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 : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
48 :
49 : /* This maps Fortran intrinsic math functions to external library or GCC
50 : builtin functions. */
51 : typedef struct GTY(()) gfc_intrinsic_map_t {
52 : /* The explicit enum is required to work around inadequacies in the
53 : garbage collection/gengtype parsing mechanism. */
54 : enum gfc_isym_id id;
55 :
56 : /* Enum value from the "language-independent", aka C-centric, part
57 : of gcc, or END_BUILTINS of no such value set. */
58 : enum built_in_function float_built_in;
59 : enum built_in_function double_built_in;
60 : enum built_in_function long_double_built_in;
61 : enum built_in_function complex_float_built_in;
62 : enum built_in_function complex_double_built_in;
63 : enum built_in_function complex_long_double_built_in;
64 :
65 : /* True if the naming pattern is to prepend "c" for complex and
66 : append "f" for kind=4. False if the naming pattern is to
67 : prepend "_gfortran_" and append "[rc](4|8|10|16)". */
68 : bool libm_name;
69 :
70 : /* True if a complex version of the function exists. */
71 : bool complex_available;
72 :
73 : /* True if the function should be marked const. */
74 : bool is_constant;
75 :
76 : /* The base library name of this function. */
77 : const char *name;
78 :
79 : /* Cache decls created for the various operand types. */
80 : tree real4_decl;
81 : tree real8_decl;
82 : tree real10_decl;
83 : tree real16_decl;
84 : tree complex4_decl;
85 : tree complex8_decl;
86 : tree complex10_decl;
87 : tree complex16_decl;
88 : }
89 : gfc_intrinsic_map_t;
90 :
91 : /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
92 : defines complex variants of all of the entries in mathbuiltins.def
93 : except for atan2. */
94 : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
95 : { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 : BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
97 : true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98 : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
99 :
100 : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101 : { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102 : BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
103 : BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
104 : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
105 :
106 : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
107 : { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 : END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 : false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
110 : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
111 :
112 : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
113 : { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
114 : BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115 : true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
116 : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
117 :
118 : static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
119 : {
120 : /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
121 : DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
122 : to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
123 : #include "mathbuiltins.def"
124 :
125 : /* Functions in libgfortran. */
126 : LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
127 : LIB_FUNCTION (SIND, "sind", false),
128 : LIB_FUNCTION (COSD, "cosd", false),
129 : LIB_FUNCTION (TAND, "tand", false),
130 :
131 : /* End the list. */
132 : LIB_FUNCTION (NONE, NULL, false)
133 :
134 : };
135 : #undef OTHER_BUILTIN
136 : #undef LIB_FUNCTION
137 : #undef DEFINE_MATH_BUILTIN
138 : #undef DEFINE_MATH_BUILTIN_C
139 :
140 :
141 : enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
142 :
143 :
144 : /* Find the correct variant of a given builtin from its argument. */
145 : static tree
146 11454 : builtin_decl_for_precision (enum built_in_function base_built_in,
147 : int precision)
148 : {
149 11454 : enum built_in_function i = END_BUILTINS;
150 :
151 11454 : gfc_intrinsic_map_t *m;
152 490551 : for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
153 : ;
154 :
155 11454 : if (precision == TYPE_PRECISION (float_type_node))
156 5814 : i = m->float_built_in;
157 5640 : else if (precision == TYPE_PRECISION (double_type_node))
158 : i = m->double_built_in;
159 1695 : else if (precision == TYPE_PRECISION (long_double_type_node)
160 1695 : && (!gfc_real16_is_float128
161 1571 : || long_double_type_node != gfc_float128_type_node))
162 1571 : i = m->long_double_built_in;
163 124 : else if (precision == TYPE_PRECISION (gfc_float128_type_node))
164 : {
165 : /* Special treatment, because it is not exactly a built-in, but
166 : a library function. */
167 124 : return m->real16_decl;
168 : }
169 :
170 11330 : return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
171 : }
172 :
173 :
174 : tree
175 10415 : gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
176 : int kind)
177 : {
178 10415 : int i = gfc_validate_kind (BT_REAL, kind, false);
179 :
180 10415 : if (gfc_real_kinds[i].c_float128)
181 : {
182 : /* For _Float128, the story is a bit different, because we return
183 : a decl to a library function rather than a built-in. */
184 : gfc_intrinsic_map_t *m;
185 36328 : for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
186 : ;
187 :
188 905 : return m->real16_decl;
189 : }
190 :
191 9510 : return builtin_decl_for_precision (double_built_in,
192 9510 : gfc_real_kinds[i].mode_precision);
193 : }
194 :
195 :
196 : /* Evaluate the arguments to an intrinsic function. The value
197 : of NARGS may be less than the actual number of arguments in EXPR
198 : to allow optional "KIND" arguments that are not included in the
199 : generated code to be ignored. */
200 :
201 : static void
202 81024 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
203 : tree *argarray, int nargs)
204 : {
205 81024 : gfc_actual_arglist *actual;
206 81024 : gfc_expr *e;
207 81024 : gfc_intrinsic_arg *formal;
208 81024 : gfc_se argse;
209 81024 : int curr_arg;
210 :
211 81024 : formal = expr->value.function.isym->formal;
212 81024 : actual = expr->value.function.actual;
213 :
214 182659 : for (curr_arg = 0; curr_arg < nargs; curr_arg++,
215 63094 : actual = actual->next,
216 101635 : formal = formal ? formal->next : NULL)
217 : {
218 101635 : gcc_assert (actual);
219 101635 : e = actual->expr;
220 : /* Skip omitted optional arguments. */
221 101635 : if (!e)
222 : {
223 31 : --curr_arg;
224 31 : continue;
225 : }
226 :
227 : /* Evaluate the parameter. This will substitute scalarized
228 : references automatically. */
229 101604 : gfc_init_se (&argse, se);
230 :
231 101604 : if (e->ts.type == BT_CHARACTER)
232 : {
233 9629 : gfc_conv_expr (&argse, e);
234 9629 : gfc_conv_string_parameter (&argse);
235 9629 : argarray[curr_arg++] = argse.string_length;
236 9629 : gcc_assert (curr_arg < nargs);
237 : }
238 : else
239 91975 : gfc_conv_expr_val (&argse, e);
240 :
241 : /* If an optional argument is itself an optional dummy argument,
242 : check its presence and substitute a null if absent. */
243 101604 : if (e->expr_type == EXPR_VARIABLE
244 51852 : && e->symtree->n.sym->attr.optional
245 203 : && formal
246 153 : && formal->optional)
247 80 : gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
248 :
249 101604 : gfc_add_block_to_block (&se->pre, &argse.pre);
250 101604 : gfc_add_block_to_block (&se->post, &argse.post);
251 101604 : argarray[curr_arg] = argse.expr;
252 : }
253 81024 : }
254 :
255 : /* Count the number of actual arguments to the intrinsic function EXPR
256 : including any "hidden" string length arguments. */
257 :
258 : static unsigned int
259 56053 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
260 : {
261 56053 : int n = 0;
262 56053 : gfc_actual_arglist *actual;
263 :
264 127299 : for (actual = expr->value.function.actual; actual; actual = actual->next)
265 : {
266 71246 : if (!actual->expr)
267 6334 : continue;
268 :
269 64912 : if (actual->expr->ts.type == BT_CHARACTER)
270 4549 : n += 2;
271 : else
272 60363 : n++;
273 : }
274 :
275 56053 : return n;
276 : }
277 :
278 :
279 : /* Conversions between different types are output by the frontend as
280 : intrinsic functions. We implement these directly with inline code. */
281 :
282 : static void
283 39933 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
284 : {
285 39933 : tree type;
286 39933 : tree *args;
287 39933 : int nargs;
288 :
289 39933 : nargs = gfc_intrinsic_argument_list_length (expr);
290 39933 : args = XALLOCAVEC (tree, nargs);
291 :
292 : /* Evaluate all the arguments passed. Whilst we're only interested in the
293 : first one here, there are other parts of the front-end that assume this
294 : and will trigger an ICE if it's not the case. */
295 39933 : type = gfc_typenode_for_spec (&expr->ts);
296 39933 : gcc_assert (expr->value.function.actual->expr);
297 39933 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
298 :
299 : /* Conversion between character kinds involves a call to a library
300 : function. */
301 39933 : if (expr->ts.type == BT_CHARACTER)
302 : {
303 248 : tree fndecl, var, addr, tmp;
304 :
305 248 : if (expr->ts.kind == 1
306 97 : && expr->value.function.actual->expr->ts.kind == 4)
307 97 : fndecl = gfor_fndecl_convert_char4_to_char1;
308 151 : else if (expr->ts.kind == 4
309 151 : && expr->value.function.actual->expr->ts.kind == 1)
310 151 : fndecl = gfor_fndecl_convert_char1_to_char4;
311 : else
312 0 : gcc_unreachable ();
313 :
314 : /* Create the variable storing the converted value. */
315 248 : type = gfc_get_pchar_type (expr->ts.kind);
316 248 : var = gfc_create_var (type, "str");
317 248 : addr = gfc_build_addr_expr (build_pointer_type (type), var);
318 :
319 : /* Call the library function that will perform the conversion. */
320 248 : gcc_assert (nargs >= 2);
321 248 : tmp = build_call_expr_loc (input_location,
322 : fndecl, 3, addr, args[0], args[1]);
323 248 : gfc_add_expr_to_block (&se->pre, tmp);
324 :
325 : /* Free the temporary afterwards. */
326 248 : tmp = gfc_call_free (var);
327 248 : gfc_add_expr_to_block (&se->post, tmp);
328 :
329 248 : se->expr = var;
330 248 : se->string_length = args[0];
331 :
332 248 : return;
333 : }
334 :
335 : /* Conversion from complex to non-complex involves taking the real
336 : component of the value. */
337 39685 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
338 39685 : && expr->ts.type != BT_COMPLEX)
339 : {
340 583 : tree artype;
341 :
342 583 : artype = TREE_TYPE (TREE_TYPE (args[0]));
343 583 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
344 : args[0]);
345 : }
346 :
347 39685 : se->expr = convert (type, args[0]);
348 : }
349 :
350 : /* This is needed because the gcc backend only implements
351 : FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
352 : FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
353 : Similarly for CEILING. */
354 :
355 : static tree
356 132 : build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
357 : {
358 132 : tree tmp;
359 132 : tree cond;
360 132 : tree argtype;
361 132 : tree intval;
362 :
363 132 : argtype = TREE_TYPE (arg);
364 132 : arg = gfc_evaluate_now (arg, pblock);
365 :
366 132 : intval = convert (type, arg);
367 132 : intval = gfc_evaluate_now (intval, pblock);
368 :
369 132 : tmp = convert (argtype, intval);
370 248 : cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
371 : logical_type_node, tmp, arg);
372 :
373 248 : tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
374 : intval, build_int_cst (type, 1));
375 132 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
376 132 : return tmp;
377 : }
378 :
379 :
380 : /* Round to nearest integer, away from zero. */
381 :
382 : static tree
383 516 : build_round_expr (tree arg, tree restype)
384 : {
385 516 : tree argtype;
386 516 : tree fn;
387 516 : int argprec, resprec;
388 :
389 516 : argtype = TREE_TYPE (arg);
390 516 : argprec = TYPE_PRECISION (argtype);
391 516 : resprec = TYPE_PRECISION (restype);
392 :
393 : /* Depending on the type of the result, choose the int intrinsic (iround,
394 : available only as a builtin, therefore cannot use it for _Float128), long
395 : int intrinsic (lround family) or long long intrinsic (llround). If we
396 : don't have an appropriate function that converts directly to the integer
397 : type (such as kind == 16), just use ROUND, and then convert the result to
398 : an integer. We might also need to convert the result afterwards. */
399 516 : if (resprec <= INT_TYPE_SIZE
400 516 : && argprec <= TYPE_PRECISION (long_double_type_node))
401 458 : fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
402 62 : else if (resprec <= LONG_TYPE_SIZE)
403 46 : fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
404 12 : else if (resprec <= LONG_LONG_TYPE_SIZE)
405 0 : fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
406 12 : else if (resprec >= argprec)
407 12 : fn = builtin_decl_for_precision (BUILT_IN_ROUND, argprec);
408 : else
409 0 : gcc_unreachable ();
410 :
411 516 : return convert (restype, build_call_expr_loc (input_location,
412 516 : fn, 1, arg));
413 : }
414 :
415 :
416 : /* Convert a real to an integer using a specific rounding mode.
417 : Ideally we would just build the corresponding GENERIC node,
418 : however the RTL expander only actually supports FIX_TRUNC_EXPR. */
419 :
420 : static tree
421 1603 : build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
422 : enum rounding_mode op)
423 : {
424 1603 : switch (op)
425 : {
426 116 : case RND_FLOOR:
427 116 : return build_fixbound_expr (pblock, arg, type, 0);
428 :
429 16 : case RND_CEIL:
430 16 : return build_fixbound_expr (pblock, arg, type, 1);
431 :
432 162 : case RND_ROUND:
433 162 : return build_round_expr (arg, type);
434 :
435 1309 : case RND_TRUNC:
436 1309 : return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
437 :
438 0 : default:
439 0 : gcc_unreachable ();
440 : }
441 : }
442 :
443 :
444 : /* Round a real value using the specified rounding mode.
445 : We use a temporary integer of that same kind size as the result.
446 : Values larger than those that can be represented by this kind are
447 : unchanged, as they will not be accurate enough to represent the
448 : rounding.
449 : huge = HUGE (KIND (a))
450 : aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
451 : */
452 :
453 : static void
454 220 : gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
455 : {
456 220 : tree type;
457 220 : tree itype;
458 220 : tree arg[2];
459 220 : tree tmp;
460 220 : tree cond;
461 220 : tree decl;
462 220 : mpfr_t huge;
463 220 : int n, nargs;
464 220 : int kind;
465 :
466 220 : kind = expr->ts.kind;
467 220 : nargs = gfc_intrinsic_argument_list_length (expr);
468 :
469 220 : decl = NULL_TREE;
470 : /* We have builtin functions for some cases. */
471 220 : switch (op)
472 : {
473 74 : case RND_ROUND:
474 74 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
475 74 : break;
476 :
477 146 : case RND_TRUNC:
478 146 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
479 146 : break;
480 :
481 0 : default:
482 0 : gcc_unreachable ();
483 : }
484 :
485 : /* Evaluate the argument. */
486 220 : gcc_assert (expr->value.function.actual->expr);
487 220 : gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
488 :
489 : /* Use a builtin function if one exists. */
490 220 : if (decl != NULL_TREE)
491 : {
492 220 : se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
493 220 : return;
494 : }
495 :
496 : /* This code is probably redundant, but we'll keep it lying around just
497 : in case. */
498 0 : type = gfc_typenode_for_spec (&expr->ts);
499 0 : arg[0] = gfc_evaluate_now (arg[0], &se->pre);
500 :
501 : /* Test if the value is too large to handle sensibly. */
502 0 : gfc_set_model_kind (kind);
503 0 : mpfr_init (huge);
504 0 : n = gfc_validate_kind (BT_INTEGER, kind, false);
505 0 : mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
506 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
507 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
508 : tmp);
509 :
510 0 : mpfr_neg (huge, huge, GFC_RND_MODE);
511 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
512 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
513 : tmp);
514 0 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
515 : cond, tmp);
516 0 : itype = gfc_get_int_type (kind);
517 :
518 0 : tmp = build_fix_expr (&se->pre, arg[0], itype, op);
519 0 : tmp = convert (type, tmp);
520 0 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
521 : arg[0]);
522 0 : mpfr_clear (huge);
523 : }
524 :
525 :
526 : /* Convert to an integer using the specified rounding mode. */
527 :
528 : static void
529 3130 : gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
530 : {
531 3130 : tree type;
532 3130 : tree *args;
533 3130 : int nargs;
534 :
535 3130 : nargs = gfc_intrinsic_argument_list_length (expr);
536 3130 : args = XALLOCAVEC (tree, nargs);
537 :
538 : /* Evaluate the argument, we process all arguments even though we only
539 : use the first one for code generation purposes. */
540 3130 : type = gfc_typenode_for_spec (&expr->ts);
541 3130 : gcc_assert (expr->value.function.actual->expr);
542 3130 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
543 :
544 3130 : if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
545 : {
546 : /* Conversion to a different integer kind. */
547 1527 : se->expr = convert (type, args[0]);
548 : }
549 : else
550 : {
551 : /* Conversion from complex to non-complex involves taking the real
552 : component of the value. */
553 1603 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
554 1603 : && expr->ts.type != BT_COMPLEX)
555 : {
556 192 : tree artype;
557 :
558 192 : artype = TREE_TYPE (TREE_TYPE (args[0]));
559 192 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
560 : args[0]);
561 : }
562 :
563 1603 : se->expr = build_fix_expr (&se->pre, args[0], type, op);
564 : }
565 3130 : }
566 :
567 :
568 : /* Get the imaginary component of a value. */
569 :
570 : static void
571 440 : gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
572 : {
573 440 : tree arg;
574 :
575 440 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
576 440 : se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
577 440 : TREE_TYPE (TREE_TYPE (arg)), arg);
578 440 : }
579 :
580 :
581 : /* Get the complex conjugate of a value. */
582 :
583 : static void
584 257 : gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
585 : {
586 257 : tree arg;
587 :
588 257 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
589 257 : se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
590 257 : }
591 :
592 :
593 :
594 : static tree
595 662781 : define_quad_builtin (const char *name, tree type, bool is_const)
596 : {
597 662781 : tree fndecl;
598 662781 : fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
599 : type);
600 :
601 : /* Mark the decl as external. */
602 662781 : DECL_EXTERNAL (fndecl) = 1;
603 662781 : TREE_PUBLIC (fndecl) = 1;
604 :
605 : /* Mark it __attribute__((const)). */
606 662781 : TREE_READONLY (fndecl) = is_const;
607 :
608 662781 : rest_of_decl_compilation (fndecl, 1, 0);
609 :
610 662781 : return fndecl;
611 : }
612 :
613 : /* Add SIMD attribute for FNDECL built-in if the built-in
614 : name is in VECTORIZED_BUILTINS. */
615 :
616 : static void
617 45320260 : add_simd_flag_for_built_in (tree fndecl)
618 : {
619 45320260 : if (gfc_vectorized_builtins == NULL
620 18200910 : || fndecl == NULL_TREE)
621 37453765 : return;
622 :
623 7866495 : const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
624 7866495 : int *clauses = gfc_vectorized_builtins->get (name);
625 7866495 : if (clauses)
626 : {
627 4935228 : for (unsigned i = 0; i < 3; i++)
628 3701421 : if (*clauses & (1 << i))
629 : {
630 1233812 : gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
631 1233812 : tree omp_clause = NULL_TREE;
632 1233812 : if (simd_type == SIMD_NONE)
633 : ; /* No SIMD clause. */
634 : else
635 : {
636 1233812 : omp_clause_code code
637 : = (simd_type == SIMD_INBRANCH
638 1233812 : ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
639 1233812 : omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
640 1233812 : omp_clause = build_tree_list (NULL_TREE, omp_clause);
641 : }
642 :
643 1233812 : DECL_ATTRIBUTES (fndecl)
644 2467624 : = tree_cons (get_identifier ("omp declare simd"), omp_clause,
645 1233812 : DECL_ATTRIBUTES (fndecl));
646 : }
647 : }
648 : }
649 :
650 : /* Set SIMD attribute to all built-in functions that are mentioned
651 : in gfc_vectorized_builtins vector. */
652 :
653 : void
654 76814 : gfc_adjust_builtins (void)
655 : {
656 76814 : gfc_intrinsic_map_t *m;
657 4608840 : for (m = gfc_intrinsic_map;
658 4608840 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
659 : {
660 4532026 : add_simd_flag_for_built_in (m->real4_decl);
661 4532026 : add_simd_flag_for_built_in (m->complex4_decl);
662 4532026 : add_simd_flag_for_built_in (m->real8_decl);
663 4532026 : add_simd_flag_for_built_in (m->complex8_decl);
664 4532026 : add_simd_flag_for_built_in (m->real10_decl);
665 4532026 : add_simd_flag_for_built_in (m->complex10_decl);
666 4532026 : add_simd_flag_for_built_in (m->real16_decl);
667 4532026 : add_simd_flag_for_built_in (m->complex16_decl);
668 4532026 : add_simd_flag_for_built_in (m->real16_decl);
669 4532026 : add_simd_flag_for_built_in (m->complex16_decl);
670 : }
671 :
672 : /* Release all strings. */
673 76814 : if (gfc_vectorized_builtins != NULL)
674 : {
675 1696486 : for (hash_map<nofree_string_hash, int>::iterator it
676 30849 : = gfc_vectorized_builtins->begin ();
677 1696486 : it != gfc_vectorized_builtins->end (); ++it)
678 1665637 : free (const_cast<char *> ((*it).first));
679 :
680 61698 : delete gfc_vectorized_builtins;
681 30849 : gfc_vectorized_builtins = NULL;
682 : }
683 76814 : }
684 :
685 : /* Initialize function decls for library functions. The external functions
686 : are created as required. Builtin functions are added here. */
687 :
688 : void
689 31561 : gfc_build_intrinsic_lib_fndecls (void)
690 : {
691 31561 : gfc_intrinsic_map_t *m;
692 31561 : tree quad_decls[END_BUILTINS + 1];
693 :
694 31561 : if (gfc_real16_is_float128)
695 : {
696 : /* If we have soft-float types, we create the decls for their
697 : C99-like library functions. For now, we only handle _Float128
698 : q-suffixed or IEC 60559 f128-suffixed functions. */
699 :
700 31561 : tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
701 31561 : tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
702 :
703 31561 : memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
704 :
705 31561 : type = gfc_float128_type_node;
706 31561 : complex_type = gfc_complex_float128_type_node;
707 : /* type (*) (type) */
708 31561 : func_1 = build_function_type_list (type, type, NULL_TREE);
709 : /* int (*) (type) */
710 31561 : func_iround = build_function_type_list (integer_type_node,
711 : type, NULL_TREE);
712 : /* long (*) (type) */
713 31561 : func_lround = build_function_type_list (long_integer_type_node,
714 : type, NULL_TREE);
715 : /* long long (*) (type) */
716 31561 : func_llround = build_function_type_list (long_long_integer_type_node,
717 : type, NULL_TREE);
718 : /* type (*) (type, type) */
719 31561 : func_2 = build_function_type_list (type, type, type, NULL_TREE);
720 : /* type (*) (type, type, type) */
721 31561 : func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
722 : /* type (*) (type, &int) */
723 31561 : func_frexp
724 31561 : = build_function_type_list (type,
725 : type,
726 : build_pointer_type (integer_type_node),
727 : NULL_TREE);
728 : /* type (*) (type, int) */
729 31561 : func_scalbn = build_function_type_list (type,
730 : type, integer_type_node, NULL_TREE);
731 : /* type (*) (complex type) */
732 31561 : func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
733 : /* complex type (*) (complex type, complex type) */
734 31561 : func_cpow
735 31561 : = build_function_type_list (complex_type,
736 : complex_type, complex_type, NULL_TREE);
737 :
738 : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
739 : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
740 : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
741 :
742 : /* Only these built-ins are actually needed here. These are used directly
743 : from the code, when calling builtin_decl_for_precision() or
744 : builtin_decl_for_float_type(). The others are all constructed by
745 : gfc_get_intrinsic_lib_fndecl(). */
746 : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
747 : quad_decls[BUILT_IN_ ## ID] \
748 : = define_quad_builtin (gfc_real16_use_iec_60559 \
749 : ? NAME "f128" : NAME "q", func_ ## TYPE, \
750 : CONST);
751 :
752 : #include "mathbuiltins.def"
753 :
754 : #undef OTHER_BUILTIN
755 : #undef LIB_FUNCTION
756 : #undef DEFINE_MATH_BUILTIN
757 : #undef DEFINE_MATH_BUILTIN_C
758 :
759 : /* There is one built-in we defined manually, because it gets called
760 : with builtin_decl_for_precision() or builtin_decl_for_float_type()
761 : even though it is not an OTHER_BUILTIN: it is SQRT. */
762 31561 : quad_decls[BUILT_IN_SQRT]
763 31561 : = define_quad_builtin (gfc_real16_use_iec_60559
764 : ? "sqrtf128" : "sqrtq", func_1, true);
765 : }
766 :
767 : /* Add GCC builtin functions. */
768 1862099 : for (m = gfc_intrinsic_map;
769 1893660 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
770 : {
771 1862099 : if (m->float_built_in != END_BUILTINS)
772 1735855 : m->real4_decl = builtin_decl_explicit (m->float_built_in);
773 1862099 : if (m->complex_float_built_in != END_BUILTINS)
774 504976 : m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
775 1862099 : if (m->double_built_in != END_BUILTINS)
776 1735855 : m->real8_decl = builtin_decl_explicit (m->double_built_in);
777 1862099 : if (m->complex_double_built_in != END_BUILTINS)
778 504976 : m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
779 :
780 : /* If real(kind=10) exists, it is always long double. */
781 1862099 : if (m->long_double_built_in != END_BUILTINS)
782 1735855 : m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
783 1862099 : if (m->complex_long_double_built_in != END_BUILTINS)
784 504976 : m->complex10_decl
785 504976 : = builtin_decl_explicit (m->complex_long_double_built_in);
786 :
787 1862099 : if (!gfc_real16_is_float128)
788 : {
789 0 : if (m->long_double_built_in != END_BUILTINS)
790 0 : m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
791 0 : if (m->complex_long_double_built_in != END_BUILTINS)
792 0 : m->complex16_decl
793 0 : = builtin_decl_explicit (m->complex_long_double_built_in);
794 : }
795 1862099 : else if (quad_decls[m->double_built_in] != NULL_TREE)
796 : {
797 : /* Quad-precision function calls are constructed when first
798 : needed by builtin_decl_for_precision(), except for those
799 : that will be used directly (define by OTHER_BUILTIN). */
800 662781 : m->real16_decl = quad_decls[m->double_built_in];
801 : }
802 1199318 : else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
803 : {
804 : /* Same thing for the complex ones. */
805 0 : m->complex16_decl = quad_decls[m->double_built_in];
806 : }
807 : }
808 31561 : }
809 :
810 :
811 : /* Create a fndecl for a simple intrinsic library function. */
812 :
813 : static tree
814 4418 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
815 : {
816 4418 : tree type;
817 4418 : vec<tree, va_gc> *argtypes;
818 4418 : tree fndecl;
819 4418 : gfc_actual_arglist *actual;
820 4418 : tree *pdecl;
821 4418 : gfc_typespec *ts;
822 4418 : char name[GFC_MAX_SYMBOL_LEN + 3];
823 :
824 4418 : ts = &expr->ts;
825 4418 : if (ts->type == BT_REAL)
826 : {
827 3556 : switch (ts->kind)
828 : {
829 1273 : case 4:
830 1273 : pdecl = &m->real4_decl;
831 1273 : break;
832 1272 : case 8:
833 1272 : pdecl = &m->real8_decl;
834 1272 : break;
835 570 : case 10:
836 570 : pdecl = &m->real10_decl;
837 570 : break;
838 441 : case 16:
839 441 : pdecl = &m->real16_decl;
840 441 : break;
841 0 : default:
842 0 : gcc_unreachable ();
843 : }
844 : }
845 862 : else if (ts->type == BT_COMPLEX)
846 : {
847 862 : gcc_assert (m->complex_available);
848 :
849 862 : switch (ts->kind)
850 : {
851 386 : case 4:
852 386 : pdecl = &m->complex4_decl;
853 386 : break;
854 405 : case 8:
855 405 : pdecl = &m->complex8_decl;
856 405 : break;
857 51 : case 10:
858 51 : pdecl = &m->complex10_decl;
859 51 : break;
860 20 : case 16:
861 20 : pdecl = &m->complex16_decl;
862 20 : break;
863 0 : default:
864 0 : gcc_unreachable ();
865 : }
866 : }
867 : else
868 0 : gcc_unreachable ();
869 :
870 4418 : if (*pdecl)
871 4080 : return *pdecl;
872 :
873 338 : if (m->libm_name)
874 : {
875 161 : int n = gfc_validate_kind (BT_REAL, ts->kind, false);
876 161 : if (gfc_real_kinds[n].c_float)
877 0 : snprintf (name, sizeof (name), "%s%s%s",
878 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
879 161 : else if (gfc_real_kinds[n].c_double)
880 0 : snprintf (name, sizeof (name), "%s%s",
881 0 : ts->type == BT_COMPLEX ? "c" : "", m->name);
882 161 : else if (gfc_real_kinds[n].c_long_double)
883 0 : snprintf (name, sizeof (name), "%s%s%s",
884 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
885 161 : else if (gfc_real_kinds[n].c_float128)
886 161 : snprintf (name, sizeof (name), "%s%s%s",
887 161 : ts->type == BT_COMPLEX ? "c" : "", m->name,
888 161 : gfc_real_kinds[n].use_iec_60559 ? "f128" : "q");
889 : else
890 0 : gcc_unreachable ();
891 : }
892 : else
893 : {
894 354 : snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
895 177 : ts->type == BT_COMPLEX ? 'c' : 'r',
896 : gfc_type_abi_kind (ts));
897 : }
898 :
899 338 : argtypes = NULL;
900 692 : for (actual = expr->value.function.actual; actual; actual = actual->next)
901 : {
902 354 : type = gfc_typenode_for_spec (&actual->expr->ts);
903 354 : vec_safe_push (argtypes, type);
904 : }
905 1014 : type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
906 338 : fndecl = build_decl (input_location,
907 : FUNCTION_DECL, get_identifier (name), type);
908 :
909 : /* Mark the decl as external. */
910 338 : DECL_EXTERNAL (fndecl) = 1;
911 338 : TREE_PUBLIC (fndecl) = 1;
912 :
913 : /* Mark it __attribute__((const)), if possible. */
914 338 : TREE_READONLY (fndecl) = m->is_constant;
915 :
916 338 : rest_of_decl_compilation (fndecl, 1, 0);
917 :
918 338 : (*pdecl) = fndecl;
919 338 : return fndecl;
920 : }
921 :
922 :
923 : /* Convert an intrinsic function into an external or builtin call. */
924 :
925 : static void
926 3872 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
927 : {
928 3872 : gfc_intrinsic_map_t *m;
929 3872 : tree fndecl;
930 3872 : tree rettype;
931 3872 : tree *args;
932 3872 : unsigned int num_args;
933 3872 : gfc_isym_id id;
934 :
935 3872 : id = expr->value.function.isym->id;
936 : /* Find the entry for this function. */
937 79631 : for (m = gfc_intrinsic_map;
938 79631 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
939 : {
940 79631 : if (id == m->id)
941 : break;
942 : }
943 :
944 3872 : if (m->id == GFC_ISYM_NONE)
945 : {
946 0 : gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
947 : expr->value.function.name, id);
948 : }
949 :
950 : /* Get the decl and generate the call. */
951 3872 : num_args = gfc_intrinsic_argument_list_length (expr);
952 3872 : args = XALLOCAVEC (tree, num_args);
953 :
954 3872 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
955 3872 : fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
956 3872 : rettype = TREE_TYPE (TREE_TYPE (fndecl));
957 :
958 3872 : fndecl = build_addr (fndecl);
959 3872 : se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
960 3872 : }
961 :
962 :
963 : /* If bounds-checking is enabled, create code to verify at runtime that the
964 : string lengths for both expressions are the same (needed for e.g. MERGE).
965 : If bounds-checking is not enabled, does nothing. */
966 :
967 : void
968 1550 : gfc_trans_same_strlen_check (const char* intr_name, locus* where,
969 : tree a, tree b, stmtblock_t* target)
970 : {
971 1550 : tree cond;
972 1550 : tree name;
973 :
974 : /* If bounds-checking is disabled, do nothing. */
975 1550 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
976 : return;
977 :
978 : /* Compare the two string lengths. */
979 94 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
980 :
981 : /* Output the runtime-check. */
982 94 : name = gfc_build_cstring_const (intr_name);
983 94 : name = gfc_build_addr_expr (pchar_type_node, name);
984 94 : gfc_trans_runtime_check (true, false, cond, target, where,
985 : "Unequal character lengths (%ld/%ld) in %s",
986 : fold_convert (long_integer_type_node, a),
987 : fold_convert (long_integer_type_node, b), name);
988 : }
989 :
990 :
991 : /* The EXPONENT(X) intrinsic function is translated into
992 : int ret;
993 : return isfinite(X) ? (frexp (X, &ret) , ret) : huge
994 : so that if X is a NaN or infinity, the result is HUGE(0).
995 : */
996 :
997 : static void
998 228 : gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
999 : {
1000 228 : tree arg, type, res, tmp, frexp, cond, huge;
1001 228 : int i;
1002 :
1003 456 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
1004 228 : expr->value.function.actual->expr->ts.kind);
1005 :
1006 228 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1007 228 : arg = gfc_evaluate_now (arg, &se->pre);
1008 :
1009 228 : i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1010 228 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1011 228 : cond = build_call_expr_loc (input_location,
1012 : builtin_decl_explicit (BUILT_IN_ISFINITE),
1013 : 1, arg);
1014 :
1015 228 : res = gfc_create_var (integer_type_node, NULL);
1016 228 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1017 : gfc_build_addr_expr (NULL_TREE, res));
1018 228 : tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
1019 : tmp, res);
1020 228 : se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1021 : cond, tmp, huge);
1022 :
1023 228 : type = gfc_typenode_for_spec (&expr->ts);
1024 228 : se->expr = fold_convert (type, se->expr);
1025 228 : }
1026 :
1027 :
1028 : static int caf_call_cnt = 0;
1029 :
1030 : static tree
1031 1434 : conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
1032 : gfc_expr *hash)
1033 : {
1034 1434 : char *name;
1035 1434 : gfc_se argse;
1036 1434 : gfc_expr func_index;
1037 1434 : gfc_symtree *index_st;
1038 1434 : tree func_index_tree;
1039 1434 : stmtblock_t blk;
1040 :
1041 : /* Need to get namespace where static variables are possible. */
1042 1434 : while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
1043 0 : ns = ns->parent;
1044 1434 : gcc_assert (ns);
1045 :
1046 1434 : name = xasprintf (pat, caf_call_cnt);
1047 1434 : gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
1048 1434 : free (name);
1049 :
1050 1434 : index_st->n.sym->attr.flavor = FL_VARIABLE;
1051 1434 : index_st->n.sym->attr.save = SAVE_EXPLICIT;
1052 1434 : index_st->n.sym->value
1053 1434 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1054 : &gfc_current_locus);
1055 1434 : mpz_set_si (index_st->n.sym->value->value.integer, -1);
1056 1434 : index_st->n.sym->ts.type = BT_INTEGER;
1057 1434 : index_st->n.sym->ts.kind = gfc_default_integer_kind;
1058 1434 : gfc_set_sym_referenced (index_st->n.sym);
1059 1434 : memset (&func_index, 0, sizeof (gfc_expr));
1060 1434 : gfc_clear_ts (&func_index.ts);
1061 1434 : func_index.expr_type = EXPR_VARIABLE;
1062 1434 : func_index.symtree = index_st;
1063 1434 : func_index.ts = index_st->n.sym->ts;
1064 1434 : gfc_commit_symbol (index_st->n.sym);
1065 :
1066 1434 : gfc_init_se (&argse, NULL);
1067 1434 : gfc_conv_expr (&argse, &func_index);
1068 1434 : gfc_add_block_to_block (block, &argse.pre);
1069 1434 : func_index_tree = argse.expr;
1070 :
1071 1434 : gfc_init_se (&argse, NULL);
1072 1434 : gfc_conv_expr (&argse, hash);
1073 :
1074 1434 : gfc_init_block (&blk);
1075 1434 : gfc_add_modify (&blk, func_index_tree,
1076 : build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1,
1077 : argse.expr));
1078 1434 : gfc_add_expr_to_block (
1079 : block,
1080 : build3 (COND_EXPR, void_type_node,
1081 : gfc_likely (build2 (EQ_EXPR, logical_type_node, func_index_tree,
1082 : build_int_cst (integer_type_node, -1)),
1083 : PRED_FIRST_MATCH),
1084 : gfc_finish_block (&blk), NULL_TREE));
1085 :
1086 1434 : return func_index_tree;
1087 : }
1088 :
1089 : static tree
1090 1434 : conv_caf_add_call_data (stmtblock_t *blk, gfc_namespace *ns, const char *pat,
1091 : gfc_symbol *data_sym, tree *data_size)
1092 : {
1093 1434 : char *name;
1094 1434 : gfc_symtree *data_st;
1095 1434 : gfc_constructor *con;
1096 1434 : gfc_expr data, data_init;
1097 1434 : gfc_se argse;
1098 1434 : tree data_tree;
1099 :
1100 1434 : memset (&data, 0, sizeof (gfc_expr));
1101 1434 : gfc_clear_ts (&data.ts);
1102 1434 : data.expr_type = EXPR_VARIABLE;
1103 1434 : name = xasprintf (pat, caf_call_cnt);
1104 1434 : gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false));
1105 1434 : free (name);
1106 1434 : data_st->n.sym->attr.flavor = FL_VARIABLE;
1107 1434 : data_st->n.sym->ts = data_sym->ts;
1108 1434 : data.symtree = data_st;
1109 1434 : gfc_set_sym_referenced (data.symtree->n.sym);
1110 1434 : data.ts = data_st->n.sym->ts;
1111 1434 : gfc_commit_symbol (data_st->n.sym);
1112 :
1113 1434 : memset (&data_init, 0, sizeof (gfc_expr));
1114 1434 : gfc_clear_ts (&data_init.ts);
1115 1434 : data_init.expr_type = EXPR_STRUCTURE;
1116 1434 : data_init.ts = data.ts;
1117 1750 : for (gfc_component *comp = data.ts.u.derived->components; comp;
1118 316 : comp = comp->next)
1119 : {
1120 316 : con = gfc_constructor_get ();
1121 316 : con->expr = comp->initializer;
1122 316 : comp->initializer = NULL;
1123 316 : gfc_constructor_append (&data_init.value.constructor, con);
1124 : }
1125 :
1126 1434 : if (data.ts.u.derived->components)
1127 : {
1128 110 : gfc_init_se (&argse, NULL);
1129 110 : gfc_conv_expr (&argse, &data);
1130 110 : data_tree = argse.expr;
1131 110 : gfc_add_expr_to_block (blk,
1132 : gfc_trans_structure_assign (data_tree, &data_init,
1133 : true, true));
1134 110 : gfc_constructor_free (data_init.value.constructor);
1135 110 : *data_size = TREE_TYPE (data_tree)->type_common.size_unit;
1136 110 : data_tree = gfc_build_addr_expr (pvoid_type_node, data_tree);
1137 : }
1138 : else
1139 : {
1140 1324 : data_tree = build_zero_cst (pvoid_type_node);
1141 1324 : *data_size = build_zero_cst (size_type_node);
1142 : }
1143 :
1144 1434 : return data_tree;
1145 : }
1146 :
1147 : static tree
1148 251 : conv_shape_to_cst (gfc_expr *e)
1149 : {
1150 251 : tree tmp = NULL;
1151 690 : for (int d = 0; d < e->rank; ++d)
1152 : {
1153 439 : if (!tmp)
1154 251 : tmp = gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind);
1155 : else
1156 188 : tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp,
1157 : gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind));
1158 : }
1159 251 : return fold_convert (size_type_node, tmp);
1160 : }
1161 :
1162 : static void
1163 1267 : conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
1164 : tree *team_no)
1165 : {
1166 1267 : gfc_expr *stat_e, *team_e;
1167 :
1168 1267 : stat_e = gfc_find_stat_co (expr);
1169 1267 : if (stat_e)
1170 : {
1171 33 : gfc_se stat_se;
1172 33 : gfc_init_se (&stat_se, NULL);
1173 33 : gfc_conv_expr_reference (&stat_se, stat_e);
1174 33 : *stat = stat_se.expr;
1175 33 : gfc_add_block_to_block (block, &stat_se.pre);
1176 33 : gfc_add_block_to_block (block, &stat_se.post);
1177 : }
1178 : else
1179 1234 : *stat = null_pointer_node;
1180 :
1181 1267 : team_e = gfc_find_team_co (expr, TEAM_TEAM);
1182 1267 : if (team_e)
1183 : {
1184 18 : gfc_se team_se;
1185 18 : gfc_init_se (&team_se, NULL);
1186 18 : gfc_conv_expr (&team_se, team_e);
1187 18 : *team
1188 18 : = gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre,
1189 : team_se.expr));
1190 18 : gfc_add_block_to_block (block, &team_se.pre);
1191 18 : gfc_add_block_to_block (block, &team_se.post);
1192 : }
1193 : else
1194 1249 : *team = null_pointer_node;
1195 :
1196 1267 : team_e = gfc_find_team_co (expr, TEAM_NUMBER);
1197 1267 : if (team_e)
1198 : {
1199 30 : gfc_se team_se;
1200 30 : gfc_init_se (&team_se, NULL);
1201 30 : gfc_conv_expr (&team_se, team_e);
1202 30 : *team_no = gfc_build_addr_expr (
1203 : NULL_TREE,
1204 : gfc_trans_force_lval (&team_se.pre,
1205 : fold_convert (integer_type_node, team_se.expr)));
1206 30 : gfc_add_block_to_block (block, &team_se.pre);
1207 30 : gfc_add_block_to_block (block, &team_se.post);
1208 : }
1209 : else
1210 1237 : *team_no = null_pointer_node;
1211 1267 : }
1212 :
1213 : /* Get data from a remote coarray. */
1214 :
1215 : static void
1216 1006 : gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
1217 : bool may_realloc, symbol_attribute *caf_attr)
1218 : {
1219 1006 : gfc_expr *array_expr;
1220 1006 : tree caf_decl, token, image_index, tmp, res_var, type, stat, dest_size,
1221 : dest_data, opt_dest_desc, get_fn_index_tree, add_data_tree, add_data_size,
1222 : opt_src_desc, opt_src_charlen, opt_dest_charlen, team, team_no;
1223 1006 : symbol_attribute caf_attr_store;
1224 1006 : gfc_namespace *ns;
1225 1006 : gfc_expr *get_fn_hash = expr->value.function.actual->next->expr,
1226 1006 : *get_fn_expr = expr->value.function.actual->next->next->expr;
1227 1006 : gfc_symbol *add_data_sym = get_fn_expr->symtree->n.sym->formal->sym;
1228 :
1229 1006 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1230 :
1231 1006 : if (se->ss && se->ss->info->useflags)
1232 : {
1233 : /* Access the previously obtained result. */
1234 379 : gfc_conv_tmp_array_ref (se);
1235 379 : return;
1236 : }
1237 :
1238 627 : array_expr = expr->value.function.actual->expr;
1239 627 : ns = array_expr->expr_type == EXPR_VARIABLE
1240 627 : && !array_expr->symtree->n.sym->attr.associate_var
1241 571 : && !array_expr->symtree->n.sym->module
1242 627 : ? array_expr->symtree->n.sym->ns
1243 : : gfc_current_ns;
1244 627 : type = gfc_typenode_for_spec (&array_expr->ts);
1245 :
1246 627 : if (caf_attr == NULL)
1247 : {
1248 627 : caf_attr_store = gfc_caf_attr (array_expr);
1249 627 : caf_attr = &caf_attr_store;
1250 : }
1251 :
1252 627 : res_var = lhs;
1253 :
1254 627 : conv_stat_and_team (&se->pre, expr, &stat, &team, &team_no);
1255 :
1256 627 : get_fn_index_tree
1257 627 : = conv_caf_func_index (&se->pre, ns, "__caf_get_from_remote_fn_index_%d",
1258 : get_fn_hash);
1259 627 : add_data_tree
1260 627 : = conv_caf_add_call_data (&se->pre, ns, "__caf_get_from_remote_add_data_%d",
1261 : add_data_sym, &add_data_size);
1262 627 : ++caf_call_cnt;
1263 :
1264 627 : if (array_expr->rank == 0)
1265 : {
1266 246 : res_var = gfc_create_var (type, "caf_res");
1267 246 : if (array_expr->ts.type == BT_CHARACTER)
1268 : {
1269 33 : gfc_conv_string_length (array_expr->ts.u.cl, array_expr, &se->pre);
1270 33 : se->string_length = array_expr->ts.u.cl->backend_decl;
1271 33 : opt_src_charlen = gfc_build_addr_expr (
1272 : NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1273 33 : dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1274 : }
1275 : else
1276 : {
1277 213 : dest_size = res_var->typed.type->type_common.size_unit;
1278 213 : opt_src_charlen
1279 213 : = build_zero_cst (build_pointer_type (size_type_node));
1280 : }
1281 246 : dest_data
1282 246 : = gfc_evaluate_now (gfc_build_addr_expr (NULL_TREE, res_var), &se->pre);
1283 246 : res_var = build_fold_indirect_ref (dest_data);
1284 246 : dest_data = gfc_build_addr_expr (pvoid_type_node, dest_data);
1285 246 : opt_dest_desc = build_zero_cst (pvoid_type_node);
1286 : }
1287 : else
1288 : {
1289 : /* Create temporary. */
1290 381 : may_realloc = gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
1291 : type, NULL_TREE, false, false,
1292 : false, &array_expr->where)
1293 : == NULL_TREE;
1294 381 : res_var = se->ss->info->data.array.descriptor;
1295 381 : if (array_expr->ts.type == BT_CHARACTER)
1296 : {
1297 16 : se->string_length = array_expr->ts.u.cl->backend_decl;
1298 16 : opt_src_charlen = gfc_build_addr_expr (
1299 : NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1300 16 : dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1301 : }
1302 : else
1303 : {
1304 365 : opt_src_charlen
1305 365 : = build_zero_cst (build_pointer_type (size_type_node));
1306 365 : dest_size = fold_build2 (
1307 : MULT_EXPR, size_type_node,
1308 : fold_convert (size_type_node,
1309 : array_expr->shape
1310 : ? conv_shape_to_cst (array_expr)
1311 : : gfc_conv_descriptor_size (res_var,
1312 : array_expr->rank)),
1313 : fold_convert (size_type_node,
1314 : gfc_conv_descriptor_span_get (res_var)));
1315 : }
1316 381 : opt_dest_desc = res_var;
1317 381 : dest_data = gfc_conv_descriptor_data_get (res_var);
1318 381 : opt_dest_desc = gfc_build_addr_expr (NULL_TREE, opt_dest_desc);
1319 381 : if (may_realloc)
1320 : {
1321 62 : tmp = gfc_conv_descriptor_data_get (res_var);
1322 62 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
1323 : NULL_TREE, NULL_TREE, true, NULL,
1324 : GFC_CAF_COARRAY_NOCOARRAY);
1325 62 : gfc_add_expr_to_block (&se->post, tmp);
1326 : }
1327 381 : dest_data
1328 381 : = gfc_build_addr_expr (NULL_TREE,
1329 : gfc_trans_force_lval (&se->pre, dest_data));
1330 : }
1331 :
1332 627 : opt_dest_charlen = opt_src_charlen;
1333 627 : caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1334 627 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1335 2 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1336 :
1337 627 : if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank
1338 627 : || GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)))
1339 546 : opt_src_desc = build_zero_cst (pvoid_type_node);
1340 : else
1341 81 : opt_src_desc = gfc_build_addr_expr (pvoid_type_node, caf_decl);
1342 :
1343 627 : image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1344 627 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, array_expr);
1345 :
1346 : /* It guarantees memory consistency within the same segment. */
1347 627 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1348 627 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1349 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1350 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1351 627 : ASM_VOLATILE_P (tmp) = 1;
1352 627 : gfc_add_expr_to_block (&se->pre, tmp);
1353 :
1354 627 : tmp = build_call_expr_loc (
1355 : input_location, gfor_fndecl_caf_get_from_remote, 15, token, opt_src_desc,
1356 : opt_src_charlen, image_index, dest_size, dest_data, opt_dest_charlen,
1357 : opt_dest_desc, constant_boolean_node (may_realloc, boolean_type_node),
1358 : get_fn_index_tree, add_data_tree, add_data_size, stat, team, team_no);
1359 :
1360 627 : gfc_add_expr_to_block (&se->pre, tmp);
1361 :
1362 627 : if (se->ss)
1363 381 : gfc_advance_se_ss_chain (se);
1364 :
1365 627 : se->expr = res_var;
1366 :
1367 627 : return;
1368 : }
1369 :
1370 : /* Generate call to caf_is_present_on_remote for allocated (coarrary[...])
1371 : calls. */
1372 :
1373 : static void
1374 167 : gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
1375 : {
1376 167 : gfc_expr *caf_expr, *hash, *present_fn;
1377 167 : gfc_symbol *add_data_sym;
1378 167 : tree fn_index, add_data_tree, add_data_size, caf_decl, image_index, token;
1379 :
1380 167 : gcc_assert (e->expr_type == EXPR_FUNCTION
1381 : && e->value.function.isym->id
1382 : == GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE);
1383 167 : caf_expr = e->value.function.actual->expr;
1384 167 : hash = e->value.function.actual->next->expr;
1385 167 : present_fn = e->value.function.actual->next->next->expr;
1386 167 : add_data_sym = present_fn->symtree->n.sym->formal->sym;
1387 :
1388 167 : fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns,
1389 : "__caf_present_on_remote_fn_index_%d", hash);
1390 167 : add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns,
1391 : "__caf_present_on_remote_add_data_%d",
1392 : add_data_sym, &add_data_size);
1393 167 : ++caf_call_cnt;
1394 :
1395 167 : caf_decl = gfc_get_tree_for_caf_expr (caf_expr);
1396 167 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1397 4 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1398 :
1399 167 : image_index = gfc_caf_get_image_index (&se->pre, caf_expr, caf_decl);
1400 167 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, caf_expr);
1401 :
1402 167 : se->expr
1403 167 : = fold_convert (logical_type_node,
1404 : build_call_expr_loc (input_location,
1405 : gfor_fndecl_caf_is_present_on_remote,
1406 : 5, token, image_index, fn_index,
1407 : add_data_tree, add_data_size));
1408 167 : }
1409 :
1410 : static tree
1411 360 : conv_caf_send_to_remote (gfc_code *code)
1412 : {
1413 360 : gfc_expr *lhs_expr, *rhs_expr, *lhs_hash, *receiver_fn_expr;
1414 360 : gfc_symbol *add_data_sym;
1415 360 : gfc_se lhs_se, rhs_se;
1416 360 : stmtblock_t block;
1417 360 : gfc_namespace *ns;
1418 360 : tree caf_decl, token, rhs_size, image_index, tmp, rhs_data;
1419 360 : tree lhs_stat, lhs_team, lhs_team_no, opt_lhs_charlen, opt_rhs_charlen;
1420 360 : tree opt_lhs_desc = NULL_TREE, opt_rhs_desc = NULL_TREE;
1421 360 : tree receiver_fn_index_tree, add_data_tree, add_data_size;
1422 :
1423 360 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1424 360 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SEND);
1425 :
1426 360 : lhs_expr = code->ext.actual->expr;
1427 360 : rhs_expr = code->ext.actual->next->expr;
1428 360 : lhs_hash = code->ext.actual->next->next->expr;
1429 360 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1430 360 : add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1431 :
1432 360 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1433 360 : && !lhs_expr->symtree->n.sym->attr.associate_var
1434 360 : ? lhs_expr->symtree->n.sym->ns
1435 : : gfc_current_ns;
1436 :
1437 360 : gfc_init_block (&block);
1438 :
1439 : /* LHS. */
1440 360 : gfc_init_se (&lhs_se, NULL);
1441 360 : caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1442 360 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1443 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1444 360 : if (lhs_expr->rank == 0)
1445 : {
1446 266 : if (lhs_expr->ts.type == BT_CHARACTER)
1447 : {
1448 24 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1449 24 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1450 24 : opt_lhs_charlen = gfc_build_addr_expr (
1451 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1452 : }
1453 : else
1454 242 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1455 266 : opt_lhs_desc = null_pointer_node;
1456 : }
1457 : else
1458 : {
1459 94 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1460 94 : gfc_add_block_to_block (&block, &lhs_se.pre);
1461 94 : opt_lhs_desc = lhs_se.expr;
1462 94 : if (lhs_expr->ts.type == BT_CHARACTER)
1463 44 : opt_lhs_charlen = gfc_build_addr_expr (
1464 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1465 : else
1466 50 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1467 : /* Get the third formal argument of the receiver function. (This is the
1468 : location where to put the data on the remote image.) Need to look at
1469 : the argument in the function decl, because in the gfc_symbol's formal
1470 : argument an array may have no descriptor while in the generated
1471 : function decl it has. */
1472 94 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1473 : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1474 94 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1475 56 : opt_lhs_desc = null_pointer_node;
1476 : else
1477 38 : opt_lhs_desc
1478 38 : = gfc_build_addr_expr (NULL_TREE,
1479 : gfc_trans_force_lval (&block, opt_lhs_desc));
1480 : }
1481 :
1482 : /* Obtain token, offset and image index for the LHS. */
1483 360 : image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
1484 360 : gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL, lhs_expr);
1485 :
1486 : /* RHS. */
1487 360 : gfc_init_se (&rhs_se, NULL);
1488 360 : if (rhs_expr->rank == 0)
1489 : {
1490 436 : rhs_se.want_pointer = rhs_expr->ts.type == BT_CHARACTER
1491 218 : && rhs_expr->expr_type != EXPR_CONSTANT;
1492 218 : gfc_conv_expr (&rhs_se, rhs_expr);
1493 218 : gfc_add_block_to_block (&block, &rhs_se.pre);
1494 218 : opt_rhs_desc = null_pointer_node;
1495 218 : if (rhs_expr->ts.type == BT_CHARACTER)
1496 : {
1497 40 : rhs_data
1498 40 : = rhs_expr->expr_type == EXPR_CONSTANT
1499 40 : ? gfc_build_addr_expr (NULL_TREE,
1500 : gfc_trans_force_lval (&block,
1501 : rhs_se.expr))
1502 : : rhs_se.expr;
1503 40 : opt_rhs_charlen = gfc_build_addr_expr (
1504 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1505 40 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1506 : }
1507 : else
1508 : {
1509 178 : rhs_data
1510 178 : = gfc_build_addr_expr (NULL_TREE,
1511 : gfc_trans_force_lval (&block, rhs_se.expr));
1512 178 : opt_rhs_charlen
1513 178 : = build_zero_cst (build_pointer_type (size_type_node));
1514 178 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1515 : }
1516 : }
1517 : else
1518 : {
1519 284 : rhs_se.force_tmp = rhs_expr->shape == NULL
1520 142 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1521 142 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1522 142 : gfc_add_block_to_block (&block, &rhs_se.pre);
1523 142 : opt_rhs_desc = rhs_se.expr;
1524 142 : if (rhs_expr->ts.type == BT_CHARACTER)
1525 : {
1526 28 : opt_rhs_charlen = gfc_build_addr_expr (
1527 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1528 28 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1529 : }
1530 : else
1531 : {
1532 114 : opt_rhs_charlen
1533 114 : = build_zero_cst (build_pointer_type (size_type_node));
1534 114 : rhs_size = fold_build2 (
1535 : MULT_EXPR, size_type_node,
1536 : fold_convert (size_type_node,
1537 : rhs_expr->shape
1538 : ? conv_shape_to_cst (rhs_expr)
1539 : : gfc_conv_descriptor_size (rhs_se.expr,
1540 : rhs_expr->rank)),
1541 : fold_convert (size_type_node,
1542 : gfc_conv_descriptor_span_get (rhs_se.expr)));
1543 : }
1544 :
1545 142 : rhs_data = gfc_build_addr_expr (
1546 : NULL_TREE, gfc_trans_force_lval (&block, gfc_conv_descriptor_data_get (
1547 : opt_rhs_desc)));
1548 142 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1549 : }
1550 360 : gfc_add_block_to_block (&block, &rhs_se.pre);
1551 :
1552 360 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1553 :
1554 360 : receiver_fn_index_tree
1555 360 : = conv_caf_func_index (&block, ns, "__caf_send_to_remote_fn_index_%d",
1556 : lhs_hash);
1557 360 : add_data_tree
1558 360 : = conv_caf_add_call_data (&block, ns, "__caf_send_to_remote_add_data_%d",
1559 : add_data_sym, &add_data_size);
1560 360 : ++caf_call_cnt;
1561 :
1562 360 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_to_remote, 14,
1563 : token, opt_lhs_desc, opt_lhs_charlen, image_index,
1564 : rhs_size, rhs_data, opt_rhs_charlen, opt_rhs_desc,
1565 : receiver_fn_index_tree, add_data_tree,
1566 : add_data_size, lhs_stat, lhs_team, lhs_team_no);
1567 :
1568 360 : gfc_add_expr_to_block (&block, tmp);
1569 360 : gfc_add_block_to_block (&block, &lhs_se.post);
1570 360 : gfc_add_block_to_block (&block, &rhs_se.post);
1571 :
1572 : /* It guarantees memory consistency within the same segment. */
1573 360 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1574 360 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1575 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1576 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1577 360 : ASM_VOLATILE_P (tmp) = 1;
1578 360 : gfc_add_expr_to_block (&block, tmp);
1579 :
1580 360 : return gfc_finish_block (&block);
1581 : }
1582 :
1583 : /* Send-get data to a remote coarray. */
1584 :
1585 : static tree
1586 140 : conv_caf_sendget (gfc_code *code)
1587 : {
1588 : /* lhs stuff */
1589 140 : gfc_expr *lhs_expr, *lhs_hash, *receiver_fn_expr;
1590 140 : gfc_symbol *lhs_add_data_sym;
1591 140 : gfc_se lhs_se;
1592 140 : tree lhs_caf_decl, lhs_token, opt_lhs_charlen,
1593 140 : opt_lhs_desc = NULL_TREE, receiver_fn_index_tree, lhs_image_index,
1594 : lhs_add_data_tree, lhs_add_data_size, lhs_stat, lhs_team, lhs_team_no;
1595 140 : int transfer_rank;
1596 :
1597 : /* rhs stuff */
1598 140 : gfc_expr *rhs_expr, *rhs_hash, *sender_fn_expr;
1599 140 : gfc_symbol *rhs_add_data_sym;
1600 140 : gfc_se rhs_se;
1601 140 : tree rhs_caf_decl, rhs_token, opt_rhs_charlen,
1602 140 : opt_rhs_desc = NULL_TREE, sender_fn_index_tree, rhs_image_index,
1603 : rhs_add_data_tree, rhs_add_data_size, rhs_stat, rhs_team, rhs_team_no;
1604 :
1605 : /* shared */
1606 140 : stmtblock_t block;
1607 140 : gfc_namespace *ns;
1608 140 : tree tmp, rhs_size;
1609 :
1610 140 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1611 140 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SENDGET);
1612 :
1613 140 : lhs_expr = code->ext.actual->expr;
1614 140 : rhs_expr = code->ext.actual->next->expr;
1615 140 : lhs_hash = code->ext.actual->next->next->expr;
1616 140 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1617 140 : rhs_hash = code->ext.actual->next->next->next->next->expr;
1618 140 : sender_fn_expr = code->ext.actual->next->next->next->next->next->expr;
1619 :
1620 140 : lhs_add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1621 140 : rhs_add_data_sym = sender_fn_expr->symtree->n.sym->formal->sym;
1622 :
1623 140 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1624 140 : && !lhs_expr->symtree->n.sym->attr.associate_var
1625 140 : ? lhs_expr->symtree->n.sym->ns
1626 : : gfc_current_ns;
1627 :
1628 140 : gfc_init_block (&block);
1629 :
1630 140 : lhs_stat = null_pointer_node;
1631 140 : lhs_team = null_pointer_node;
1632 140 : rhs_stat = null_pointer_node;
1633 140 : rhs_team = null_pointer_node;
1634 :
1635 : /* LHS. */
1636 140 : gfc_init_se (&lhs_se, NULL);
1637 140 : lhs_caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1638 140 : if (TREE_CODE (TREE_TYPE (lhs_caf_decl)) == REFERENCE_TYPE)
1639 0 : lhs_caf_decl = build_fold_indirect_ref_loc (input_location, lhs_caf_decl);
1640 140 : if (lhs_expr->rank == 0)
1641 : {
1642 78 : if (lhs_expr->ts.type == BT_CHARACTER)
1643 : {
1644 16 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1645 16 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1646 16 : opt_lhs_charlen = gfc_build_addr_expr (
1647 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1648 : }
1649 : else
1650 62 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1651 78 : opt_lhs_desc = null_pointer_node;
1652 : }
1653 : else
1654 : {
1655 62 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1656 62 : gfc_add_block_to_block (&block, &lhs_se.pre);
1657 62 : opt_lhs_desc = lhs_se.expr;
1658 62 : if (lhs_expr->ts.type == BT_CHARACTER)
1659 32 : opt_lhs_charlen = gfc_build_addr_expr (
1660 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1661 : else
1662 30 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1663 : /* Get the third formal argument of the receiver function. (This is the
1664 : location where to put the data on the remote image.) Need to look at
1665 : the argument in the function decl, because in the gfc_symbol's formal
1666 : argument an array may have no descriptor while in the generated
1667 : function decl it has. */
1668 62 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1669 : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1670 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1671 54 : opt_lhs_desc = null_pointer_node;
1672 : else
1673 8 : opt_lhs_desc
1674 8 : = gfc_build_addr_expr (NULL_TREE,
1675 : gfc_trans_force_lval (&block, opt_lhs_desc));
1676 : }
1677 :
1678 : /* Obtain token, offset and image index for the LHS. */
1679 140 : lhs_image_index = gfc_caf_get_image_index (&block, lhs_expr, lhs_caf_decl);
1680 140 : gfc_get_caf_token_offset (&lhs_se, &lhs_token, NULL, lhs_caf_decl, NULL,
1681 : lhs_expr);
1682 :
1683 : /* RHS. */
1684 140 : rhs_caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
1685 140 : if (TREE_CODE (TREE_TYPE (rhs_caf_decl)) == REFERENCE_TYPE)
1686 0 : rhs_caf_decl = build_fold_indirect_ref_loc (input_location, rhs_caf_decl);
1687 140 : transfer_rank = rhs_expr->rank;
1688 140 : gfc_expression_rank (rhs_expr);
1689 140 : gfc_init_se (&rhs_se, NULL);
1690 140 : if (rhs_expr->rank == 0)
1691 : {
1692 80 : opt_rhs_desc = null_pointer_node;
1693 80 : if (rhs_expr->ts.type == BT_CHARACTER)
1694 : {
1695 32 : gfc_conv_expr (&rhs_se, rhs_expr);
1696 32 : gfc_add_block_to_block (&block, &rhs_se.pre);
1697 32 : opt_rhs_charlen = gfc_build_addr_expr (
1698 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1699 32 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1700 : }
1701 : else
1702 : {
1703 48 : gfc_typespec *ts
1704 48 : = &sender_fn_expr->symtree->n.sym->formal->next->next->sym->ts;
1705 :
1706 48 : opt_rhs_charlen
1707 48 : = build_zero_cst (build_pointer_type (size_type_node));
1708 48 : rhs_size = gfc_typenode_for_spec (ts)->type_common.size_unit;
1709 : }
1710 : }
1711 : /* Get the fifth formal argument of the getter function. This is the argument
1712 : pointing to the data to get on the remote image. Need to look at the
1713 : argument in the function decl, because in the gfc_symbol's formal argument
1714 : an array may have no descriptor while in the generated function decl it
1715 : has. */
1716 60 : else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_VALUE (
1717 : TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1718 : TREE_TYPE (sender_fn_expr->symtree->n.sym->backend_decl))))))))))
1719 : {
1720 52 : rhs_se.data_not_needed = 1;
1721 52 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1722 52 : gfc_add_block_to_block (&block, &rhs_se.pre);
1723 52 : if (rhs_expr->ts.type == BT_CHARACTER)
1724 : {
1725 16 : opt_rhs_charlen = gfc_build_addr_expr (
1726 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1727 16 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1728 : }
1729 : else
1730 : {
1731 36 : opt_rhs_charlen
1732 36 : = build_zero_cst (build_pointer_type (size_type_node));
1733 36 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1734 : }
1735 52 : opt_rhs_desc = null_pointer_node;
1736 : }
1737 : else
1738 : {
1739 8 : gfc_ref *arr_ref = rhs_expr->ref;
1740 8 : while (arr_ref && arr_ref->type != REF_ARRAY)
1741 0 : arr_ref = arr_ref->next;
1742 8 : rhs_se.force_tmp
1743 16 : = (rhs_expr->shape == NULL
1744 8 : && (!arr_ref || !gfc_full_array_ref_p (arr_ref, nullptr)))
1745 16 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1746 8 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1747 8 : gfc_add_block_to_block (&block, &rhs_se.pre);
1748 8 : opt_rhs_desc = rhs_se.expr;
1749 8 : if (rhs_expr->ts.type == BT_CHARACTER)
1750 : {
1751 0 : opt_rhs_charlen = gfc_build_addr_expr (
1752 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1753 0 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1754 : }
1755 : else
1756 : {
1757 8 : opt_rhs_charlen
1758 8 : = build_zero_cst (build_pointer_type (size_type_node));
1759 8 : rhs_size = fold_build2 (
1760 : MULT_EXPR, size_type_node,
1761 : fold_convert (size_type_node,
1762 : rhs_expr->shape
1763 : ? conv_shape_to_cst (rhs_expr)
1764 : : gfc_conv_descriptor_size (rhs_se.expr,
1765 : rhs_expr->rank)),
1766 : fold_convert (size_type_node,
1767 : gfc_conv_descriptor_span_get (rhs_se.expr)));
1768 : }
1769 :
1770 8 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1771 : }
1772 140 : gfc_add_block_to_block (&block, &rhs_se.pre);
1773 :
1774 : /* Obtain token, offset and image index for the RHS. */
1775 140 : rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, rhs_caf_decl);
1776 140 : gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, rhs_caf_decl, NULL,
1777 : rhs_expr);
1778 :
1779 : /* stat and team. */
1780 140 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1781 140 : conv_stat_and_team (&block, rhs_expr, &rhs_stat, &rhs_team, &rhs_team_no);
1782 :
1783 140 : sender_fn_index_tree
1784 140 : = conv_caf_func_index (&block, ns, "__caf_transfer_from_fn_index_%d",
1785 : rhs_hash);
1786 140 : rhs_add_data_tree
1787 140 : = conv_caf_add_call_data (&block, ns,
1788 : "__caf_transfer_from_remote_add_data_%d",
1789 : rhs_add_data_sym, &rhs_add_data_size);
1790 140 : receiver_fn_index_tree
1791 140 : = conv_caf_func_index (&block, ns, "__caf_transfer_to_remote_fn_index_%d",
1792 : lhs_hash);
1793 140 : lhs_add_data_tree
1794 140 : = conv_caf_add_call_data (&block, ns,
1795 : "__caf_transfer_to_remote_add_data_%d",
1796 : lhs_add_data_sym, &lhs_add_data_size);
1797 140 : ++caf_call_cnt;
1798 :
1799 140 : tmp = build_call_expr_loc (
1800 : input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token,
1801 : opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree,
1802 : lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc,
1803 : opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree,
1804 : rhs_add_data_size, rhs_size,
1805 : transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat,
1806 : rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no);
1807 :
1808 140 : gfc_add_expr_to_block (&block, tmp);
1809 140 : gfc_add_block_to_block (&block, &lhs_se.post);
1810 140 : gfc_add_block_to_block (&block, &rhs_se.post);
1811 :
1812 : /* It guarantees memory consistency within the same segment. */
1813 140 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1814 140 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1815 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1816 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1817 140 : ASM_VOLATILE_P (tmp) = 1;
1818 140 : gfc_add_expr_to_block (&block, tmp);
1819 :
1820 140 : return gfc_finish_block (&block);
1821 : }
1822 :
1823 :
1824 : static void
1825 1298 : trans_this_image (gfc_se * se, gfc_expr *expr)
1826 : {
1827 1298 : stmtblock_t loop;
1828 1298 : tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound,
1829 : ubound, extent, ml, team;
1830 1298 : gfc_se argse;
1831 1298 : int rank, corank;
1832 :
1833 : /* The case -fcoarray=single is handled elsewhere. */
1834 1298 : gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
1835 :
1836 : /* Translate team, if present. */
1837 1298 : if (expr->value.function.actual->next->next->expr)
1838 : {
1839 18 : gfc_init_se (&argse, NULL);
1840 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr);
1841 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
1842 18 : gfc_add_block_to_block (&se->post, &argse.post);
1843 18 : team = fold_convert (pvoid_type_node, argse.expr);
1844 : }
1845 : else
1846 1280 : team = null_pointer_node;
1847 :
1848 : /* Argument-free version: THIS_IMAGE(). */
1849 1298 : if (expr->value.function.actual->expr == NULL)
1850 : {
1851 980 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1852 : team);
1853 980 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1854 : tmp);
1855 988 : return;
1856 : }
1857 :
1858 : /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1859 :
1860 318 : type = gfc_get_int_type (gfc_default_integer_kind);
1861 318 : corank = expr->value.function.actual->expr->corank;
1862 318 : rank = expr->value.function.actual->expr->rank;
1863 :
1864 : /* Obtain the descriptor of the COARRAY. */
1865 318 : gfc_init_se (&argse, NULL);
1866 318 : argse.want_coarray = 1;
1867 318 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
1868 318 : gfc_add_block_to_block (&se->pre, &argse.pre);
1869 318 : gfc_add_block_to_block (&se->post, &argse.post);
1870 318 : desc = argse.expr;
1871 :
1872 318 : if (se->ss)
1873 : {
1874 : /* Create an implicit second parameter from the loop variable. */
1875 70 : gcc_assert (!expr->value.function.actual->next->expr);
1876 70 : gcc_assert (corank > 0);
1877 70 : gcc_assert (se->loop->dimen == 1);
1878 70 : gcc_assert (se->ss->info->expr == expr);
1879 :
1880 70 : dim_arg = se->loop->loopvar[0];
1881 70 : dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1882 : gfc_array_index_type, dim_arg,
1883 70 : build_int_cst (TREE_TYPE (dim_arg), 1));
1884 70 : gfc_advance_se_ss_chain (se);
1885 : }
1886 : else
1887 : {
1888 : /* Use the passed DIM= argument. */
1889 248 : gcc_assert (expr->value.function.actual->next->expr);
1890 248 : gfc_init_se (&argse, NULL);
1891 248 : gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1892 : gfc_array_index_type);
1893 248 : gfc_add_block_to_block (&se->pre, &argse.pre);
1894 248 : dim_arg = argse.expr;
1895 :
1896 248 : if (INTEGER_CST_P (dim_arg))
1897 : {
1898 132 : if (wi::ltu_p (wi::to_wide (dim_arg), 1)
1899 264 : || wi::gtu_p (wi::to_wide (dim_arg),
1900 132 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
1901 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1902 0 : "dimension index", expr->value.function.isym->name,
1903 : &expr->where);
1904 : }
1905 116 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1906 : {
1907 0 : dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1908 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1909 : dim_arg,
1910 0 : build_int_cst (TREE_TYPE (dim_arg), 1));
1911 0 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1912 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1913 : dim_arg, tmp);
1914 0 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1915 : logical_type_node, cond, tmp);
1916 0 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1917 : gfc_msg_fault);
1918 : }
1919 : }
1920 :
1921 : /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1922 : one always has a dim_arg argument.
1923 :
1924 : m = this_image() - 1
1925 : if (corank == 1)
1926 : {
1927 : sub(1) = m + lcobound(corank)
1928 : return;
1929 : }
1930 : i = rank
1931 : min_var = min (rank + corank - 2, rank + dim_arg - 1)
1932 : for (;;)
1933 : {
1934 : extent = gfc_extent(i)
1935 : ml = m
1936 : m = m/extent
1937 : if (i >= min_var)
1938 : goto exit_label
1939 : i++
1940 : }
1941 : exit_label:
1942 : sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1943 : : m + lcobound(corank)
1944 : */
1945 :
1946 : /* this_image () - 1. */
1947 318 : tmp
1948 318 : = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team);
1949 318 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
1950 : fold_convert (type, tmp), build_int_cst (type, 1));
1951 318 : if (corank == 1)
1952 : {
1953 : /* sub(1) = m + lcobound(corank). */
1954 8 : lbound = gfc_conv_descriptor_lbound_get (desc,
1955 8 : build_int_cst (TREE_TYPE (gfc_array_index_type),
1956 8 : corank+rank-1));
1957 8 : lbound = fold_convert (type, lbound);
1958 8 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1959 :
1960 8 : se->expr = tmp;
1961 8 : return;
1962 : }
1963 :
1964 310 : m = gfc_create_var (type, NULL);
1965 310 : ml = gfc_create_var (type, NULL);
1966 310 : loop_var = gfc_create_var (integer_type_node, NULL);
1967 310 : min_var = gfc_create_var (integer_type_node, NULL);
1968 :
1969 : /* m = this_image () - 1. */
1970 310 : gfc_add_modify (&se->pre, m, tmp);
1971 :
1972 : /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1973 310 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1974 : fold_convert (integer_type_node, dim_arg),
1975 310 : build_int_cst (integer_type_node, rank - 1));
1976 310 : tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1977 310 : build_int_cst (integer_type_node, rank + corank - 2),
1978 : tmp);
1979 310 : gfc_add_modify (&se->pre, min_var, tmp);
1980 :
1981 : /* i = rank. */
1982 310 : tmp = build_int_cst (integer_type_node, rank);
1983 310 : gfc_add_modify (&se->pre, loop_var, tmp);
1984 :
1985 310 : exit_label = gfc_build_label_decl (NULL_TREE);
1986 310 : TREE_USED (exit_label) = 1;
1987 :
1988 : /* Loop body. */
1989 310 : gfc_init_block (&loop);
1990 :
1991 : /* ml = m. */
1992 310 : gfc_add_modify (&loop, ml, m);
1993 :
1994 : /* extent = ... */
1995 310 : lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1996 310 : ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1997 310 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1998 310 : extent = fold_convert (type, extent);
1999 :
2000 : /* m = m/extent. */
2001 310 : gfc_add_modify (&loop, m,
2002 : fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2003 : m, extent));
2004 :
2005 : /* Exit condition: if (i >= min_var) goto exit_label. */
2006 310 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2007 : min_var);
2008 310 : tmp = build1_v (GOTO_EXPR, exit_label);
2009 310 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2010 : build_empty_stmt (input_location));
2011 310 : gfc_add_expr_to_block (&loop, tmp);
2012 :
2013 : /* Increment loop variable: i++. */
2014 310 : gfc_add_modify (&loop, loop_var,
2015 : fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2016 : loop_var,
2017 : integer_one_node));
2018 :
2019 : /* Making the loop... actually loop! */
2020 310 : tmp = gfc_finish_block (&loop);
2021 310 : tmp = build1_v (LOOP_EXPR, tmp);
2022 310 : gfc_add_expr_to_block (&se->pre, tmp);
2023 :
2024 : /* The exit label. */
2025 310 : tmp = build1_v (LABEL_EXPR, exit_label);
2026 310 : gfc_add_expr_to_block (&se->pre, tmp);
2027 :
2028 : /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2029 : : m + lcobound(corank) */
2030 :
2031 310 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2032 310 : build_int_cst (TREE_TYPE (dim_arg), corank));
2033 :
2034 310 : lbound = gfc_conv_descriptor_lbound_get (desc,
2035 : fold_build2_loc (input_location, PLUS_EXPR,
2036 : gfc_array_index_type, dim_arg,
2037 310 : build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2038 310 : lbound = fold_convert (type, lbound);
2039 :
2040 310 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2041 : fold_build2_loc (input_location, MULT_EXPR, type,
2042 : m, extent));
2043 310 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2044 :
2045 310 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2046 : fold_build2_loc (input_location, PLUS_EXPR, type,
2047 : m, lbound));
2048 : }
2049 :
2050 :
2051 : /* Convert a call to image_status. */
2052 :
2053 : static void
2054 25 : conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2055 : {
2056 25 : unsigned int num_args;
2057 25 : tree *args, tmp;
2058 :
2059 25 : num_args = gfc_intrinsic_argument_list_length (expr);
2060 25 : args = XALLOCAVEC (tree, num_args);
2061 25 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2062 : /* In args[0] the number of the image the status is desired for has to be
2063 : given. */
2064 :
2065 25 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2066 : {
2067 0 : tree arg;
2068 0 : arg = gfc_evaluate_now (args[0], &se->pre);
2069 0 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2070 : fold_convert (integer_type_node, arg),
2071 : integer_one_node);
2072 0 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2073 : tmp, integer_zero_node,
2074 : build_int_cst (integer_type_node,
2075 : GFC_STAT_STOPPED_IMAGE));
2076 : }
2077 25 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2078 : /* The team is optional and therefore needs to be a pointer to the opaque
2079 : pointer. */
2080 29 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2081 : args[0],
2082 : num_args < 2
2083 : ? null_pointer_node
2084 4 : : gfc_build_addr_expr (NULL_TREE, args[1]));
2085 : else
2086 0 : gcc_unreachable ();
2087 :
2088 25 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2089 25 : }
2090 :
2091 : static void
2092 21 : conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2093 : {
2094 21 : unsigned int num_args;
2095 :
2096 21 : tree *args, tmp;
2097 :
2098 21 : num_args = gfc_intrinsic_argument_list_length (expr);
2099 21 : args = XALLOCAVEC (tree, num_args);
2100 21 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2101 :
2102 21 : if (flag_coarray ==
2103 18 : GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2104 0 : tmp = gfc_evaluate_now (args[0], &se->pre);
2105 21 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2106 : {
2107 : // the value -1 represents that no team has been created yet
2108 18 : tmp = build_int_cst (integer_type_node, -1);
2109 : }
2110 3 : else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2111 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2112 : args[0]);
2113 3 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2114 3 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2115 : null_pointer_node);
2116 : else
2117 0 : gcc_unreachable ();
2118 :
2119 21 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2120 21 : }
2121 :
2122 :
2123 : static void
2124 193 : trans_image_index (gfc_se * se, gfc_expr *expr)
2125 : {
2126 193 : tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp,
2127 193 : invalid_bound, team = null_pointer_node, team_number = null_pointer_node;
2128 193 : gfc_se argse, subse;
2129 193 : int rank, corank, codim;
2130 :
2131 193 : type = gfc_get_int_type (gfc_default_integer_kind);
2132 193 : corank = expr->value.function.actual->expr->corank;
2133 193 : rank = expr->value.function.actual->expr->rank;
2134 :
2135 : /* Obtain the descriptor of the COARRAY. */
2136 193 : gfc_init_se (&argse, NULL);
2137 193 : argse.want_coarray = 1;
2138 193 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2139 193 : gfc_add_block_to_block (&se->pre, &argse.pre);
2140 193 : gfc_add_block_to_block (&se->post, &argse.post);
2141 193 : desc = argse.expr;
2142 :
2143 : /* Obtain a handle to the SUB argument. */
2144 193 : gfc_init_se (&subse, NULL);
2145 193 : gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2146 193 : gfc_add_block_to_block (&se->pre, &subse.pre);
2147 193 : gfc_add_block_to_block (&se->post, &subse.post);
2148 193 : subdesc = build_fold_indirect_ref_loc (input_location,
2149 : gfc_conv_descriptor_data_get (subse.expr));
2150 :
2151 193 : if (expr->value.function.actual->next->next->expr)
2152 : {
2153 0 : gfc_init_se (&argse, NULL);
2154 0 : gfc_conv_expr_descriptor (&argse,
2155 0 : expr->value.function.actual->next->next->expr);
2156 0 : if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED)
2157 0 : team = argse.expr;
2158 : else
2159 0 : team_number = gfc_build_addr_expr (
2160 : NULL_TREE,
2161 : gfc_trans_force_lval (&argse.pre,
2162 : fold_convert (integer_type_node, argse.expr)));
2163 0 : gfc_add_block_to_block (&se->pre, &argse.pre);
2164 0 : gfc_add_block_to_block (&se->post, &argse.post);
2165 : }
2166 :
2167 : /* Fortran 2008 does not require that the values remain in the cobounds,
2168 : thus we need explicitly check this - and return 0 if they are exceeded. */
2169 :
2170 193 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2171 193 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2172 193 : invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2173 : fold_convert (gfc_array_index_type, tmp),
2174 : lbound);
2175 :
2176 443 : for (codim = corank + rank - 2; codim >= rank; codim--)
2177 : {
2178 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2179 250 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2180 250 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2181 250 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2182 : fold_convert (gfc_array_index_type, tmp),
2183 : lbound);
2184 250 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2185 : logical_type_node, invalid_bound, cond);
2186 250 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2187 : fold_convert (gfc_array_index_type, tmp),
2188 : ubound);
2189 250 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2190 : logical_type_node, invalid_bound, cond);
2191 : }
2192 :
2193 193 : invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2194 :
2195 : /* See Fortran 2008, C.10 for the following algorithm. */
2196 :
2197 : /* coindex = sub(corank) - lcobound(n). */
2198 193 : coindex = fold_convert (gfc_array_index_type,
2199 : gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2200 : NULL));
2201 193 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2202 193 : coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2203 : fold_convert (gfc_array_index_type, coindex),
2204 : lbound);
2205 :
2206 443 : for (codim = corank + rank - 2; codim >= rank; codim--)
2207 : {
2208 250 : tree extent, ubound;
2209 :
2210 : /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2211 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2212 250 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2213 250 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2214 :
2215 : /* coindex *= extent. */
2216 250 : coindex = fold_build2_loc (input_location, MULT_EXPR,
2217 : gfc_array_index_type, coindex, extent);
2218 :
2219 : /* coindex += sub(codim). */
2220 250 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2221 250 : coindex = fold_build2_loc (input_location, PLUS_EXPR,
2222 : gfc_array_index_type, coindex,
2223 : fold_convert (gfc_array_index_type, tmp));
2224 :
2225 : /* coindex -= lbound(codim). */
2226 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2227 250 : coindex = fold_build2_loc (input_location, MINUS_EXPR,
2228 : gfc_array_index_type, coindex, lbound);
2229 : }
2230 :
2231 193 : coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2232 : fold_convert(type, coindex),
2233 : build_int_cst (type, 1));
2234 :
2235 : /* Return 0 if "coindex" exceeds num_images(). */
2236 :
2237 193 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2238 108 : num_images = build_int_cst (type, 1);
2239 : else
2240 : {
2241 85 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2242 : team, team_number);
2243 85 : num_images = fold_convert (type, tmp);
2244 : }
2245 :
2246 193 : tmp = gfc_create_var (type, NULL);
2247 193 : gfc_add_modify (&se->pre, tmp, coindex);
2248 :
2249 193 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2250 : num_images);
2251 193 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2252 : cond,
2253 : fold_convert (logical_type_node, invalid_bound));
2254 193 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2255 : build_int_cst (type, 0), tmp);
2256 193 : }
2257 :
2258 : static void
2259 810 : trans_num_images (gfc_se * se, gfc_expr *expr)
2260 : {
2261 810 : tree tmp, team = null_pointer_node, team_number = null_pointer_node;
2262 810 : gfc_se argse;
2263 :
2264 810 : if (expr->value.function.actual->expr)
2265 : {
2266 18 : gfc_init_se (&argse, NULL);
2267 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2268 18 : if (expr->value.function.actual->expr->ts.type == BT_DERIVED)
2269 6 : team = argse.expr;
2270 : else
2271 12 : team_number = gfc_build_addr_expr (
2272 : NULL_TREE,
2273 : gfc_trans_force_lval (&se->pre,
2274 : fold_convert (integer_type_node, argse.expr)));
2275 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
2276 18 : gfc_add_block_to_block (&se->post, &argse.post);
2277 : }
2278 :
2279 810 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2280 : team, team_number);
2281 810 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2282 810 : }
2283 :
2284 :
2285 : static void
2286 12588 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2287 : {
2288 12588 : gfc_se argse;
2289 :
2290 12588 : gfc_init_se (&argse, NULL);
2291 12588 : argse.data_not_needed = 1;
2292 12588 : argse.descriptor_only = 1;
2293 :
2294 12588 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2295 12588 : gfc_add_block_to_block (&se->pre, &argse.pre);
2296 12588 : gfc_add_block_to_block (&se->post, &argse.post);
2297 :
2298 12588 : se->expr = gfc_conv_descriptor_rank (argse.expr);
2299 12588 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2300 : se->expr);
2301 12588 : }
2302 :
2303 :
2304 : static void
2305 735 : gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2306 : {
2307 735 : gfc_expr *arg;
2308 735 : arg = expr->value.function.actual->expr;
2309 735 : gfc_conv_is_contiguous_expr (se, arg);
2310 735 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2311 735 : }
2312 :
2313 : /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2314 : plus it can be called directly. */
2315 :
2316 : void
2317 2092 : gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2318 : {
2319 2092 : gfc_ss *ss;
2320 2092 : gfc_se argse;
2321 2092 : tree desc, tmp, stride, extent, cond;
2322 2092 : int i;
2323 2092 : tree fncall0;
2324 2092 : gfc_array_spec *as;
2325 2092 : gfc_symbol *sym = NULL;
2326 :
2327 2092 : if (arg->ts.type == BT_CLASS)
2328 90 : gfc_add_class_array_ref (arg);
2329 :
2330 2092 : if (arg->expr_type == EXPR_VARIABLE)
2331 2056 : sym = arg->symtree->n.sym;
2332 :
2333 2092 : ss = gfc_walk_expr (arg);
2334 2092 : gcc_assert (ss != gfc_ss_terminator);
2335 2092 : gfc_init_se (&argse, NULL);
2336 2092 : argse.data_not_needed = 1;
2337 2092 : gfc_conv_expr_descriptor (&argse, arg);
2338 :
2339 2092 : as = gfc_get_full_arrayspec_from_expr (arg);
2340 :
2341 : /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2342 : Note in addition that zero-sized arrays don't count as contiguous. */
2343 :
2344 2092 : if (as && as->type == AS_ASSUMED_RANK)
2345 : {
2346 : /* Build the call to is_contiguous0. */
2347 243 : argse.want_pointer = 1;
2348 243 : gfc_conv_expr_descriptor (&argse, arg);
2349 243 : gfc_add_block_to_block (&se->pre, &argse.pre);
2350 243 : gfc_add_block_to_block (&se->post, &argse.post);
2351 243 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2352 243 : fncall0 = build_call_expr_loc (input_location,
2353 : gfor_fndecl_is_contiguous0, 1, desc);
2354 243 : se->expr = fncall0;
2355 243 : se->expr = convert (boolean_type_node, se->expr);
2356 : }
2357 : else
2358 : {
2359 1849 : gfc_add_block_to_block (&se->pre, &argse.pre);
2360 1849 : gfc_add_block_to_block (&se->post, &argse.post);
2361 1849 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2362 :
2363 1849 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2364 1849 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2365 1849 : stride, build_int_cst (TREE_TYPE (stride), 1));
2366 :
2367 2181 : for (i = 0; i < arg->rank - 1; i++)
2368 : {
2369 332 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2370 332 : extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2371 332 : extent = fold_build2_loc (input_location, MINUS_EXPR,
2372 : gfc_array_index_type, extent, tmp);
2373 332 : extent = fold_build2_loc (input_location, PLUS_EXPR,
2374 : gfc_array_index_type, extent,
2375 : gfc_index_one_node);
2376 332 : tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2377 332 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2378 : tmp, extent);
2379 332 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2380 332 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2381 : stride, tmp);
2382 332 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2383 : boolean_type_node, cond, tmp);
2384 : }
2385 1849 : se->expr = cond;
2386 : }
2387 :
2388 : /* A pointer that does not have the CONTIGUOUS attribute needs to be checked
2389 : if it points to an array whose span differs from the element size. */
2390 2092 : if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous)
2391 : {
2392 180 : tree span = gfc_conv_descriptor_span_get (desc);
2393 180 : tmp = fold_convert (TREE_TYPE (span),
2394 : gfc_conv_descriptor_elem_len (desc));
2395 180 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2396 : span, tmp);
2397 180 : se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2398 : boolean_type_node, cond,
2399 : convert (boolean_type_node, se->expr));
2400 : }
2401 :
2402 2092 : gfc_free_ss_chain (ss);
2403 2092 : }
2404 :
2405 :
2406 : /* Evaluate a single upper or lower bound. */
2407 : /* TODO: bound intrinsic generates way too much unnecessary code. */
2408 :
2409 : static void
2410 16187 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2411 : {
2412 16187 : gfc_actual_arglist *arg;
2413 16187 : gfc_actual_arglist *arg2;
2414 16187 : tree desc;
2415 16187 : tree type;
2416 16187 : tree bound;
2417 16187 : tree tmp;
2418 16187 : tree cond, cond1;
2419 16187 : tree ubound;
2420 16187 : tree lbound;
2421 16187 : tree size;
2422 16187 : gfc_se argse;
2423 16187 : gfc_array_spec * as;
2424 16187 : bool assumed_rank_lb_one;
2425 :
2426 16187 : arg = expr->value.function.actual;
2427 16187 : arg2 = arg->next;
2428 :
2429 16187 : if (se->ss)
2430 : {
2431 : /* Create an implicit second parameter from the loop variable. */
2432 7944 : gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2433 7944 : gcc_assert (se->loop->dimen == 1);
2434 7944 : gcc_assert (se->ss->info->expr == expr);
2435 7944 : gfc_advance_se_ss_chain (se);
2436 7944 : bound = se->loop->loopvar[0];
2437 7944 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2438 : gfc_array_index_type, bound,
2439 : se->loop->from[0]);
2440 : }
2441 : else
2442 : {
2443 : /* use the passed argument. */
2444 8243 : gcc_assert (arg2->expr);
2445 8243 : gfc_init_se (&argse, NULL);
2446 8243 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2447 8243 : gfc_add_block_to_block (&se->pre, &argse.pre);
2448 8243 : bound = argse.expr;
2449 : /* Convert from one based to zero based. */
2450 8243 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2451 : gfc_array_index_type, bound,
2452 : gfc_index_one_node);
2453 : }
2454 :
2455 : /* TODO: don't re-evaluate the descriptor on each iteration. */
2456 : /* Get a descriptor for the first parameter. */
2457 16187 : gfc_init_se (&argse, NULL);
2458 16187 : gfc_conv_expr_descriptor (&argse, arg->expr);
2459 16187 : gfc_add_block_to_block (&se->pre, &argse.pre);
2460 16187 : gfc_add_block_to_block (&se->post, &argse.post);
2461 :
2462 16187 : desc = argse.expr;
2463 :
2464 16187 : as = gfc_get_full_arrayspec_from_expr (arg->expr);
2465 :
2466 16187 : if (INTEGER_CST_P (bound))
2467 : {
2468 8123 : gcc_assert (op != GFC_ISYM_SHAPE);
2469 7886 : if (((!as || as->type != AS_ASSUMED_RANK)
2470 7263 : && wi::geu_p (wi::to_wide (bound),
2471 7263 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2472 16246 : || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2473 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2474 : "dimension index",
2475 : (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
2476 : &expr->where);
2477 : }
2478 :
2479 16187 : if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2480 : {
2481 8924 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2482 : {
2483 651 : bound = gfc_evaluate_now (bound, &se->pre);
2484 651 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2485 651 : bound, build_int_cst (TREE_TYPE (bound), 0));
2486 651 : if (as && as->type == AS_ASSUMED_RANK)
2487 546 : tmp = gfc_conv_descriptor_rank (desc);
2488 : else
2489 105 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2490 651 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2491 651 : bound, fold_convert(TREE_TYPE (bound), tmp));
2492 651 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2493 : logical_type_node, cond, tmp);
2494 651 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2495 : gfc_msg_fault);
2496 : }
2497 : }
2498 :
2499 : /* Take care of the lbound shift for assumed-rank arrays that are
2500 : nonallocatable and nonpointers. Those have a lbound of 1. */
2501 15603 : assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2502 11061 : && ((arg->expr->ts.type != BT_CLASS
2503 1963 : && !arg->expr->symtree->n.sym->attr.allocatable
2504 1620 : && !arg->expr->symtree->n.sym->attr.pointer)
2505 896 : || (arg->expr->ts.type == BT_CLASS
2506 174 : && !CLASS_DATA (arg->expr)->attr.allocatable
2507 138 : && !CLASS_DATA (arg->expr)->attr.class_pointer));
2508 :
2509 16187 : ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2510 16187 : lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2511 16187 : size = fold_build2_loc (input_location, MINUS_EXPR,
2512 : gfc_array_index_type, ubound, lbound);
2513 16187 : size = fold_build2_loc (input_location, PLUS_EXPR,
2514 : gfc_array_index_type, size, gfc_index_one_node);
2515 :
2516 : /* 13.14.53: Result value for LBOUND
2517 :
2518 : Case (i): For an array section or for an array expression other than a
2519 : whole array or array structure component, LBOUND(ARRAY, DIM)
2520 : has the value 1. For a whole array or array structure
2521 : component, LBOUND(ARRAY, DIM) has the value:
2522 : (a) equal to the lower bound for subscript DIM of ARRAY if
2523 : dimension DIM of ARRAY does not have extent zero
2524 : or if ARRAY is an assumed-size array of rank DIM,
2525 : or (b) 1 otherwise.
2526 :
2527 : 13.14.113: Result value for UBOUND
2528 :
2529 : Case (i): For an array section or for an array expression other than a
2530 : whole array or array structure component, UBOUND(ARRAY, DIM)
2531 : has the value equal to the number of elements in the given
2532 : dimension; otherwise, it has a value equal to the upper bound
2533 : for subscript DIM of ARRAY if dimension DIM of ARRAY does
2534 : not have size zero and has value zero if dimension DIM has
2535 : size zero. */
2536 :
2537 16187 : if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
2538 532 : se->expr = gfc_index_one_node;
2539 15655 : else if (as)
2540 : {
2541 15071 : if (op == GFC_ISYM_UBOUND)
2542 : {
2543 5370 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2544 : size, gfc_index_zero_node);
2545 10136 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2546 : gfc_array_index_type, cond,
2547 : (assumed_rank_lb_one ? size : ubound),
2548 : gfc_index_zero_node);
2549 : }
2550 9701 : else if (op == GFC_ISYM_LBOUND)
2551 : {
2552 4902 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2553 : size, gfc_index_zero_node);
2554 4902 : if (as->type == AS_ASSUMED_SIZE)
2555 : {
2556 98 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2557 : logical_type_node, bound,
2558 98 : build_int_cst (TREE_TYPE (bound),
2559 98 : arg->expr->rank - 1));
2560 98 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2561 : logical_type_node, cond, cond1);
2562 : }
2563 4902 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2564 : gfc_array_index_type, cond,
2565 : lbound, gfc_index_one_node);
2566 : }
2567 4799 : else if (op == GFC_ISYM_SHAPE)
2568 4799 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2569 : gfc_array_index_type, size,
2570 : gfc_index_zero_node);
2571 : else
2572 0 : gcc_unreachable ();
2573 :
2574 : /* According to F2018 16.9.172, para 5, an assumed rank object,
2575 : argument associated with and assumed size array, has the ubound
2576 : of the final dimension set to -1 and UBOUND must return this.
2577 : Similarly for the SHAPE intrinsic. */
2578 15071 : if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
2579 : {
2580 811 : tree minus_one = build_int_cst (gfc_array_index_type, -1);
2581 811 : tree rank = fold_convert (gfc_array_index_type,
2582 : gfc_conv_descriptor_rank (desc));
2583 811 : rank = fold_build2_loc (input_location, PLUS_EXPR,
2584 : gfc_array_index_type, rank, minus_one);
2585 :
2586 : /* Fix the expression to stop it from becoming even more
2587 : complicated. */
2588 811 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
2589 :
2590 : /* Descriptors for assumed-size arrays have ubound = -1
2591 : in the last dimension. */
2592 811 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2593 : logical_type_node, ubound, minus_one);
2594 811 : cond = fold_build2_loc (input_location, EQ_EXPR,
2595 : logical_type_node, bound, rank);
2596 811 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2597 : logical_type_node, cond, cond1);
2598 811 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2599 : gfc_array_index_type, cond,
2600 : minus_one, se->expr);
2601 : }
2602 : }
2603 : else /* as is null; this is an old-fashioned 1-based array. */
2604 : {
2605 584 : if (op != GFC_ISYM_LBOUND)
2606 : {
2607 482 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2608 : gfc_array_index_type, size,
2609 : gfc_index_zero_node);
2610 : }
2611 : else
2612 102 : se->expr = gfc_index_one_node;
2613 : }
2614 :
2615 :
2616 16187 : type = gfc_typenode_for_spec (&expr->ts);
2617 16187 : se->expr = convert (type, se->expr);
2618 16187 : }
2619 :
2620 :
2621 : static void
2622 666 : conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2623 : {
2624 666 : gfc_actual_arglist *arg;
2625 666 : gfc_actual_arglist *arg2;
2626 666 : gfc_se argse;
2627 666 : tree bound, lbound, resbound, resbound2, desc, cond, tmp;
2628 666 : tree type;
2629 666 : int corank;
2630 :
2631 666 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2632 : || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2633 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE
2634 : || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2635 :
2636 666 : arg = expr->value.function.actual;
2637 666 : arg2 = arg->next;
2638 :
2639 666 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2640 666 : corank = arg->expr->corank;
2641 :
2642 666 : gfc_init_se (&argse, NULL);
2643 666 : argse.want_coarray = 1;
2644 :
2645 666 : gfc_conv_expr_descriptor (&argse, arg->expr);
2646 666 : gfc_add_block_to_block (&se->pre, &argse.pre);
2647 666 : gfc_add_block_to_block (&se->post, &argse.post);
2648 666 : desc = argse.expr;
2649 :
2650 666 : if (se->ss)
2651 : {
2652 : /* Create an implicit second parameter from the loop variable. */
2653 238 : gcc_assert (!arg2->expr
2654 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE);
2655 238 : gcc_assert (corank > 0);
2656 238 : gcc_assert (se->loop->dimen == 1);
2657 238 : gcc_assert (se->ss->info->expr == expr);
2658 :
2659 238 : bound = se->loop->loopvar[0];
2660 476 : bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2661 238 : bound, gfc_rank_cst[arg->expr->rank]);
2662 238 : gfc_advance_se_ss_chain (se);
2663 : }
2664 428 : else if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2665 0 : bound = gfc_index_zero_node;
2666 : else
2667 : {
2668 428 : gcc_assert (arg2->expr);
2669 428 : gfc_init_se (&argse, NULL);
2670 428 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2671 428 : gfc_add_block_to_block (&se->pre, &argse.pre);
2672 428 : bound = argse.expr;
2673 :
2674 428 : if (INTEGER_CST_P (bound))
2675 : {
2676 334 : if (wi::ltu_p (wi::to_wide (bound), 1)
2677 668 : || wi::gtu_p (wi::to_wide (bound),
2678 334 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2679 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2680 0 : "dimension index", expr->value.function.isym->name,
2681 : &expr->where);
2682 : }
2683 94 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2684 : {
2685 36 : bound = gfc_evaluate_now (bound, &se->pre);
2686 36 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2687 36 : bound, build_int_cst (TREE_TYPE (bound), 1));
2688 36 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2689 36 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2690 : bound, tmp);
2691 36 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2692 : logical_type_node, cond, tmp);
2693 36 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2694 : gfc_msg_fault);
2695 : }
2696 :
2697 :
2698 : /* Subtract 1 to get to zero based and add dimensions. */
2699 428 : switch (arg->expr->rank)
2700 : {
2701 70 : case 0:
2702 70 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2703 : gfc_array_index_type, bound,
2704 : gfc_index_one_node);
2705 : case 1:
2706 : break;
2707 38 : default:
2708 38 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2709 : gfc_array_index_type, bound,
2710 38 : gfc_rank_cst[arg->expr->rank - 1]);
2711 : }
2712 : }
2713 :
2714 666 : resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2715 :
2716 : /* COSHAPE needs the lower cobound and so it is stashed here before resbound
2717 : is overwritten. */
2718 666 : lbound = NULL_TREE;
2719 666 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2720 4 : lbound = resbound;
2721 :
2722 : /* Handle UCOBOUND with special handling of the last codimension. */
2723 666 : if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2724 422 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2725 : {
2726 : /* Last codimension: For -fcoarray=single just return
2727 : the lcobound - otherwise add
2728 : ceiling (real (num_images ()) / real (size)) - 1
2729 : = (num_images () + size - 1) / size - 1
2730 : = (num_images - 1) / size(),
2731 : where size is the product of the extent of all but the last
2732 : codimension. */
2733 :
2734 248 : if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2735 : {
2736 64 : tree cosize;
2737 :
2738 64 : cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2739 64 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2740 : 2, null_pointer_node, null_pointer_node);
2741 64 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2742 : gfc_array_index_type,
2743 : fold_convert (gfc_array_index_type, tmp),
2744 : build_int_cst (gfc_array_index_type, 1));
2745 64 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2746 : gfc_array_index_type, tmp,
2747 : fold_convert (gfc_array_index_type, cosize));
2748 64 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2749 : gfc_array_index_type, resbound, tmp);
2750 64 : }
2751 184 : else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2752 : {
2753 : /* ubound = lbound + num_images() - 1. */
2754 44 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2755 : 2, null_pointer_node, null_pointer_node);
2756 44 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2757 : gfc_array_index_type,
2758 : fold_convert (gfc_array_index_type, tmp),
2759 : build_int_cst (gfc_array_index_type, 1));
2760 44 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2761 : gfc_array_index_type, resbound, tmp);
2762 : }
2763 :
2764 248 : if (corank > 1)
2765 : {
2766 171 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2767 : bound,
2768 171 : build_int_cst (TREE_TYPE (bound),
2769 171 : arg->expr->rank + corank - 1));
2770 :
2771 171 : resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2772 171 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2773 : gfc_array_index_type, cond,
2774 : resbound, resbound2);
2775 : }
2776 : else
2777 77 : se->expr = resbound;
2778 :
2779 : /* Get the coshape for this dimension. */
2780 248 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2781 : {
2782 4 : gcc_assert (lbound != NULL_TREE);
2783 4 : se->expr = fold_build2_loc (input_location, MINUS_EXPR,
2784 : gfc_array_index_type,
2785 : se->expr, lbound);
2786 4 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2787 : gfc_array_index_type,
2788 : se->expr, gfc_index_one_node);
2789 : }
2790 : }
2791 : else
2792 418 : se->expr = resbound;
2793 :
2794 666 : type = gfc_typenode_for_spec (&expr->ts);
2795 666 : se->expr = convert (type, se->expr);
2796 666 : }
2797 :
2798 :
2799 : static void
2800 2281 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2801 : {
2802 2281 : gfc_actual_arglist *array_arg;
2803 2281 : gfc_actual_arglist *dim_arg;
2804 2281 : gfc_se argse;
2805 2281 : tree desc, tmp;
2806 :
2807 2281 : array_arg = expr->value.function.actual;
2808 2281 : dim_arg = array_arg->next;
2809 :
2810 2281 : gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2811 :
2812 2281 : gfc_init_se (&argse, NULL);
2813 2281 : gfc_conv_expr_descriptor (&argse, array_arg->expr);
2814 2281 : gfc_add_block_to_block (&se->pre, &argse.pre);
2815 2281 : gfc_add_block_to_block (&se->post, &argse.post);
2816 2281 : desc = argse.expr;
2817 :
2818 2281 : gcc_assert (dim_arg->expr);
2819 2281 : gfc_init_se (&argse, NULL);
2820 2281 : gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2821 2281 : gfc_add_block_to_block (&se->pre, &argse.pre);
2822 2281 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2823 : argse.expr, gfc_index_one_node);
2824 2281 : se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2825 2281 : }
2826 :
2827 : static void
2828 7872 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2829 : {
2830 7872 : tree arg, cabs;
2831 :
2832 7872 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2833 :
2834 7872 : switch (expr->value.function.actual->expr->ts.type)
2835 : {
2836 6866 : case BT_INTEGER:
2837 6866 : case BT_REAL:
2838 6866 : se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2839 : arg);
2840 6866 : break;
2841 :
2842 1006 : case BT_COMPLEX:
2843 1006 : cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
2844 1006 : se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2845 1006 : break;
2846 :
2847 0 : default:
2848 0 : gcc_unreachable ();
2849 : }
2850 7872 : }
2851 :
2852 :
2853 : /* Create a complex value from one or two real components. */
2854 :
2855 : static void
2856 491 : gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2857 : {
2858 491 : tree real;
2859 491 : tree imag;
2860 491 : tree type;
2861 491 : tree *args;
2862 491 : unsigned int num_args;
2863 :
2864 491 : num_args = gfc_intrinsic_argument_list_length (expr);
2865 491 : args = XALLOCAVEC (tree, num_args);
2866 :
2867 491 : type = gfc_typenode_for_spec (&expr->ts);
2868 491 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2869 491 : real = convert (TREE_TYPE (type), args[0]);
2870 491 : if (both)
2871 447 : imag = convert (TREE_TYPE (type), args[1]);
2872 44 : else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
2873 : {
2874 30 : imag = fold_build1_loc (input_location, IMAGPART_EXPR,
2875 30 : TREE_TYPE (TREE_TYPE (args[0])), args[0]);
2876 30 : imag = convert (TREE_TYPE (type), imag);
2877 : }
2878 : else
2879 14 : imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
2880 :
2881 491 : se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
2882 491 : }
2883 :
2884 :
2885 : /* Remainder function MOD(A, P) = A - INT(A / P) * P
2886 : MODULO(A, P) = A - FLOOR (A / P) * P
2887 :
2888 : The obvious algorithms above are numerically instable for large
2889 : arguments, hence these intrinsics are instead implemented via calls
2890 : to the fmod family of functions. It is the responsibility of the
2891 : user to ensure that the second argument is non-zero. */
2892 :
2893 : static void
2894 3663 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2895 : {
2896 3663 : tree type;
2897 3663 : tree tmp;
2898 3663 : tree test;
2899 3663 : tree test2;
2900 3663 : tree fmod;
2901 3663 : tree zero;
2902 3663 : tree args[2];
2903 :
2904 3663 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
2905 :
2906 3663 : switch (expr->ts.type)
2907 : {
2908 3510 : case BT_INTEGER:
2909 : /* Integer case is easy, we've got a builtin op. */
2910 3510 : type = TREE_TYPE (args[0]);
2911 :
2912 3510 : if (modulo)
2913 411 : se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2914 : args[0], args[1]);
2915 : else
2916 3099 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2917 : args[0], args[1]);
2918 : break;
2919 :
2920 30 : case BT_UNSIGNED:
2921 : /* Even easier, we only need one. */
2922 30 : type = TREE_TYPE (args[0]);
2923 30 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2924 : args[0], args[1]);
2925 30 : break;
2926 :
2927 123 : case BT_REAL:
2928 123 : fmod = NULL_TREE;
2929 : /* Check if we have a builtin fmod. */
2930 123 : fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
2931 :
2932 : /* The builtin should always be available. */
2933 123 : gcc_assert (fmod != NULL_TREE);
2934 :
2935 123 : tmp = build_addr (fmod);
2936 123 : se->expr = build_call_array_loc (input_location,
2937 123 : TREE_TYPE (TREE_TYPE (fmod)),
2938 : tmp, 2, args);
2939 123 : if (modulo == 0)
2940 123 : return;
2941 :
2942 25 : type = TREE_TYPE (args[0]);
2943 :
2944 25 : args[0] = gfc_evaluate_now (args[0], &se->pre);
2945 25 : args[1] = gfc_evaluate_now (args[1], &se->pre);
2946 :
2947 : /* Definition:
2948 : modulo = arg - floor (arg/arg2) * arg2
2949 :
2950 : In order to calculate the result accurately, we use the fmod
2951 : function as follows.
2952 :
2953 : res = fmod (arg, arg2);
2954 : if (res)
2955 : {
2956 : if ((arg < 0) xor (arg2 < 0))
2957 : res += arg2;
2958 : }
2959 : else
2960 : res = copysign (0., arg2);
2961 :
2962 : => As two nested ternary exprs:
2963 :
2964 : res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2965 : : copysign (0., arg2);
2966 :
2967 : */
2968 :
2969 25 : zero = gfc_build_const (type, integer_zero_node);
2970 25 : tmp = gfc_evaluate_now (se->expr, &se->pre);
2971 25 : if (!flag_signed_zeros)
2972 : {
2973 1 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2974 : args[0], zero);
2975 1 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2976 : args[1], zero);
2977 1 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2978 : logical_type_node, test, test2);
2979 1 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2980 : tmp, zero);
2981 1 : test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2982 : logical_type_node, test, test2);
2983 1 : test = gfc_evaluate_now (test, &se->pre);
2984 1 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2985 : fold_build2_loc (input_location,
2986 : PLUS_EXPR,
2987 : type, tmp, args[1]),
2988 : tmp);
2989 : }
2990 : else
2991 : {
2992 24 : tree expr1, copysign, cscall;
2993 24 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
2994 : expr->ts.kind);
2995 24 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2996 : args[0], zero);
2997 24 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2998 : args[1], zero);
2999 24 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3000 : logical_type_node, test, test2);
3001 24 : expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3002 : fold_build2_loc (input_location,
3003 : PLUS_EXPR,
3004 : type, tmp, args[1]),
3005 : tmp);
3006 24 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3007 : tmp, zero);
3008 24 : cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3009 : args[1]);
3010 24 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3011 : expr1, cscall);
3012 : }
3013 : return;
3014 :
3015 0 : default:
3016 0 : gcc_unreachable ();
3017 : }
3018 : }
3019 :
3020 : /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3021 : DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3022 : where the right shifts are logical (i.e. 0's are shifted in).
3023 : Because SHIFT_EXPR's want shifts strictly smaller than the integral
3024 : type width, we have to special-case both S == 0 and S == BITSIZE(J):
3025 : DSHIFTL(I,J,0) = I
3026 : DSHIFTL(I,J,BITSIZE) = J
3027 : DSHIFTR(I,J,0) = J
3028 : DSHIFTR(I,J,BITSIZE) = I. */
3029 :
3030 : static void
3031 132 : gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3032 : {
3033 132 : tree type, utype, stype, arg1, arg2, shift, res, left, right;
3034 132 : tree args[3], cond, tmp;
3035 132 : int bitsize;
3036 :
3037 132 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
3038 :
3039 132 : gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3040 132 : type = TREE_TYPE (args[0]);
3041 132 : bitsize = TYPE_PRECISION (type);
3042 132 : utype = unsigned_type_for (type);
3043 132 : stype = TREE_TYPE (args[2]);
3044 :
3045 132 : arg1 = gfc_evaluate_now (args[0], &se->pre);
3046 132 : arg2 = gfc_evaluate_now (args[1], &se->pre);
3047 132 : shift = gfc_evaluate_now (args[2], &se->pre);
3048 :
3049 : /* The generic case. */
3050 132 : tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3051 132 : build_int_cst (stype, bitsize), shift);
3052 198 : left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3053 : arg1, dshiftl ? shift : tmp);
3054 :
3055 198 : right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3056 : fold_convert (utype, arg2), dshiftl ? tmp : shift);
3057 132 : right = fold_convert (type, right);
3058 :
3059 132 : res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3060 :
3061 : /* Special cases. */
3062 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3063 : build_int_cst (stype, 0));
3064 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3065 : dshiftl ? arg1 : arg2, res);
3066 :
3067 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3068 132 : build_int_cst (stype, bitsize));
3069 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3070 : dshiftl ? arg2 : arg1, res);
3071 :
3072 132 : se->expr = res;
3073 132 : }
3074 :
3075 :
3076 : /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3077 :
3078 : static void
3079 96 : gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3080 : {
3081 96 : tree val;
3082 96 : tree tmp;
3083 96 : tree type;
3084 96 : tree zero;
3085 96 : tree args[2];
3086 :
3087 96 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3088 96 : type = TREE_TYPE (args[0]);
3089 :
3090 96 : val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3091 96 : val = gfc_evaluate_now (val, &se->pre);
3092 :
3093 96 : zero = gfc_build_const (type, integer_zero_node);
3094 96 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3095 96 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3096 96 : }
3097 :
3098 :
3099 : /* SIGN(A, B) is absolute value of A times sign of B.
3100 : The real value versions use library functions to ensure the correct
3101 : handling of negative zero. Integer case implemented as:
3102 : SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3103 : */
3104 :
3105 : static void
3106 423 : gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3107 : {
3108 423 : tree tmp;
3109 423 : tree type;
3110 423 : tree args[2];
3111 :
3112 423 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3113 423 : if (expr->ts.type == BT_REAL)
3114 : {
3115 161 : tree abs;
3116 :
3117 161 : tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3118 161 : abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3119 :
3120 : /* We explicitly have to ignore the minus sign. We do so by using
3121 : result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3122 161 : if (!flag_sign_zero
3123 197 : && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3124 : {
3125 12 : tree cond, zero;
3126 12 : zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3127 12 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3128 : args[1], zero);
3129 24 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3130 12 : TREE_TYPE (args[0]), cond,
3131 : build_call_expr_loc (input_location, abs, 1,
3132 : args[0]),
3133 : build_call_expr_loc (input_location, tmp, 2,
3134 : args[0], args[1]));
3135 : }
3136 : else
3137 149 : se->expr = build_call_expr_loc (input_location, tmp, 2,
3138 : args[0], args[1]);
3139 161 : return;
3140 : }
3141 :
3142 : /* Having excluded floating point types, we know we are now dealing
3143 : with signed integer types. */
3144 262 : type = TREE_TYPE (args[0]);
3145 :
3146 : /* Args[0] is used multiple times below. */
3147 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3148 :
3149 : /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3150 : the signs of A and B are the same, and of all ones if they differ. */
3151 262 : tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3152 262 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3153 262 : build_int_cst (type, TYPE_PRECISION (type) - 1));
3154 262 : tmp = gfc_evaluate_now (tmp, &se->pre);
3155 :
3156 : /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3157 : is all ones (i.e. -1). */
3158 262 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3159 : fold_build2_loc (input_location, PLUS_EXPR,
3160 : type, args[0], tmp), tmp);
3161 : }
3162 :
3163 :
3164 : /* Test for the presence of an optional argument. */
3165 :
3166 : static void
3167 5070 : gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3168 : {
3169 5070 : gfc_expr *arg;
3170 :
3171 5070 : arg = expr->value.function.actual->expr;
3172 5070 : gcc_assert (arg->expr_type == EXPR_VARIABLE);
3173 5070 : se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3174 5070 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3175 5070 : }
3176 :
3177 :
3178 : /* Calculate the double precision product of two single precision values. */
3179 :
3180 : static void
3181 13 : gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3182 : {
3183 13 : tree type;
3184 13 : tree args[2];
3185 :
3186 13 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3187 :
3188 : /* Convert the args to double precision before multiplying. */
3189 13 : type = gfc_typenode_for_spec (&expr->ts);
3190 13 : args[0] = convert (type, args[0]);
3191 13 : args[1] = convert (type, args[1]);
3192 13 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3193 : args[1]);
3194 13 : }
3195 :
3196 :
3197 : /* Return a length one character string containing an ascii character. */
3198 :
3199 : static void
3200 2020 : gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3201 : {
3202 2020 : tree arg[2];
3203 2020 : tree var;
3204 2020 : tree type;
3205 2020 : unsigned int num_args;
3206 :
3207 2020 : num_args = gfc_intrinsic_argument_list_length (expr);
3208 2020 : gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3209 :
3210 2020 : type = gfc_get_char_type (expr->ts.kind);
3211 2020 : var = gfc_create_var (type, "char");
3212 :
3213 2020 : arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3214 2020 : gfc_add_modify (&se->pre, var, arg[0]);
3215 2020 : se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3216 2020 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3217 2020 : }
3218 :
3219 :
3220 : static void
3221 0 : gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3222 : {
3223 0 : tree var;
3224 0 : tree len;
3225 0 : tree tmp;
3226 0 : tree cond;
3227 0 : tree fndecl;
3228 0 : tree *args;
3229 0 : unsigned int num_args;
3230 :
3231 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3232 0 : args = XALLOCAVEC (tree, num_args);
3233 :
3234 0 : var = gfc_create_var (pchar_type_node, "pstr");
3235 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3236 :
3237 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3238 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3239 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3240 :
3241 0 : fndecl = build_addr (gfor_fndecl_ctime);
3242 0 : tmp = build_call_array_loc (input_location,
3243 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3244 : fndecl, num_args, args);
3245 0 : gfc_add_expr_to_block (&se->pre, tmp);
3246 :
3247 : /* Free the temporary afterwards, if necessary. */
3248 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3249 0 : len, build_int_cst (TREE_TYPE (len), 0));
3250 0 : tmp = gfc_call_free (var);
3251 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3252 0 : gfc_add_expr_to_block (&se->post, tmp);
3253 :
3254 0 : se->expr = var;
3255 0 : se->string_length = len;
3256 0 : }
3257 :
3258 :
3259 : static void
3260 0 : gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3261 : {
3262 0 : tree var;
3263 0 : tree len;
3264 0 : tree tmp;
3265 0 : tree cond;
3266 0 : tree fndecl;
3267 0 : tree *args;
3268 0 : unsigned int num_args;
3269 :
3270 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3271 0 : args = XALLOCAVEC (tree, num_args);
3272 :
3273 0 : var = gfc_create_var (pchar_type_node, "pstr");
3274 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3275 :
3276 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3277 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3278 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3279 :
3280 0 : fndecl = build_addr (gfor_fndecl_fdate);
3281 0 : tmp = build_call_array_loc (input_location,
3282 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3283 : fndecl, num_args, args);
3284 0 : gfc_add_expr_to_block (&se->pre, tmp);
3285 :
3286 : /* Free the temporary afterwards, if necessary. */
3287 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3288 0 : len, build_int_cst (TREE_TYPE (len), 0));
3289 0 : tmp = gfc_call_free (var);
3290 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3291 0 : gfc_add_expr_to_block (&se->post, tmp);
3292 :
3293 0 : se->expr = var;
3294 0 : se->string_length = len;
3295 0 : }
3296 :
3297 :
3298 : /* Generate a direct call to free() for the FREE subroutine. */
3299 :
3300 : static tree
3301 10 : conv_intrinsic_free (gfc_code *code)
3302 : {
3303 10 : stmtblock_t block;
3304 10 : gfc_se argse;
3305 10 : tree arg, call;
3306 :
3307 10 : gfc_init_se (&argse, NULL);
3308 10 : gfc_conv_expr (&argse, code->ext.actual->expr);
3309 10 : arg = fold_convert (ptr_type_node, argse.expr);
3310 :
3311 10 : gfc_init_block (&block);
3312 10 : call = build_call_expr_loc (input_location,
3313 : builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3314 10 : gfc_add_expr_to_block (&block, call);
3315 10 : return gfc_finish_block (&block);
3316 : }
3317 :
3318 :
3319 : /* Call the RANDOM_INIT library subroutine with a hidden argument for
3320 : handling seeding on coarray images. */
3321 :
3322 : static tree
3323 90 : conv_intrinsic_random_init (gfc_code *code)
3324 : {
3325 90 : stmtblock_t block;
3326 90 : gfc_se se;
3327 90 : tree arg1, arg2, tmp;
3328 : /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3329 90 : tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3330 90 : ? logical_type_node
3331 90 : : gfc_get_logical_type (4);
3332 :
3333 : /* Make the function call. */
3334 90 : gfc_init_block (&block);
3335 90 : gfc_init_se (&se, NULL);
3336 :
3337 : /* Convert REPEATABLE to the desired LOGICAL entity. */
3338 90 : gfc_conv_expr (&se, code->ext.actual->expr);
3339 90 : gfc_add_block_to_block (&block, &se.pre);
3340 90 : arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3341 90 : gfc_add_block_to_block (&block, &se.post);
3342 :
3343 : /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3344 90 : gfc_conv_expr (&se, code->ext.actual->next->expr);
3345 90 : gfc_add_block_to_block (&block, &se.pre);
3346 90 : arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3347 90 : gfc_add_block_to_block (&block, &se.post);
3348 :
3349 90 : if (flag_coarray == GFC_FCOARRAY_LIB)
3350 : {
3351 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3352 : 2, arg1, arg2);
3353 : }
3354 : else
3355 : {
3356 : /* The ABI for libgfortran needs to be maintained, so a hidden
3357 : argument must be include if code is compiled with -fcoarray=single
3358 : or without the option. Set to 0. */
3359 90 : tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3360 90 : tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3361 : 3, arg1, arg2, arg3);
3362 : }
3363 :
3364 90 : gfc_add_expr_to_block (&block, tmp);
3365 :
3366 90 : return gfc_finish_block (&block);
3367 : }
3368 :
3369 :
3370 : /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3371 : conversions. */
3372 :
3373 : static tree
3374 194 : conv_intrinsic_system_clock (gfc_code *code)
3375 : {
3376 194 : stmtblock_t block;
3377 194 : gfc_se count_se, count_rate_se, count_max_se;
3378 194 : tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3379 194 : tree tmp;
3380 194 : int least;
3381 :
3382 194 : gfc_expr *count = code->ext.actual->expr;
3383 194 : gfc_expr *count_rate = code->ext.actual->next->expr;
3384 194 : gfc_expr *count_max = code->ext.actual->next->next->expr;
3385 :
3386 : /* Evaluate our arguments. */
3387 194 : if (count)
3388 : {
3389 194 : gfc_init_se (&count_se, NULL);
3390 194 : gfc_conv_expr (&count_se, count);
3391 : }
3392 :
3393 194 : if (count_rate)
3394 : {
3395 181 : gfc_init_se (&count_rate_se, NULL);
3396 181 : gfc_conv_expr (&count_rate_se, count_rate);
3397 : }
3398 :
3399 194 : if (count_max)
3400 : {
3401 180 : gfc_init_se (&count_max_se, NULL);
3402 180 : gfc_conv_expr (&count_max_se, count_max);
3403 : }
3404 :
3405 : /* Find the smallest kind found of the arguments. */
3406 194 : least = 16;
3407 194 : least = (count && count->ts.kind < least) ? count->ts.kind : least;
3408 194 : least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3409 : : least;
3410 194 : least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3411 : : least;
3412 :
3413 : /* Prepare temporary variables. */
3414 :
3415 194 : if (count)
3416 : {
3417 194 : if (least >= 8)
3418 18 : arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3419 176 : else if (least == 4)
3420 152 : arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3421 24 : else if (count->ts.kind == 1)
3422 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3423 : count->ts.kind);
3424 : else
3425 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3426 : count->ts.kind);
3427 : }
3428 :
3429 194 : if (count_rate)
3430 : {
3431 181 : if (least >= 8)
3432 18 : arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3433 163 : else if (least == 4)
3434 139 : arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3435 : else
3436 24 : arg2 = integer_zero_node;
3437 : }
3438 :
3439 194 : if (count_max)
3440 : {
3441 180 : if (least >= 8)
3442 18 : arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3443 162 : else if (least == 4)
3444 138 : arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3445 : else
3446 24 : arg3 = integer_zero_node;
3447 : }
3448 :
3449 : /* Make the function call. */
3450 194 : gfc_init_block (&block);
3451 :
3452 194 : if (least <= 2)
3453 : {
3454 24 : if (least == 1)
3455 : {
3456 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3457 : : null_pointer_node;
3458 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3459 : : null_pointer_node;
3460 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3461 : : null_pointer_node;
3462 : }
3463 :
3464 24 : if (least == 2)
3465 : {
3466 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3467 : : null_pointer_node;
3468 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3469 : : null_pointer_node;
3470 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3471 : : null_pointer_node;
3472 : }
3473 : }
3474 : else
3475 : {
3476 170 : if (least == 4)
3477 : {
3478 581 : tmp = build_call_expr_loc (input_location,
3479 : gfor_fndecl_system_clock4, 3,
3480 152 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3481 : : null_pointer_node,
3482 139 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3483 : : null_pointer_node,
3484 138 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3485 : : null_pointer_node);
3486 152 : gfc_add_expr_to_block (&block, tmp);
3487 : }
3488 : /* Handle kind>=8, 10, or 16 arguments */
3489 170 : if (least >= 8)
3490 : {
3491 72 : tmp = build_call_expr_loc (input_location,
3492 : gfor_fndecl_system_clock8, 3,
3493 18 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3494 : : null_pointer_node,
3495 18 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3496 : : null_pointer_node,
3497 18 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3498 : : null_pointer_node);
3499 18 : gfc_add_expr_to_block (&block, tmp);
3500 : }
3501 : }
3502 :
3503 : /* And store values back if needed. */
3504 194 : if (arg1 && arg1 != count_se.expr)
3505 194 : gfc_add_modify (&block, count_se.expr,
3506 194 : fold_convert (TREE_TYPE (count_se.expr), arg1));
3507 194 : if (arg2 && arg2 != count_rate_se.expr)
3508 181 : gfc_add_modify (&block, count_rate_se.expr,
3509 181 : fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3510 194 : if (arg3 && arg3 != count_max_se.expr)
3511 180 : gfc_add_modify (&block, count_max_se.expr,
3512 180 : fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3513 :
3514 194 : return gfc_finish_block (&block);
3515 : }
3516 :
3517 : static tree
3518 102 : conv_intrinsic_split (gfc_code *code)
3519 : {
3520 102 : stmtblock_t block, post_block;
3521 102 : gfc_se se;
3522 102 : gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
3523 102 : tree string, string_len;
3524 102 : tree set, set_len;
3525 102 : tree pos, pos_for_call;
3526 102 : tree back;
3527 102 : tree fndecl, call;
3528 :
3529 102 : string_expr = code->ext.actual->expr;
3530 102 : set_expr = code->ext.actual->next->expr;
3531 102 : pos_expr = code->ext.actual->next->next->expr;
3532 102 : back_expr = code->ext.actual->next->next->next->expr;
3533 :
3534 102 : gfc_start_block (&block);
3535 102 : gfc_init_block (&post_block);
3536 :
3537 102 : gfc_init_se (&se, NULL);
3538 102 : gfc_conv_expr (&se, string_expr);
3539 102 : gfc_conv_string_parameter (&se);
3540 102 : gfc_add_block_to_block (&block, &se.pre);
3541 102 : gfc_add_block_to_block (&post_block, &se.post);
3542 102 : string = se.expr;
3543 102 : string_len = se.string_length;
3544 :
3545 102 : gfc_init_se (&se, NULL);
3546 102 : gfc_conv_expr (&se, set_expr);
3547 102 : gfc_conv_string_parameter (&se);
3548 102 : gfc_add_block_to_block (&block, &se.pre);
3549 102 : gfc_add_block_to_block (&post_block, &se.post);
3550 102 : set = se.expr;
3551 102 : set_len = se.string_length;
3552 :
3553 102 : gfc_init_se (&se, NULL);
3554 102 : gfc_conv_expr (&se, pos_expr);
3555 102 : gfc_add_block_to_block (&block, &se.pre);
3556 102 : gfc_add_block_to_block (&post_block, &se.post);
3557 102 : pos = se.expr;
3558 102 : pos_for_call = fold_convert (gfc_charlen_type_node, pos);
3559 :
3560 102 : if (back_expr)
3561 : {
3562 48 : gfc_init_se (&se, NULL);
3563 48 : gfc_conv_expr (&se, back_expr);
3564 48 : gfc_add_block_to_block (&block, &se.pre);
3565 48 : gfc_add_block_to_block (&post_block, &se.post);
3566 48 : back = se.expr;
3567 : }
3568 : else
3569 54 : back = logical_false_node;
3570 :
3571 102 : if (string_expr->ts.kind == 1)
3572 66 : fndecl = gfor_fndecl_string_split;
3573 36 : else if (string_expr->ts.kind == 4)
3574 36 : fndecl = gfor_fndecl_string_split_char4;
3575 : else
3576 0 : gcc_unreachable ();
3577 :
3578 102 : call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
3579 : set_len, set, pos_for_call, back);
3580 102 : gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
3581 :
3582 102 : gfc_add_block_to_block (&block, &post_block);
3583 102 : return gfc_finish_block (&block);
3584 : }
3585 :
3586 : /* Return a character string containing the tty name. */
3587 :
3588 : static void
3589 0 : gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3590 : {
3591 0 : tree var;
3592 0 : tree len;
3593 0 : tree tmp;
3594 0 : tree cond;
3595 0 : tree fndecl;
3596 0 : tree *args;
3597 0 : unsigned int num_args;
3598 :
3599 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3600 0 : args = XALLOCAVEC (tree, num_args);
3601 :
3602 0 : var = gfc_create_var (pchar_type_node, "pstr");
3603 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3604 :
3605 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3606 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3607 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3608 :
3609 0 : fndecl = build_addr (gfor_fndecl_ttynam);
3610 0 : tmp = build_call_array_loc (input_location,
3611 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3612 : fndecl, num_args, args);
3613 0 : gfc_add_expr_to_block (&se->pre, tmp);
3614 :
3615 : /* Free the temporary afterwards, if necessary. */
3616 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3617 0 : len, build_int_cst (TREE_TYPE (len), 0));
3618 0 : tmp = gfc_call_free (var);
3619 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3620 0 : gfc_add_expr_to_block (&se->post, tmp);
3621 :
3622 0 : se->expr = var;
3623 0 : se->string_length = len;
3624 0 : }
3625 :
3626 :
3627 : /* Get the minimum/maximum value of all the parameters.
3628 : minmax (a1, a2, a3, ...)
3629 : {
3630 : mvar = a1;
3631 : mvar = COMP (mvar, a2)
3632 : mvar = COMP (mvar, a3)
3633 : ...
3634 : return mvar;
3635 : }
3636 : Where COMP is MIN/MAX_EXPR for integral types or when we don't
3637 : care about NaNs, or IFN_FMIN/MAX when the target has support for
3638 : fast NaN-honouring min/max. When neither holds expand a sequence
3639 : of explicit comparisons. */
3640 :
3641 : /* TODO: Mismatching types can occur when specific names are used.
3642 : These should be handled during resolution. */
3643 : static void
3644 1365 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3645 : {
3646 1365 : tree tmp;
3647 1365 : tree mvar;
3648 1365 : tree val;
3649 1365 : tree *args;
3650 1365 : tree type;
3651 1365 : tree argtype;
3652 1365 : gfc_actual_arglist *argexpr;
3653 1365 : unsigned int i, nargs;
3654 :
3655 1365 : nargs = gfc_intrinsic_argument_list_length (expr);
3656 1365 : args = XALLOCAVEC (tree, nargs);
3657 :
3658 1365 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3659 1365 : type = gfc_typenode_for_spec (&expr->ts);
3660 :
3661 : /* Only evaluate the argument once. */
3662 1365 : if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3663 368 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3664 :
3665 : /* Determine suitable type of temporary, as a GNU extension allows
3666 : different argument kinds. */
3667 1365 : argtype = TREE_TYPE (args[0]);
3668 1365 : argexpr = expr->value.function.actual;
3669 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3670 : {
3671 1584 : tree tmptype = TREE_TYPE (args[i]);
3672 1584 : if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
3673 1 : argtype = tmptype;
3674 : }
3675 1365 : mvar = gfc_create_var (argtype, "M");
3676 1365 : gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
3677 :
3678 1365 : argexpr = expr->value.function.actual;
3679 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3680 : {
3681 1584 : tree cond = NULL_TREE;
3682 1584 : val = args[i];
3683 :
3684 : /* Handle absent optional arguments by ignoring the comparison. */
3685 1584 : if (argexpr->expr->expr_type == EXPR_VARIABLE
3686 920 : && argexpr->expr->symtree->n.sym->attr.optional
3687 45 : && INDIRECT_REF_P (val))
3688 : {
3689 84 : cond = fold_build2_loc (input_location,
3690 : NE_EXPR, logical_type_node,
3691 42 : TREE_OPERAND (val, 0),
3692 42 : build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3693 : }
3694 1542 : else if (!VAR_P (val) && !TREE_CONSTANT (val))
3695 : /* Only evaluate the argument once. */
3696 599 : val = gfc_evaluate_now (val, &se->pre);
3697 :
3698 1584 : tree calc;
3699 : /* For floating point types, the question is what MAX(a, NaN) or
3700 : MIN(a, NaN) should return (where "a" is a normal number).
3701 : There are valid use case for returning either one, but the
3702 : Fortran standard doesn't specify which one should be chosen.
3703 : Also, there is no consensus among other tested compilers. In
3704 : short, it's a mess. So lets just do whatever is fastest. */
3705 1584 : tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
3706 1584 : calc = fold_build2_loc (input_location, code, argtype,
3707 : convert (argtype, val), mvar);
3708 1584 : tmp = build2_v (MODIFY_EXPR, mvar, calc);
3709 :
3710 1584 : if (cond != NULL_TREE)
3711 42 : tmp = build3_v (COND_EXPR, cond, tmp,
3712 : build_empty_stmt (input_location));
3713 1584 : gfc_add_expr_to_block (&se->pre, tmp);
3714 : }
3715 1365 : se->expr = convert (type, mvar);
3716 1365 : }
3717 :
3718 :
3719 : /* Generate library calls for MIN and MAX intrinsics for character
3720 : variables. */
3721 : static void
3722 282 : gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3723 : {
3724 282 : tree *args;
3725 282 : tree var, len, fndecl, tmp, cond, function;
3726 282 : unsigned int nargs;
3727 :
3728 282 : nargs = gfc_intrinsic_argument_list_length (expr);
3729 282 : args = XALLOCAVEC (tree, nargs + 4);
3730 282 : gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3731 :
3732 : /* Create the result variables. */
3733 282 : len = gfc_create_var (gfc_charlen_type_node, "len");
3734 282 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
3735 282 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3736 282 : args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3737 282 : args[2] = build_int_cst (integer_type_node, op);
3738 282 : args[3] = build_int_cst (integer_type_node, nargs / 2);
3739 :
3740 282 : if (expr->ts.kind == 1)
3741 210 : function = gfor_fndecl_string_minmax;
3742 72 : else if (expr->ts.kind == 4)
3743 72 : function = gfor_fndecl_string_minmax_char4;
3744 : else
3745 0 : gcc_unreachable ();
3746 :
3747 : /* Make the function call. */
3748 282 : fndecl = build_addr (function);
3749 282 : tmp = build_call_array_loc (input_location,
3750 282 : TREE_TYPE (TREE_TYPE (function)), fndecl,
3751 : nargs + 4, args);
3752 282 : gfc_add_expr_to_block (&se->pre, tmp);
3753 :
3754 : /* Free the temporary afterwards, if necessary. */
3755 282 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3756 282 : len, build_int_cst (TREE_TYPE (len), 0));
3757 282 : tmp = gfc_call_free (var);
3758 282 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3759 282 : gfc_add_expr_to_block (&se->post, tmp);
3760 :
3761 282 : se->expr = var;
3762 282 : se->string_length = len;
3763 282 : }
3764 :
3765 :
3766 : /* Create a symbol node for this intrinsic. The symbol from the frontend
3767 : has the generic name. */
3768 :
3769 : static gfc_symbol *
3770 11270 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3771 : {
3772 11270 : gfc_symbol *sym;
3773 :
3774 : /* TODO: Add symbols for intrinsic function to the global namespace. */
3775 11270 : gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3776 11270 : sym = gfc_new_symbol (expr->value.function.name, NULL);
3777 :
3778 11270 : sym->ts = expr->ts;
3779 11270 : if (sym->ts.type == BT_CHARACTER)
3780 1784 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3781 11270 : sym->attr.external = 1;
3782 11270 : sym->attr.function = 1;
3783 11270 : sym->attr.always_explicit = 1;
3784 11270 : sym->attr.proc = PROC_INTRINSIC;
3785 11270 : sym->attr.flavor = FL_PROCEDURE;
3786 11270 : sym->result = sym;
3787 11270 : if (expr->rank > 0)
3788 : {
3789 9878 : sym->attr.dimension = 1;
3790 9878 : sym->as = gfc_get_array_spec ();
3791 9878 : sym->as->type = AS_ASSUMED_SHAPE;
3792 9878 : sym->as->rank = expr->rank;
3793 : }
3794 :
3795 11270 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3796 : ignore_optional ? expr->value.function.actual
3797 : : NULL);
3798 :
3799 11270 : return sym;
3800 : }
3801 :
3802 : /* Remove empty actual arguments. */
3803 :
3804 : static void
3805 8277 : remove_empty_actual_arguments (gfc_actual_arglist **ap)
3806 : {
3807 44456 : while (*ap)
3808 : {
3809 36179 : if ((*ap)->expr == NULL)
3810 : {
3811 11076 : gfc_actual_arglist *r = *ap;
3812 11076 : *ap = r->next;
3813 11076 : r->next = NULL;
3814 11076 : gfc_free_actual_arglist (r);
3815 : }
3816 : else
3817 25103 : ap = &((*ap)->next);
3818 : }
3819 8277 : }
3820 :
3821 : #define MAX_SPEC_ARG 12
3822 :
3823 : /* Make up an fn spec that's right for intrinsic functions that we
3824 : want to call. */
3825 :
3826 : static char *
3827 1939 : intrinsic_fnspec (gfc_expr *expr)
3828 : {
3829 1939 : static char fnspec_buf[MAX_SPEC_ARG*2+1];
3830 1939 : char *fp;
3831 1939 : int i;
3832 1939 : int num_char_args;
3833 :
3834 : #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
3835 :
3836 : /* Set the fndecl. */
3837 1939 : fp = fnspec_buf;
3838 : /* Function return value. FIXME: Check if the second letter could
3839 : be something other than a space, for further optimization. */
3840 1939 : ADD_CHAR ('.');
3841 1939 : if (expr->rank == 0)
3842 : {
3843 238 : if (expr->ts.type == BT_CHARACTER)
3844 : {
3845 84 : ADD_CHAR ('w'); /* Address of character. */
3846 84 : ADD_CHAR ('.'); /* Length of character. */
3847 : }
3848 : }
3849 : else
3850 1701 : ADD_CHAR ('w'); /* Return value is a descriptor. */
3851 :
3852 1939 : num_char_args = 0;
3853 10224 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
3854 : {
3855 8285 : if (a->expr == NULL)
3856 2565 : continue;
3857 :
3858 5720 : if (a->name && strcmp (a->name,"%VAL") == 0)
3859 1300 : ADD_CHAR ('.');
3860 : else
3861 : {
3862 4420 : if (a->expr->rank > 0)
3863 2575 : ADD_CHAR ('r');
3864 : else
3865 1845 : ADD_CHAR ('R');
3866 : }
3867 5720 : num_char_args += a->expr->ts.type == BT_CHARACTER;
3868 5720 : gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
3869 : }
3870 :
3871 2743 : for (i = 0; i < num_char_args; i++)
3872 804 : ADD_CHAR ('.');
3873 :
3874 1939 : *fp = '\0';
3875 1939 : return fnspec_buf;
3876 : }
3877 :
3878 : #undef MAX_SPEC_ARG
3879 : #undef ADD_CHAR
3880 :
3881 : /* Generate the right symbol for the specific intrinsic function and
3882 : modify the expr accordingly. This assumes that absent optional
3883 : arguments should be removed. */
3884 :
3885 : gfc_symbol *
3886 8277 : specific_intrinsic_symbol (gfc_expr *expr)
3887 : {
3888 8277 : gfc_symbol *sym;
3889 :
3890 8277 : sym = gfc_find_intrinsic_symbol (expr);
3891 8277 : if (sym == NULL)
3892 : {
3893 1939 : sym = gfc_get_intrinsic_function_symbol (expr);
3894 1939 : sym->ts = expr->ts;
3895 1939 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
3896 240 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
3897 :
3898 1939 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3899 : expr->value.function.actual, true);
3900 1939 : sym->backend_decl
3901 1939 : = gfc_get_extern_function_decl (sym, expr->value.function.actual,
3902 1939 : intrinsic_fnspec (expr));
3903 : }
3904 :
3905 8277 : remove_empty_actual_arguments (&(expr->value.function.actual));
3906 :
3907 8277 : return sym;
3908 : }
3909 :
3910 : /* Generate a call to an external intrinsic function. FIXME: So far,
3911 : this only works for functions which are called with well-defined
3912 : types; CSHIFT and friends will come later. */
3913 :
3914 : static void
3915 13716 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3916 : {
3917 13716 : gfc_symbol *sym;
3918 13716 : vec<tree, va_gc> *append_args;
3919 13716 : bool specific_symbol;
3920 :
3921 13716 : gcc_assert (!se->ss || se->ss->info->expr == expr);
3922 :
3923 13716 : if (se->ss)
3924 11762 : gcc_assert (expr->rank > 0);
3925 : else
3926 1954 : gcc_assert (expr->rank == 0);
3927 :
3928 13716 : switch (expr->value.function.isym->id)
3929 : {
3930 : case GFC_ISYM_ANY:
3931 : case GFC_ISYM_ALL:
3932 : case GFC_ISYM_FINDLOC:
3933 : case GFC_ISYM_MAXLOC:
3934 : case GFC_ISYM_MINLOC:
3935 : case GFC_ISYM_MAXVAL:
3936 : case GFC_ISYM_MINVAL:
3937 : case GFC_ISYM_NORM2:
3938 : case GFC_ISYM_PRODUCT:
3939 : case GFC_ISYM_SUM:
3940 : specific_symbol = true;
3941 : break;
3942 5439 : default:
3943 5439 : specific_symbol = false;
3944 : }
3945 :
3946 13716 : if (specific_symbol)
3947 : {
3948 : /* Need to copy here because specific_intrinsic_symbol modifies
3949 : expr to omit the absent optional arguments. */
3950 8277 : expr = gfc_copy_expr (expr);
3951 8277 : sym = specific_intrinsic_symbol (expr);
3952 : }
3953 : else
3954 5439 : sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
3955 :
3956 : /* Calls to libgfortran_matmul need to be appended special arguments,
3957 : to be able to call the BLAS ?gemm functions if required and possible. */
3958 13716 : append_args = NULL;
3959 13716 : if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3960 865 : && !expr->external_blas
3961 827 : && sym->ts.type != BT_LOGICAL)
3962 : {
3963 811 : tree cint = gfc_get_int_type (gfc_c_int_kind);
3964 :
3965 811 : if (flag_external_blas
3966 0 : && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3967 0 : && (sym->ts.kind == 4 || sym->ts.kind == 8))
3968 : {
3969 0 : tree gemm_fndecl;
3970 :
3971 0 : if (sym->ts.type == BT_REAL)
3972 : {
3973 0 : if (sym->ts.kind == 4)
3974 0 : gemm_fndecl = gfor_fndecl_sgemm;
3975 : else
3976 0 : gemm_fndecl = gfor_fndecl_dgemm;
3977 : }
3978 : else
3979 : {
3980 0 : if (sym->ts.kind == 4)
3981 0 : gemm_fndecl = gfor_fndecl_cgemm;
3982 : else
3983 0 : gemm_fndecl = gfor_fndecl_zgemm;
3984 : }
3985 :
3986 0 : vec_alloc (append_args, 3);
3987 0 : append_args->quick_push (build_int_cst (cint, 1));
3988 0 : append_args->quick_push (build_int_cst (cint,
3989 0 : flag_blas_matmul_limit));
3990 0 : append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
3991 : gemm_fndecl));
3992 0 : }
3993 : else
3994 : {
3995 811 : vec_alloc (append_args, 3);
3996 811 : append_args->quick_push (build_int_cst (cint, 0));
3997 811 : append_args->quick_push (build_int_cst (cint, 0));
3998 811 : append_args->quick_push (null_pointer_node);
3999 : }
4000 : }
4001 : /* Non-character scalar reduce returns a pointer to a result of size set by
4002 : the element size of 'array'. Setting 'sym' allocatable ensures that the
4003 : result is deallocated at the appropriate time. */
4004 12905 : else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
4005 102 : && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
4006 96 : sym->attr.allocatable = 1;
4007 :
4008 :
4009 13716 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4010 : append_args);
4011 :
4012 13716 : if (specific_symbol)
4013 8277 : gfc_free_expr (expr);
4014 : else
4015 5439 : gfc_free_symbol (sym);
4016 13716 : }
4017 :
4018 : /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4019 : Implemented as
4020 : any(a)
4021 : {
4022 : forall (i=...)
4023 : if (a[i] != 0)
4024 : return 1
4025 : end forall
4026 : return 0
4027 : }
4028 : all(a)
4029 : {
4030 : forall (i=...)
4031 : if (a[i] == 0)
4032 : return 0
4033 : end forall
4034 : return 1
4035 : }
4036 : */
4037 : static void
4038 38329 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4039 : {
4040 38329 : tree resvar;
4041 38329 : stmtblock_t block;
4042 38329 : stmtblock_t body;
4043 38329 : tree type;
4044 38329 : tree tmp;
4045 38329 : tree found;
4046 38329 : gfc_loopinfo loop;
4047 38329 : gfc_actual_arglist *actual;
4048 38329 : gfc_ss *arrayss;
4049 38329 : gfc_se arrayse;
4050 38329 : tree exit_label;
4051 :
4052 38329 : if (se->ss)
4053 : {
4054 0 : gfc_conv_intrinsic_funcall (se, expr);
4055 0 : return;
4056 : }
4057 :
4058 38329 : actual = expr->value.function.actual;
4059 38329 : type = gfc_typenode_for_spec (&expr->ts);
4060 : /* Initialize the result. */
4061 38329 : resvar = gfc_create_var (type, "test");
4062 38329 : if (op == EQ_EXPR)
4063 420 : tmp = convert (type, boolean_true_node);
4064 : else
4065 37909 : tmp = convert (type, boolean_false_node);
4066 38329 : gfc_add_modify (&se->pre, resvar, tmp);
4067 :
4068 : /* Walk the arguments. */
4069 38329 : arrayss = gfc_walk_expr (actual->expr);
4070 38329 : gcc_assert (arrayss != gfc_ss_terminator);
4071 :
4072 : /* Initialize the scalarizer. */
4073 38329 : gfc_init_loopinfo (&loop);
4074 38329 : exit_label = gfc_build_label_decl (NULL_TREE);
4075 38329 : TREE_USED (exit_label) = 1;
4076 38329 : gfc_add_ss_to_loop (&loop, arrayss);
4077 :
4078 : /* Initialize the loop. */
4079 38329 : gfc_conv_ss_startstride (&loop);
4080 38329 : gfc_conv_loop_setup (&loop, &expr->where);
4081 :
4082 38329 : gfc_mark_ss_chain_used (arrayss, 1);
4083 : /* Generate the loop body. */
4084 38329 : gfc_start_scalarized_body (&loop, &body);
4085 :
4086 : /* If the condition matches then set the return value. */
4087 38329 : gfc_start_block (&block);
4088 38329 : if (op == EQ_EXPR)
4089 420 : tmp = convert (type, boolean_false_node);
4090 : else
4091 37909 : tmp = convert (type, boolean_true_node);
4092 38329 : gfc_add_modify (&block, resvar, tmp);
4093 :
4094 : /* And break out of the loop. */
4095 38329 : tmp = build1_v (GOTO_EXPR, exit_label);
4096 38329 : gfc_add_expr_to_block (&block, tmp);
4097 :
4098 38329 : found = gfc_finish_block (&block);
4099 :
4100 : /* Check this element. */
4101 38329 : gfc_init_se (&arrayse, NULL);
4102 38329 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4103 38329 : arrayse.ss = arrayss;
4104 38329 : gfc_conv_expr_val (&arrayse, actual->expr);
4105 :
4106 38329 : gfc_add_block_to_block (&body, &arrayse.pre);
4107 38329 : tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4108 38329 : build_int_cst (TREE_TYPE (arrayse.expr), 0));
4109 38329 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4110 38329 : gfc_add_expr_to_block (&body, tmp);
4111 38329 : gfc_add_block_to_block (&body, &arrayse.post);
4112 :
4113 38329 : gfc_trans_scalarizing_loops (&loop, &body);
4114 :
4115 : /* Add the exit label. */
4116 38329 : tmp = build1_v (LABEL_EXPR, exit_label);
4117 38329 : gfc_add_expr_to_block (&loop.pre, tmp);
4118 :
4119 38329 : gfc_add_block_to_block (&se->pre, &loop.pre);
4120 38329 : gfc_add_block_to_block (&se->pre, &loop.post);
4121 38329 : gfc_cleanup_loop (&loop);
4122 :
4123 38329 : se->expr = resvar;
4124 : }
4125 :
4126 :
4127 : /* Generate the constant 180 / pi, which is used in the conversion
4128 : of acosd(), asind(), atand(), atan2d(). */
4129 :
4130 : static tree
4131 336 : rad2deg (int kind)
4132 : {
4133 336 : tree retval;
4134 336 : mpfr_t pi, t0;
4135 :
4136 336 : gfc_set_model_kind (kind);
4137 336 : mpfr_init (pi);
4138 336 : mpfr_init (t0);
4139 336 : mpfr_set_si (t0, 180, GFC_RND_MODE);
4140 336 : mpfr_const_pi (pi, GFC_RND_MODE);
4141 336 : mpfr_div (t0, t0, pi, GFC_RND_MODE);
4142 336 : retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4143 336 : mpfr_clear (t0);
4144 336 : mpfr_clear (pi);
4145 336 : return retval;
4146 : }
4147 :
4148 :
4149 : static gfc_intrinsic_map_t *
4150 546 : gfc_lookup_intrinsic (gfc_isym_id id)
4151 : {
4152 546 : gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4153 11154 : for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4154 11154 : if (id == m->id)
4155 : break;
4156 546 : gcc_assert (id == m->id);
4157 546 : return m;
4158 : }
4159 :
4160 :
4161 : /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4162 : ASIND(x) is translated into ASIN(x) * 180 / pi.
4163 : ATAND(x) is translated into ATAN(x) * 180 / pi. */
4164 :
4165 : static void
4166 216 : gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4167 : {
4168 216 : tree arg;
4169 216 : tree atrigd;
4170 216 : tree type;
4171 216 : gfc_intrinsic_map_t *m;
4172 :
4173 216 : type = gfc_typenode_for_spec (&expr->ts);
4174 :
4175 216 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4176 :
4177 216 : switch (id)
4178 : {
4179 72 : case GFC_ISYM_ACOSD:
4180 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
4181 72 : break;
4182 72 : case GFC_ISYM_ASIND:
4183 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
4184 72 : break;
4185 72 : case GFC_ISYM_ATAND:
4186 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
4187 72 : break;
4188 0 : default:
4189 0 : gcc_unreachable ();
4190 : }
4191 216 : atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4192 216 : atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4193 :
4194 216 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4195 : fold_convert (type, rad2deg (expr->ts.kind)));
4196 216 : }
4197 :
4198 :
4199 : /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4200 : COS(X) / SIN(X) for COMPLEX argument. */
4201 :
4202 : static void
4203 102 : gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4204 : {
4205 102 : gfc_intrinsic_map_t *m;
4206 102 : tree arg;
4207 102 : tree type;
4208 :
4209 102 : type = gfc_typenode_for_spec (&expr->ts);
4210 102 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4211 :
4212 102 : if (expr->ts.type == BT_REAL)
4213 : {
4214 102 : tree tan;
4215 102 : tree tmp;
4216 102 : mpfr_t pio2;
4217 :
4218 : /* Create pi/2. */
4219 102 : gfc_set_model_kind (expr->ts.kind);
4220 102 : mpfr_init (pio2);
4221 102 : mpfr_const_pi (pio2, GFC_RND_MODE);
4222 102 : mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4223 102 : tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4224 102 : mpfr_clear (pio2);
4225 :
4226 : /* Find tan builtin function. */
4227 102 : m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
4228 102 : tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4229 102 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4230 102 : tan = build_call_expr_loc (input_location, tan, 1, tmp);
4231 102 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4232 : }
4233 : else
4234 : {
4235 0 : tree sin;
4236 0 : tree cos;
4237 :
4238 : /* Find cos builtin function. */
4239 0 : m = gfc_lookup_intrinsic (GFC_ISYM_COS);
4240 0 : cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4241 0 : cos = build_call_expr_loc (input_location, cos, 1, arg);
4242 :
4243 : /* Find sin builtin function. */
4244 0 : m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
4245 0 : sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4246 0 : sin = build_call_expr_loc (input_location, sin, 1, arg);
4247 :
4248 : /* Divide cos by sin. */
4249 0 : se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4250 : }
4251 102 : }
4252 :
4253 :
4254 : /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4255 :
4256 : static void
4257 108 : gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4258 : {
4259 108 : tree arg;
4260 108 : tree type;
4261 108 : tree ninety_tree;
4262 108 : mpfr_t ninety;
4263 :
4264 108 : type = gfc_typenode_for_spec (&expr->ts);
4265 108 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4266 :
4267 108 : gfc_set_model_kind (expr->ts.kind);
4268 :
4269 : /* Build the tree for x + 90. */
4270 108 : mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4271 108 : ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4272 108 : arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4273 108 : mpfr_clear (ninety);
4274 :
4275 : /* Find tand. */
4276 108 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
4277 108 : tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4278 108 : tand = build_call_expr_loc (input_location, tand, 1, arg);
4279 :
4280 108 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4281 108 : }
4282 :
4283 :
4284 : /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4285 :
4286 : static void
4287 120 : gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4288 : {
4289 120 : tree args[2];
4290 120 : tree atan2d;
4291 120 : tree type;
4292 :
4293 120 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
4294 120 : type = TREE_TYPE (args[0]);
4295 :
4296 120 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
4297 120 : atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4298 120 : atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4299 :
4300 120 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4301 : rad2deg (expr->ts.kind));
4302 120 : }
4303 :
4304 :
4305 : /* COUNT(A) = Number of true elements in A. */
4306 : static void
4307 143 : gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4308 : {
4309 143 : tree resvar;
4310 143 : tree type;
4311 143 : stmtblock_t body;
4312 143 : tree tmp;
4313 143 : gfc_loopinfo loop;
4314 143 : gfc_actual_arglist *actual;
4315 143 : gfc_ss *arrayss;
4316 143 : gfc_se arrayse;
4317 :
4318 143 : if (se->ss)
4319 : {
4320 0 : gfc_conv_intrinsic_funcall (se, expr);
4321 0 : return;
4322 : }
4323 :
4324 143 : actual = expr->value.function.actual;
4325 :
4326 143 : type = gfc_typenode_for_spec (&expr->ts);
4327 : /* Initialize the result. */
4328 143 : resvar = gfc_create_var (type, "count");
4329 143 : gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4330 :
4331 : /* Walk the arguments. */
4332 143 : arrayss = gfc_walk_expr (actual->expr);
4333 143 : gcc_assert (arrayss != gfc_ss_terminator);
4334 :
4335 : /* Initialize the scalarizer. */
4336 143 : gfc_init_loopinfo (&loop);
4337 143 : gfc_add_ss_to_loop (&loop, arrayss);
4338 :
4339 : /* Initialize the loop. */
4340 143 : gfc_conv_ss_startstride (&loop);
4341 143 : gfc_conv_loop_setup (&loop, &expr->where);
4342 :
4343 143 : gfc_mark_ss_chain_used (arrayss, 1);
4344 : /* Generate the loop body. */
4345 143 : gfc_start_scalarized_body (&loop, &body);
4346 :
4347 143 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4348 143 : resvar, build_int_cst (TREE_TYPE (resvar), 1));
4349 143 : tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4350 :
4351 143 : gfc_init_se (&arrayse, NULL);
4352 143 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4353 143 : arrayse.ss = arrayss;
4354 143 : gfc_conv_expr_val (&arrayse, actual->expr);
4355 143 : tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4356 : build_empty_stmt (input_location));
4357 :
4358 143 : gfc_add_block_to_block (&body, &arrayse.pre);
4359 143 : gfc_add_expr_to_block (&body, tmp);
4360 143 : gfc_add_block_to_block (&body, &arrayse.post);
4361 :
4362 143 : gfc_trans_scalarizing_loops (&loop, &body);
4363 :
4364 143 : gfc_add_block_to_block (&se->pre, &loop.pre);
4365 143 : gfc_add_block_to_block (&se->pre, &loop.post);
4366 143 : gfc_cleanup_loop (&loop);
4367 :
4368 143 : se->expr = resvar;
4369 : }
4370 :
4371 :
4372 : /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4373 : struct and return the corresponding loopinfo. */
4374 :
4375 : static gfc_loopinfo *
4376 3374 : enter_nested_loop (gfc_se *se)
4377 : {
4378 3374 : se->ss = se->ss->nested_ss;
4379 3374 : gcc_assert (se->ss == se->ss->loop->ss);
4380 :
4381 3374 : return se->ss->loop;
4382 : }
4383 :
4384 : /* Build the condition for a mask, which may be optional. */
4385 :
4386 : static tree
4387 12763 : conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4388 : bool optional_mask)
4389 : {
4390 12763 : tree present;
4391 12763 : tree type;
4392 :
4393 12763 : if (optional_mask)
4394 : {
4395 206 : type = TREE_TYPE (maskse->expr);
4396 206 : present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4397 206 : present = convert (type, present);
4398 206 : present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4399 : present);
4400 206 : return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4401 206 : type, present, maskse->expr);
4402 : }
4403 : else
4404 12557 : return maskse->expr;
4405 : }
4406 :
4407 : /* Inline implementation of the sum and product intrinsics. */
4408 : static void
4409 2513 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4410 : bool norm2)
4411 : {
4412 2513 : tree resvar;
4413 2513 : tree scale = NULL_TREE;
4414 2513 : tree type;
4415 2513 : stmtblock_t body;
4416 2513 : stmtblock_t block;
4417 2513 : tree tmp;
4418 2513 : gfc_loopinfo loop, *ploop;
4419 2513 : gfc_actual_arglist *arg_array, *arg_mask;
4420 2513 : gfc_ss *arrayss = NULL;
4421 2513 : gfc_ss *maskss = NULL;
4422 2513 : gfc_se arrayse;
4423 2513 : gfc_se maskse;
4424 2513 : gfc_se *parent_se;
4425 2513 : gfc_expr *arrayexpr;
4426 2513 : gfc_expr *maskexpr;
4427 2513 : bool optional_mask;
4428 :
4429 2513 : if (expr->rank > 0)
4430 : {
4431 578 : gcc_assert (gfc_inline_intrinsic_function_p (expr));
4432 : parent_se = se;
4433 : }
4434 : else
4435 : parent_se = NULL;
4436 :
4437 2513 : type = gfc_typenode_for_spec (&expr->ts);
4438 : /* Initialize the result. */
4439 2513 : resvar = gfc_create_var (type, "val");
4440 2513 : if (norm2)
4441 : {
4442 : /* result = 0.0;
4443 : scale = 1.0. */
4444 68 : scale = gfc_create_var (type, "scale");
4445 68 : gfc_add_modify (&se->pre, scale,
4446 : gfc_build_const (type, integer_one_node));
4447 68 : tmp = gfc_build_const (type, integer_zero_node);
4448 : }
4449 2445 : else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4450 2027 : tmp = gfc_build_const (type, integer_zero_node);
4451 418 : else if (op == NE_EXPR)
4452 : /* PARITY. */
4453 36 : tmp = convert (type, boolean_false_node);
4454 382 : else if (op == BIT_AND_EXPR)
4455 24 : tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4456 : type, integer_one_node));
4457 : else
4458 358 : tmp = gfc_build_const (type, integer_one_node);
4459 :
4460 2513 : gfc_add_modify (&se->pre, resvar, tmp);
4461 :
4462 2513 : arg_array = expr->value.function.actual;
4463 :
4464 2513 : arrayexpr = arg_array->expr;
4465 :
4466 2513 : if (op == NE_EXPR || norm2)
4467 : {
4468 : /* PARITY and NORM2. */
4469 : maskexpr = NULL;
4470 : optional_mask = false;
4471 : }
4472 : else
4473 : {
4474 2409 : arg_mask = arg_array->next->next;
4475 2409 : gcc_assert (arg_mask != NULL);
4476 2409 : maskexpr = arg_mask->expr;
4477 371 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4478 266 : && maskexpr->symtree->n.sym->attr.dummy
4479 2427 : && maskexpr->symtree->n.sym->attr.optional;
4480 : }
4481 :
4482 2513 : if (expr->rank == 0)
4483 : {
4484 : /* Walk the arguments. */
4485 1935 : arrayss = gfc_walk_expr (arrayexpr);
4486 1935 : gcc_assert (arrayss != gfc_ss_terminator);
4487 :
4488 1935 : if (maskexpr && maskexpr->rank > 0)
4489 : {
4490 223 : maskss = gfc_walk_expr (maskexpr);
4491 223 : gcc_assert (maskss != gfc_ss_terminator);
4492 : }
4493 : else
4494 : maskss = NULL;
4495 :
4496 : /* Initialize the scalarizer. */
4497 1935 : gfc_init_loopinfo (&loop);
4498 :
4499 : /* We add the mask first because the number of iterations is
4500 : taken from the last ss, and this breaks if an absent
4501 : optional argument is used for mask. */
4502 :
4503 1935 : if (maskexpr && maskexpr->rank > 0)
4504 223 : gfc_add_ss_to_loop (&loop, maskss);
4505 1935 : gfc_add_ss_to_loop (&loop, arrayss);
4506 :
4507 : /* Initialize the loop. */
4508 1935 : gfc_conv_ss_startstride (&loop);
4509 1935 : gfc_conv_loop_setup (&loop, &expr->where);
4510 :
4511 1935 : if (maskexpr && maskexpr->rank > 0)
4512 223 : gfc_mark_ss_chain_used (maskss, 1);
4513 1935 : gfc_mark_ss_chain_used (arrayss, 1);
4514 :
4515 1935 : ploop = &loop;
4516 : }
4517 : else
4518 : /* All the work has been done in the parent loops. */
4519 578 : ploop = enter_nested_loop (se);
4520 :
4521 2513 : gcc_assert (ploop);
4522 :
4523 : /* Generate the loop body. */
4524 2513 : gfc_start_scalarized_body (ploop, &body);
4525 :
4526 : /* If we have a mask, only add this element if the mask is set. */
4527 2513 : if (maskexpr && maskexpr->rank > 0)
4528 : {
4529 307 : gfc_init_se (&maskse, parent_se);
4530 307 : gfc_copy_loopinfo_to_se (&maskse, ploop);
4531 307 : if (expr->rank == 0)
4532 223 : maskse.ss = maskss;
4533 307 : gfc_conv_expr_val (&maskse, maskexpr);
4534 307 : gfc_add_block_to_block (&body, &maskse.pre);
4535 :
4536 307 : gfc_start_block (&block);
4537 : }
4538 : else
4539 2206 : gfc_init_block (&block);
4540 :
4541 : /* Do the actual summation/product. */
4542 2513 : gfc_init_se (&arrayse, parent_se);
4543 2513 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
4544 2513 : if (expr->rank == 0)
4545 1935 : arrayse.ss = arrayss;
4546 2513 : gfc_conv_expr_val (&arrayse, arrayexpr);
4547 2513 : gfc_add_block_to_block (&block, &arrayse.pre);
4548 :
4549 2513 : if (norm2)
4550 : {
4551 : /* if (x (i) != 0.0)
4552 : {
4553 : absX = abs(x(i))
4554 : if (absX > scale)
4555 : {
4556 : val = scale/absX;
4557 : result = 1.0 + result * val * val;
4558 : scale = absX;
4559 : }
4560 : else
4561 : {
4562 : val = absX/scale;
4563 : result += val * val;
4564 : }
4565 : } */
4566 68 : tree res1, res2, cond, absX, val;
4567 68 : stmtblock_t ifblock1, ifblock2, ifblock3;
4568 :
4569 68 : gfc_init_block (&ifblock1);
4570 :
4571 68 : absX = gfc_create_var (type, "absX");
4572 68 : gfc_add_modify (&ifblock1, absX,
4573 : fold_build1_loc (input_location, ABS_EXPR, type,
4574 : arrayse.expr));
4575 68 : val = gfc_create_var (type, "val");
4576 68 : gfc_add_expr_to_block (&ifblock1, val);
4577 :
4578 68 : gfc_init_block (&ifblock2);
4579 68 : gfc_add_modify (&ifblock2, val,
4580 : fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4581 : absX));
4582 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4583 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4584 68 : res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4585 : gfc_build_const (type, integer_one_node));
4586 68 : gfc_add_modify (&ifblock2, resvar, res1);
4587 68 : gfc_add_modify (&ifblock2, scale, absX);
4588 68 : res1 = gfc_finish_block (&ifblock2);
4589 :
4590 68 : gfc_init_block (&ifblock3);
4591 68 : gfc_add_modify (&ifblock3, val,
4592 : fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4593 : scale));
4594 68 : res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4595 68 : res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4596 68 : gfc_add_modify (&ifblock3, resvar, res2);
4597 68 : res2 = gfc_finish_block (&ifblock3);
4598 :
4599 68 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4600 : absX, scale);
4601 68 : tmp = build3_v (COND_EXPR, cond, res1, res2);
4602 68 : gfc_add_expr_to_block (&ifblock1, tmp);
4603 68 : tmp = gfc_finish_block (&ifblock1);
4604 :
4605 68 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4606 : arrayse.expr,
4607 : gfc_build_const (type, integer_zero_node));
4608 :
4609 68 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4610 68 : gfc_add_expr_to_block (&block, tmp);
4611 : }
4612 : else
4613 : {
4614 2445 : tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4615 2445 : gfc_add_modify (&block, resvar, tmp);
4616 : }
4617 :
4618 2513 : gfc_add_block_to_block (&block, &arrayse.post);
4619 :
4620 2513 : if (maskexpr && maskexpr->rank > 0)
4621 : {
4622 : /* We enclose the above in if (mask) {...} . If the mask is an
4623 : optional argument, generate
4624 : IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4625 307 : tree ifmask;
4626 307 : tmp = gfc_finish_block (&block);
4627 307 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4628 307 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4629 : build_empty_stmt (input_location));
4630 307 : }
4631 : else
4632 2206 : tmp = gfc_finish_block (&block);
4633 2513 : gfc_add_expr_to_block (&body, tmp);
4634 :
4635 2513 : gfc_trans_scalarizing_loops (ploop, &body);
4636 :
4637 : /* For a scalar mask, enclose the loop in an if statement. */
4638 2513 : if (maskexpr && maskexpr->rank == 0)
4639 : {
4640 64 : gfc_init_block (&block);
4641 64 : gfc_add_block_to_block (&block, &ploop->pre);
4642 64 : gfc_add_block_to_block (&block, &ploop->post);
4643 64 : tmp = gfc_finish_block (&block);
4644 :
4645 64 : if (expr->rank > 0)
4646 : {
4647 34 : tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4648 : build_empty_stmt (input_location));
4649 34 : gfc_advance_se_ss_chain (se);
4650 : }
4651 : else
4652 : {
4653 30 : tree ifmask;
4654 :
4655 30 : gcc_assert (expr->rank == 0);
4656 30 : gfc_init_se (&maskse, NULL);
4657 30 : gfc_conv_expr_val (&maskse, maskexpr);
4658 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4659 30 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4660 : build_empty_stmt (input_location));
4661 : }
4662 :
4663 64 : gfc_add_expr_to_block (&block, tmp);
4664 64 : gfc_add_block_to_block (&se->pre, &block);
4665 64 : gcc_assert (se->post.head == NULL);
4666 : }
4667 : else
4668 : {
4669 2449 : gfc_add_block_to_block (&se->pre, &ploop->pre);
4670 2449 : gfc_add_block_to_block (&se->pre, &ploop->post);
4671 : }
4672 :
4673 2513 : if (expr->rank == 0)
4674 1935 : gfc_cleanup_loop (ploop);
4675 :
4676 2513 : if (norm2)
4677 : {
4678 : /* result = scale * sqrt(result). */
4679 68 : tree sqrt;
4680 68 : sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4681 68 : resvar = build_call_expr_loc (input_location,
4682 : sqrt, 1, resvar);
4683 68 : resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4684 : }
4685 :
4686 2513 : se->expr = resvar;
4687 2513 : }
4688 :
4689 :
4690 : /* Inline implementation of the dot_product intrinsic. This function
4691 : is based on gfc_conv_intrinsic_arith (the previous function). */
4692 : static void
4693 113 : gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4694 : {
4695 113 : tree resvar;
4696 113 : tree type;
4697 113 : stmtblock_t body;
4698 113 : stmtblock_t block;
4699 113 : tree tmp;
4700 113 : gfc_loopinfo loop;
4701 113 : gfc_actual_arglist *actual;
4702 113 : gfc_ss *arrayss1, *arrayss2;
4703 113 : gfc_se arrayse1, arrayse2;
4704 113 : gfc_expr *arrayexpr1, *arrayexpr2;
4705 :
4706 113 : type = gfc_typenode_for_spec (&expr->ts);
4707 :
4708 : /* Initialize the result. */
4709 113 : resvar = gfc_create_var (type, "val");
4710 113 : if (expr->ts.type == BT_LOGICAL)
4711 30 : tmp = build_int_cst (type, 0);
4712 : else
4713 83 : tmp = gfc_build_const (type, integer_zero_node);
4714 :
4715 113 : gfc_add_modify (&se->pre, resvar, tmp);
4716 :
4717 : /* Walk argument #1. */
4718 113 : actual = expr->value.function.actual;
4719 113 : arrayexpr1 = actual->expr;
4720 113 : arrayss1 = gfc_walk_expr (arrayexpr1);
4721 113 : gcc_assert (arrayss1 != gfc_ss_terminator);
4722 :
4723 : /* Walk argument #2. */
4724 113 : actual = actual->next;
4725 113 : arrayexpr2 = actual->expr;
4726 113 : arrayss2 = gfc_walk_expr (arrayexpr2);
4727 113 : gcc_assert (arrayss2 != gfc_ss_terminator);
4728 :
4729 : /* Initialize the scalarizer. */
4730 113 : gfc_init_loopinfo (&loop);
4731 113 : gfc_add_ss_to_loop (&loop, arrayss1);
4732 113 : gfc_add_ss_to_loop (&loop, arrayss2);
4733 :
4734 : /* Initialize the loop. */
4735 113 : gfc_conv_ss_startstride (&loop);
4736 113 : gfc_conv_loop_setup (&loop, &expr->where);
4737 :
4738 113 : gfc_mark_ss_chain_used (arrayss1, 1);
4739 113 : gfc_mark_ss_chain_used (arrayss2, 1);
4740 :
4741 : /* Generate the loop body. */
4742 113 : gfc_start_scalarized_body (&loop, &body);
4743 113 : gfc_init_block (&block);
4744 :
4745 : /* Make the tree expression for [conjg(]array1[)]. */
4746 113 : gfc_init_se (&arrayse1, NULL);
4747 113 : gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4748 113 : arrayse1.ss = arrayss1;
4749 113 : gfc_conv_expr_val (&arrayse1, arrayexpr1);
4750 113 : if (expr->ts.type == BT_COMPLEX)
4751 9 : arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4752 : arrayse1.expr);
4753 113 : gfc_add_block_to_block (&block, &arrayse1.pre);
4754 :
4755 : /* Make the tree expression for array2. */
4756 113 : gfc_init_se (&arrayse2, NULL);
4757 113 : gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4758 113 : arrayse2.ss = arrayss2;
4759 113 : gfc_conv_expr_val (&arrayse2, arrayexpr2);
4760 113 : gfc_add_block_to_block (&block, &arrayse2.pre);
4761 :
4762 : /* Do the actual product and sum. */
4763 113 : if (expr->ts.type == BT_LOGICAL)
4764 : {
4765 30 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4766 : arrayse1.expr, arrayse2.expr);
4767 30 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4768 : }
4769 : else
4770 : {
4771 83 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4772 : arrayse2.expr);
4773 83 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4774 : }
4775 113 : gfc_add_modify (&block, resvar, tmp);
4776 :
4777 : /* Finish up the loop block and the loop. */
4778 113 : tmp = gfc_finish_block (&block);
4779 113 : gfc_add_expr_to_block (&body, tmp);
4780 :
4781 113 : gfc_trans_scalarizing_loops (&loop, &body);
4782 113 : gfc_add_block_to_block (&se->pre, &loop.pre);
4783 113 : gfc_add_block_to_block (&se->pre, &loop.post);
4784 113 : gfc_cleanup_loop (&loop);
4785 :
4786 113 : se->expr = resvar;
4787 113 : }
4788 :
4789 :
4790 : /* Tells whether the expression E is a reference to an optional variable whose
4791 : presence is not known at compile time. Those are variable references without
4792 : subreference; if there is a subreference, we can assume the variable is
4793 : present. We have to special case full arrays, which we represent with a fake
4794 : "full" reference, and class descriptors for which a reference to data is not
4795 : really a subreference. */
4796 :
4797 : bool
4798 14613 : maybe_absent_optional_variable (gfc_expr *e)
4799 : {
4800 14613 : if (!(e && e->expr_type == EXPR_VARIABLE))
4801 : return false;
4802 :
4803 1716 : gfc_symbol *sym = e->symtree->n.sym;
4804 1716 : if (!sym->attr.optional)
4805 : return false;
4806 :
4807 224 : gfc_ref *ref = e->ref;
4808 224 : if (ref == nullptr)
4809 : return true;
4810 :
4811 20 : if (ref->type == REF_ARRAY
4812 20 : && ref->u.ar.type == AR_FULL
4813 20 : && ref->next == nullptr)
4814 : return true;
4815 :
4816 0 : if (!(sym->ts.type == BT_CLASS
4817 0 : && ref->type == REF_COMPONENT
4818 0 : && ref->u.c.component == CLASS_DATA (sym)))
4819 : return false;
4820 :
4821 0 : gfc_ref *next_ref = ref->next;
4822 0 : if (next_ref == nullptr)
4823 : return true;
4824 :
4825 0 : if (next_ref->type == REF_ARRAY
4826 0 : && next_ref->u.ar.type == AR_FULL
4827 0 : && next_ref->next == nullptr)
4828 0 : return true;
4829 :
4830 : return false;
4831 : }
4832 :
4833 :
4834 : /* Emit code for minloc or maxloc intrinsic. There are many different cases
4835 : we need to handle. For performance reasons we sometimes create two
4836 : loops instead of one, where the second one is much simpler.
4837 : Examples for minloc intrinsic:
4838 : A: Result is scalar.
4839 : 1) Array mask is used and NaNs need to be supported:
4840 : limit = Infinity;
4841 : pos = 0;
4842 : S = from;
4843 : while (S <= to) {
4844 : if (mask[S]) {
4845 : if (pos == 0) pos = S + (1 - from);
4846 : if (a[S] <= limit) {
4847 : limit = a[S];
4848 : pos = S + (1 - from);
4849 : goto lab1;
4850 : }
4851 : }
4852 : S++;
4853 : }
4854 : goto lab2;
4855 : lab1:;
4856 : while (S <= to) {
4857 : if (mask[S])
4858 : if (a[S] < limit) {
4859 : limit = a[S];
4860 : pos = S + (1 - from);
4861 : }
4862 : S++;
4863 : }
4864 : lab2:;
4865 : 2) NaNs need to be supported, but it is known at compile time or cheaply
4866 : at runtime whether array is nonempty or not:
4867 : limit = Infinity;
4868 : pos = 0;
4869 : S = from;
4870 : while (S <= to) {
4871 : if (a[S] <= limit) {
4872 : limit = a[S];
4873 : pos = S + (1 - from);
4874 : goto lab1;
4875 : }
4876 : S++;
4877 : }
4878 : if (from <= to) pos = 1;
4879 : goto lab2;
4880 : lab1:;
4881 : while (S <= to) {
4882 : if (a[S] < limit) {
4883 : limit = a[S];
4884 : pos = S + (1 - from);
4885 : }
4886 : S++;
4887 : }
4888 : lab2:;
4889 : 3) NaNs aren't supported, array mask is used:
4890 : limit = infinities_supported ? Infinity : huge (limit);
4891 : pos = 0;
4892 : S = from;
4893 : while (S <= to) {
4894 : if (mask[S]) {
4895 : limit = a[S];
4896 : pos = S + (1 - from);
4897 : goto lab1;
4898 : }
4899 : S++;
4900 : }
4901 : goto lab2;
4902 : lab1:;
4903 : while (S <= to) {
4904 : if (mask[S])
4905 : if (a[S] < limit) {
4906 : limit = a[S];
4907 : pos = S + (1 - from);
4908 : }
4909 : S++;
4910 : }
4911 : lab2:;
4912 : 4) Same without array mask:
4913 : limit = infinities_supported ? Infinity : huge (limit);
4914 : pos = (from <= to) ? 1 : 0;
4915 : S = from;
4916 : while (S <= to) {
4917 : if (a[S] < limit) {
4918 : limit = a[S];
4919 : pos = S + (1 - from);
4920 : }
4921 : S++;
4922 : }
4923 : B: Array result, non-CHARACTER type, DIM absent
4924 : Generate similar code as in the scalar case, using a collection of
4925 : variables (one per dimension) instead of a single variable as result.
4926 : Picking only cases 1) and 4) with ARRAY of rank 2, the generated code
4927 : becomes:
4928 : 1) Array mask is used and NaNs need to be supported:
4929 : limit = Infinity;
4930 : pos0 = 0;
4931 : pos1 = 0;
4932 : S1 = from1;
4933 : second_loop_entry = false;
4934 : while (S1 <= to1) {
4935 : S0 = from0;
4936 : while (s0 <= to0 {
4937 : if (mask[S1][S0]) {
4938 : if (pos0 == 0) {
4939 : pos0 = S0 + (1 - from0);
4940 : pos1 = S1 + (1 - from1);
4941 : }
4942 : if (a[S1][S0] <= limit) {
4943 : limit = a[S1][S0];
4944 : pos0 = S0 + (1 - from0);
4945 : pos1 = S1 + (1 - from1);
4946 : second_loop_entry = true;
4947 : goto lab1;
4948 : }
4949 : }
4950 : S0++;
4951 : }
4952 : S1++;
4953 : }
4954 : goto lab2;
4955 : lab1:;
4956 : S1 = second_loop_entry ? S1 : from1;
4957 : while (S1 <= to1) {
4958 : S0 = second_loop_entry ? S0 : from0;
4959 : while (S0 <= to0) {
4960 : if (mask[S1][S0])
4961 : if (a[S1][S0] < limit) {
4962 : limit = a[S1][S0];
4963 : pos0 = S + (1 - from0);
4964 : pos1 = S + (1 - from1);
4965 : }
4966 : second_loop_entry = false;
4967 : S0++;
4968 : }
4969 : S1++;
4970 : }
4971 : lab2:;
4972 : result = { pos0, pos1 };
4973 : ...
4974 : 4) NANs aren't supported, no array mask.
4975 : limit = infinities_supported ? Infinity : huge (limit);
4976 : pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4977 : pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4978 : S1 = from1;
4979 : while (S1 <= to1) {
4980 : S0 = from0;
4981 : while (S0 <= to0) {
4982 : if (a[S1][S0] < limit) {
4983 : limit = a[S1][S0];
4984 : pos0 = S + (1 - from0);
4985 : pos1 = S + (1 - from1);
4986 : }
4987 : S0++;
4988 : }
4989 : S1++;
4990 : }
4991 : result = { pos0, pos1 };
4992 : C: Otherwise, a call is generated.
4993 : For 2) and 4), if mask is scalar, this all goes into a conditional,
4994 : setting pos = 0; in the else branch.
4995 :
4996 : Since we now also support the BACK argument, instead of using
4997 : if (a[S] < limit), we now use
4998 :
4999 : if (back)
5000 : cond = a[S] <= limit;
5001 : else
5002 : cond = a[S] < limit;
5003 : if (cond) {
5004 : ....
5005 :
5006 : The optimizer is smart enough to move the condition out of the loop.
5007 : They are now marked as unlikely too for further speedup. */
5008 :
5009 : static void
5010 18898 : gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5011 : {
5012 18898 : stmtblock_t body;
5013 18898 : stmtblock_t block;
5014 18898 : stmtblock_t ifblock;
5015 18898 : stmtblock_t elseblock;
5016 18898 : tree limit;
5017 18898 : tree type;
5018 18898 : tree tmp;
5019 18898 : tree cond;
5020 18898 : tree elsetmp;
5021 18898 : tree ifbody;
5022 18898 : tree offset[GFC_MAX_DIMENSIONS];
5023 18898 : tree nonempty;
5024 18898 : tree lab1, lab2;
5025 18898 : tree b_if, b_else;
5026 18898 : tree back;
5027 18898 : gfc_loopinfo loop, *ploop;
5028 18898 : gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg;
5029 18898 : gfc_actual_arglist *back_arg;
5030 18898 : gfc_ss *arrayss = nullptr;
5031 18898 : gfc_ss *maskss = nullptr;
5032 18898 : gfc_ss *orig_ss = nullptr;
5033 18898 : gfc_se arrayse;
5034 18898 : gfc_se maskse;
5035 18898 : gfc_se nested_se;
5036 18898 : gfc_se *base_se;
5037 18898 : gfc_expr *arrayexpr;
5038 18898 : gfc_expr *maskexpr;
5039 18898 : gfc_expr *backexpr;
5040 18898 : gfc_se backse;
5041 18898 : tree pos[GFC_MAX_DIMENSIONS];
5042 18898 : tree idx[GFC_MAX_DIMENSIONS];
5043 18898 : tree result_var = NULL_TREE;
5044 18898 : int n;
5045 18898 : bool optional_mask;
5046 :
5047 18898 : array_arg = expr->value.function.actual;
5048 18898 : dim_arg = array_arg->next;
5049 18898 : mask_arg = dim_arg->next;
5050 18898 : kind_arg = mask_arg->next;
5051 18898 : back_arg = kind_arg->next;
5052 :
5053 18898 : bool dim_present = dim_arg->expr != nullptr;
5054 18898 : bool nested_loop = dim_present && expr->rank > 0;
5055 :
5056 : /* Remove kind. */
5057 18898 : if (kind_arg->expr)
5058 : {
5059 2240 : gfc_free_expr (kind_arg->expr);
5060 2240 : kind_arg->expr = NULL;
5061 : }
5062 :
5063 : /* Pass BACK argument by value. */
5064 18898 : back_arg->name = "%VAL";
5065 :
5066 18898 : if (se->ss)
5067 : {
5068 14732 : if (se->ss->info->useflags)
5069 : {
5070 7671 : if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
5071 : {
5072 : /* The code generating and initializing the result array has been
5073 : generated already before the scalarization loop, either with a
5074 : library function call or with inline code; now we can just use
5075 : the result. */
5076 4875 : gfc_conv_tmp_array_ref (se);
5077 13822 : return;
5078 : }
5079 : }
5080 7061 : else if (!gfc_inline_intrinsic_function_p (expr))
5081 : {
5082 3780 : gfc_conv_intrinsic_funcall (se, expr);
5083 3780 : return;
5084 : }
5085 : }
5086 :
5087 10243 : arrayexpr = array_arg->expr;
5088 :
5089 : /* Special case for character maxloc. Remove unneeded "dim" actual
5090 : argument, then call a library function. */
5091 :
5092 10243 : if (arrayexpr->ts.type == BT_CHARACTER)
5093 : {
5094 292 : gcc_assert (expr->rank == 0);
5095 :
5096 292 : if (dim_arg->expr)
5097 : {
5098 292 : gfc_free_expr (dim_arg->expr);
5099 292 : dim_arg->expr = NULL;
5100 : }
5101 292 : gfc_conv_intrinsic_funcall (se, expr);
5102 292 : return;
5103 : }
5104 :
5105 9951 : type = gfc_typenode_for_spec (&expr->ts);
5106 :
5107 9951 : if (expr->rank > 0 && !dim_present)
5108 : {
5109 3281 : gfc_array_spec as;
5110 3281 : memset (&as, 0, sizeof (as));
5111 :
5112 3281 : as.rank = 1;
5113 3281 : as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5114 : &arrayexpr->where,
5115 : HOST_WIDE_INT_1);
5116 6562 : as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind,
5117 : &arrayexpr->where,
5118 3281 : arrayexpr->rank);
5119 :
5120 3281 : tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
5121 :
5122 3281 : result_var = gfc_create_var (array, "loc_result");
5123 : }
5124 :
5125 7155 : const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
5126 :
5127 : /* Initialize the result. */
5128 22177 : for (int i = 0; i < reduction_dimensions; i++)
5129 : {
5130 12226 : pos[i] = gfc_create_var (gfc_array_index_type,
5131 : gfc_get_string ("pos%d", i));
5132 12226 : offset[i] = gfc_create_var (gfc_array_index_type,
5133 : gfc_get_string ("offset%d", i));
5134 12226 : idx[i] = gfc_create_var (gfc_array_index_type,
5135 : gfc_get_string ("idx%d", i));
5136 : }
5137 :
5138 9951 : maskexpr = mask_arg->expr;
5139 6518 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5140 5329 : && maskexpr->symtree->n.sym->attr.dummy
5141 10116 : && maskexpr->symtree->n.sym->attr.optional;
5142 9951 : backexpr = back_arg->expr;
5143 :
5144 17106 : gfc_init_se (&backse, nested_loop ? se : nullptr);
5145 9951 : if (backexpr == nullptr)
5146 0 : back = logical_false_node;
5147 9951 : else if (maybe_absent_optional_variable (backexpr))
5148 : {
5149 : /* This should have been checked already by
5150 : maybe_absent_optional_variable. */
5151 184 : gcc_checking_assert (backexpr->expr_type == EXPR_VARIABLE);
5152 :
5153 184 : gfc_conv_expr (&backse, backexpr);
5154 184 : tree present = gfc_conv_expr_present (backexpr->symtree->n.sym, false);
5155 184 : back = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5156 : logical_type_node, present, backse.expr);
5157 : }
5158 : else
5159 : {
5160 9767 : gfc_conv_expr (&backse, backexpr);
5161 9767 : back = backse.expr;
5162 : }
5163 9951 : gfc_add_block_to_block (&se->pre, &backse.pre);
5164 9951 : back = gfc_evaluate_now_loc (input_location, back, &se->pre);
5165 9951 : gfc_add_block_to_block (&se->pre, &backse.post);
5166 :
5167 9951 : if (nested_loop)
5168 : {
5169 2796 : gfc_init_se (&nested_se, se);
5170 2796 : base_se = &nested_se;
5171 : }
5172 : else
5173 : {
5174 : /* Walk the arguments. */
5175 7155 : arrayss = gfc_walk_expr (arrayexpr);
5176 7155 : gcc_assert (arrayss != gfc_ss_terminator);
5177 :
5178 7155 : if (maskexpr && maskexpr->rank != 0)
5179 : {
5180 2700 : maskss = gfc_walk_expr (maskexpr);
5181 2700 : gcc_assert (maskss != gfc_ss_terminator);
5182 : }
5183 :
5184 : base_se = nullptr;
5185 : }
5186 :
5187 18091 : nonempty = nullptr;
5188 7448 : if (!(maskexpr && maskexpr->rank > 0))
5189 : {
5190 6077 : mpz_t asize;
5191 6077 : bool reduction_size_known;
5192 :
5193 6077 : if (dim_present)
5194 : {
5195 4032 : int reduction_dim;
5196 4032 : if (dim_arg->expr->expr_type == EXPR_CONSTANT)
5197 4030 : reduction_dim = mpz_get_si (dim_arg->expr->value.integer) - 1;
5198 2 : else if (arrayexpr->rank == 1)
5199 : reduction_dim = 0;
5200 : else
5201 0 : gcc_unreachable ();
5202 4032 : reduction_size_known = gfc_array_dimen_size (arrayexpr, reduction_dim,
5203 : &asize);
5204 : }
5205 : else
5206 2045 : reduction_size_known = gfc_array_size (arrayexpr, &asize);
5207 :
5208 6077 : if (reduction_size_known)
5209 : {
5210 4482 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5211 4482 : mpz_clear (asize);
5212 4482 : nonempty = fold_build2_loc (input_location, GT_EXPR,
5213 : logical_type_node, nonempty,
5214 : gfc_index_zero_node);
5215 : }
5216 6077 : maskss = NULL;
5217 : }
5218 :
5219 9951 : limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5220 9951 : switch (arrayexpr->ts.type)
5221 : {
5222 3898 : case BT_REAL:
5223 3898 : tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5224 3898 : break;
5225 :
5226 6029 : case BT_INTEGER:
5227 6029 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5228 6029 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5229 : arrayexpr->ts.kind);
5230 6029 : break;
5231 :
5232 24 : case BT_UNSIGNED:
5233 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
5234 24 : if (op == GT_EXPR)
5235 : {
5236 12 : tmp = gfc_get_unsigned_type (arrayexpr->ts.kind);
5237 12 : tmp = build_int_cst (tmp, 0);
5238 : }
5239 : else
5240 : {
5241 12 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5242 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
5243 : expr->ts.kind);
5244 : }
5245 : break;
5246 :
5247 0 : default:
5248 0 : gcc_unreachable ();
5249 : }
5250 :
5251 : /* We start with the most negative possible value for MAXLOC, and the most
5252 : positive possible value for MINLOC. The most negative possible value is
5253 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5254 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
5255 : with above. */
5256 9951 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
5257 4724 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5258 4724 : if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5259 2914 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5260 2914 : build_int_cst (TREE_TYPE (tmp), 1));
5261 :
5262 9951 : gfc_add_modify (&se->pre, limit, tmp);
5263 :
5264 : /* If we are in a case where we generate two sets of loops, the second one
5265 : should continue where the first stopped instead of restarting from the
5266 : beginning. So nested loops in the second set should have a partial range
5267 : on the first iteration, but they should start from the beginning and span
5268 : their full range on the following iterations. So we use conditionals in
5269 : the loops lower bounds, and use the following variable in those
5270 : conditionals to decide whether to use the original loop bound or to use
5271 : the index at which the loop from the first set stopped. */
5272 9951 : tree second_loop_entry = gfc_create_var (logical_type_node,
5273 : "second_loop_entry");
5274 9951 : gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
5275 :
5276 9951 : if (nested_loop)
5277 : {
5278 2796 : ploop = enter_nested_loop (&nested_se);
5279 2796 : orig_ss = nested_se.ss;
5280 2796 : ploop->temp_dim = 1;
5281 : }
5282 : else
5283 : {
5284 : /* Initialize the scalarizer. */
5285 7155 : gfc_init_loopinfo (&loop);
5286 :
5287 : /* We add the mask first because the number of iterations is taken
5288 : from the last ss, and this breaks if an absent optional argument
5289 : is used for mask. */
5290 :
5291 7155 : if (maskss)
5292 2700 : gfc_add_ss_to_loop (&loop, maskss);
5293 :
5294 7155 : gfc_add_ss_to_loop (&loop, arrayss);
5295 :
5296 : /* Initialize the loop. */
5297 7155 : gfc_conv_ss_startstride (&loop);
5298 :
5299 : /* The code generated can have more than one loop in sequence (see the
5300 : comment at the function header). This doesn't work well with the
5301 : scalarizer, which changes arrays' offset when the scalarization loops
5302 : are generated (see gfc_trans_preloop_setup). Fortunately, we can use
5303 : the scalarizer temporary code to handle multiple loops. Thus, we set
5304 : temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
5305 : we use gfc_trans_scalarized_loop_boundary even later to restore
5306 : offset. */
5307 7155 : loop.temp_dim = loop.dimen;
5308 7155 : gfc_conv_loop_setup (&loop, &expr->where);
5309 :
5310 7155 : ploop = &loop;
5311 : }
5312 :
5313 9951 : gcc_assert (reduction_dimensions == ploop->dimen);
5314 :
5315 9951 : if (nonempty == NULL && !(maskexpr && maskexpr->rank > 0))
5316 : {
5317 1595 : nonempty = logical_true_node;
5318 :
5319 3697 : for (int i = 0; i < ploop->dimen; i++)
5320 : {
5321 2102 : if (!(ploop->from[i] && ploop->to[i]))
5322 : {
5323 : nonempty = NULL;
5324 : break;
5325 : }
5326 :
5327 2102 : tree tmp = fold_build2_loc (input_location, LE_EXPR,
5328 : logical_type_node, ploop->from[i],
5329 : ploop->to[i]);
5330 :
5331 2102 : nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5332 : logical_type_node, nonempty, tmp);
5333 : }
5334 : }
5335 :
5336 11546 : lab1 = NULL;
5337 11546 : lab2 = NULL;
5338 : /* Initialize the position to zero, following Fortran 2003. We are free
5339 : to do this because Fortran 95 allows the result of an entirely false
5340 : mask to be processor dependent. If we know at compile time the array
5341 : is non-empty and no MASK is used, we can initialize to 1 to simplify
5342 : the inner loop. */
5343 9951 : if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5344 : {
5345 3748 : tree init = fold_build3_loc (input_location, COND_EXPR,
5346 : gfc_array_index_type, nonempty,
5347 : gfc_index_one_node,
5348 : gfc_index_zero_node);
5349 8430 : for (int i = 0; i < ploop->dimen; i++)
5350 4682 : gfc_add_modify (&ploop->pre, pos[i], init);
5351 : }
5352 : else
5353 : {
5354 13747 : for (int i = 0; i < ploop->dimen; i++)
5355 7544 : gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node);
5356 6203 : lab1 = gfc_build_label_decl (NULL_TREE);
5357 6203 : TREE_USED (lab1) = 1;
5358 6203 : lab2 = gfc_build_label_decl (NULL_TREE);
5359 6203 : TREE_USED (lab2) = 1;
5360 : }
5361 :
5362 : /* An offset must be added to the loop
5363 : counter to obtain the required position. */
5364 22177 : for (int i = 0; i < ploop->dimen; i++)
5365 : {
5366 12226 : gcc_assert (ploop->from[i]);
5367 :
5368 12226 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5369 : gfc_index_one_node, ploop->from[i]);
5370 12226 : gfc_add_modify (&ploop->pre, offset[i], tmp);
5371 : }
5372 :
5373 9951 : if (!nested_loop)
5374 : {
5375 9965 : gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5376 7155 : if (maskss)
5377 2700 : gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5378 : }
5379 :
5380 : /* Generate the loop body. */
5381 9951 : gfc_start_scalarized_body (ploop, &body);
5382 :
5383 : /* If we have a mask, only check this element if the mask is set. */
5384 9951 : if (maskexpr && maskexpr->rank > 0)
5385 : {
5386 3874 : gfc_init_se (&maskse, base_se);
5387 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5388 3874 : if (!nested_loop)
5389 2700 : maskse.ss = maskss;
5390 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5391 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5392 :
5393 3874 : gfc_start_block (&block);
5394 : }
5395 : else
5396 6077 : gfc_init_block (&block);
5397 :
5398 : /* Compare with the current limit. */
5399 9951 : gfc_init_se (&arrayse, base_se);
5400 9951 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5401 9951 : if (!nested_loop)
5402 7155 : arrayse.ss = arrayss;
5403 9951 : gfc_conv_expr_val (&arrayse, arrayexpr);
5404 9951 : gfc_add_block_to_block (&block, &arrayse.pre);
5405 :
5406 : /* We do the following if this is a more extreme value. */
5407 9951 : gfc_start_block (&ifblock);
5408 :
5409 : /* Assign the value to the limit... */
5410 9951 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5411 :
5412 9951 : if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5413 : {
5414 1569 : stmtblock_t ifblock2;
5415 1569 : tree ifbody2;
5416 :
5417 1569 : gfc_start_block (&ifblock2);
5418 3439 : for (int i = 0; i < ploop->dimen; i++)
5419 : {
5420 1870 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5421 : ploop->loopvar[i], offset[i]);
5422 1870 : gfc_add_modify (&ifblock2, pos[i], tmp);
5423 : }
5424 1569 : ifbody2 = gfc_finish_block (&ifblock2);
5425 :
5426 1569 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5427 : pos[0], gfc_index_zero_node);
5428 1569 : tmp = build3_v (COND_EXPR, cond, ifbody2,
5429 : build_empty_stmt (input_location));
5430 1569 : gfc_add_expr_to_block (&block, tmp);
5431 : }
5432 :
5433 22177 : for (int i = 0; i < ploop->dimen; i++)
5434 : {
5435 12226 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5436 : ploop->loopvar[i], offset[i]);
5437 12226 : gfc_add_modify (&ifblock, pos[i], tmp);
5438 12226 : gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
5439 : }
5440 :
5441 9951 : gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
5442 :
5443 9951 : if (lab1)
5444 6203 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5445 :
5446 9951 : ifbody = gfc_finish_block (&ifblock);
5447 :
5448 9951 : if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5449 : {
5450 7646 : if (lab1)
5451 5998 : cond = fold_build2_loc (input_location,
5452 : op == GT_EXPR ? GE_EXPR : LE_EXPR,
5453 : logical_type_node, arrayse.expr, limit);
5454 : else
5455 : {
5456 3748 : tree ifbody2, elsebody2;
5457 :
5458 : /* We switch to > or >= depending on the value of the BACK argument. */
5459 3748 : cond = gfc_create_var (logical_type_node, "cond");
5460 :
5461 3748 : gfc_start_block (&ifblock);
5462 5641 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5463 : logical_type_node, arrayse.expr, limit);
5464 :
5465 3748 : gfc_add_modify (&ifblock, cond, b_if);
5466 3748 : ifbody2 = gfc_finish_block (&ifblock);
5467 :
5468 3748 : gfc_start_block (&elseblock);
5469 3748 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5470 : arrayse.expr, limit);
5471 :
5472 3748 : gfc_add_modify (&elseblock, cond, b_else);
5473 3748 : elsebody2 = gfc_finish_block (&elseblock);
5474 :
5475 3748 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5476 : back, ifbody2, elsebody2);
5477 :
5478 3748 : gfc_add_expr_to_block (&block, tmp);
5479 : }
5480 :
5481 7646 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5482 7646 : ifbody = build3_v (COND_EXPR, cond, ifbody,
5483 : build_empty_stmt (input_location));
5484 : }
5485 9951 : gfc_add_expr_to_block (&block, ifbody);
5486 :
5487 9951 : if (maskexpr && maskexpr->rank > 0)
5488 : {
5489 : /* We enclose the above in if (mask) {...}. If the mask is an
5490 : optional argument, generate IF (.NOT. PRESENT(MASK)
5491 : .OR. MASK(I)). */
5492 :
5493 3874 : tree ifmask;
5494 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5495 3874 : tmp = gfc_finish_block (&block);
5496 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5497 : build_empty_stmt (input_location));
5498 3874 : }
5499 : else
5500 6077 : tmp = gfc_finish_block (&block);
5501 9951 : gfc_add_expr_to_block (&body, tmp);
5502 :
5503 9951 : if (lab1)
5504 : {
5505 13747 : for (int i = 0; i < ploop->dimen; i++)
5506 7544 : ploop->from[i] = fold_build3_loc (input_location, COND_EXPR,
5507 7544 : TREE_TYPE (ploop->from[i]),
5508 : second_loop_entry, idx[i],
5509 : ploop->from[i]);
5510 :
5511 6203 : gfc_trans_scalarized_loop_boundary (ploop, &body);
5512 :
5513 6203 : if (nested_loop)
5514 : {
5515 : /* The first loop already advanced the parent se'ss chain, so clear
5516 : the parent now to avoid doing it a second time, making the chain
5517 : out of sync. */
5518 1858 : nested_se.parent = nullptr;
5519 1858 : nested_se.ss = orig_ss;
5520 : }
5521 :
5522 6203 : stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1];
5523 :
5524 6203 : if (HONOR_NANS (DECL_MODE (limit)))
5525 : {
5526 3898 : if (nonempty != NULL)
5527 : {
5528 2329 : stmtblock_t init_block;
5529 2329 : gfc_init_block (&init_block);
5530 :
5531 5229 : for (int i = 0; i < ploop->dimen; i++)
5532 2900 : gfc_add_modify (&init_block, pos[i], gfc_index_one_node);
5533 :
5534 2329 : tree ifbody = gfc_finish_block (&init_block);
5535 2329 : tmp = build3_v (COND_EXPR, nonempty, ifbody,
5536 : build_empty_stmt (input_location));
5537 2329 : gfc_add_expr_to_block (outer_block, tmp);
5538 : }
5539 : }
5540 :
5541 6203 : gfc_add_expr_to_block (outer_block, build1_v (GOTO_EXPR, lab2));
5542 6203 : gfc_add_expr_to_block (outer_block, build1_v (LABEL_EXPR, lab1));
5543 :
5544 : /* If we have a mask, only check this element if the mask is set. */
5545 6203 : if (maskexpr && maskexpr->rank > 0)
5546 : {
5547 3874 : gfc_init_se (&maskse, base_se);
5548 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5549 3874 : if (!nested_loop)
5550 2700 : maskse.ss = maskss;
5551 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5552 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5553 :
5554 3874 : gfc_start_block (&block);
5555 : }
5556 : else
5557 2329 : gfc_init_block (&block);
5558 :
5559 : /* Compare with the current limit. */
5560 6203 : gfc_init_se (&arrayse, base_se);
5561 6203 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5562 6203 : if (!nested_loop)
5563 4345 : arrayse.ss = arrayss;
5564 6203 : gfc_conv_expr_val (&arrayse, arrayexpr);
5565 6203 : gfc_add_block_to_block (&block, &arrayse.pre);
5566 :
5567 : /* We do the following if this is a more extreme value. */
5568 6203 : gfc_start_block (&ifblock);
5569 :
5570 : /* Assign the value to the limit... */
5571 6203 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5572 :
5573 13747 : for (int i = 0; i < ploop->dimen; i++)
5574 : {
5575 7544 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5576 : ploop->loopvar[i], offset[i]);
5577 7544 : gfc_add_modify (&ifblock, pos[i], tmp);
5578 : }
5579 :
5580 6203 : ifbody = gfc_finish_block (&ifblock);
5581 :
5582 : /* We switch to > or >= depending on the value of the BACK argument. */
5583 6203 : {
5584 6203 : tree ifbody2, elsebody2;
5585 :
5586 6203 : cond = gfc_create_var (logical_type_node, "cond");
5587 :
5588 6203 : gfc_start_block (&ifblock);
5589 9537 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5590 : logical_type_node, arrayse.expr, limit);
5591 :
5592 6203 : gfc_add_modify (&ifblock, cond, b_if);
5593 6203 : ifbody2 = gfc_finish_block (&ifblock);
5594 :
5595 6203 : gfc_start_block (&elseblock);
5596 6203 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5597 : arrayse.expr, limit);
5598 :
5599 6203 : gfc_add_modify (&elseblock, cond, b_else);
5600 6203 : elsebody2 = gfc_finish_block (&elseblock);
5601 :
5602 6203 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5603 : back, ifbody2, elsebody2);
5604 : }
5605 :
5606 6203 : gfc_add_expr_to_block (&block, tmp);
5607 6203 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5608 6203 : tmp = build3_v (COND_EXPR, cond, ifbody,
5609 : build_empty_stmt (input_location));
5610 :
5611 6203 : gfc_add_expr_to_block (&block, tmp);
5612 :
5613 6203 : if (maskexpr && maskexpr->rank > 0)
5614 : {
5615 : /* We enclose the above in if (mask) {...}. If the mask is
5616 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5617 : .OR. MASK(I)).*/
5618 :
5619 3874 : tree ifmask;
5620 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5621 3874 : tmp = gfc_finish_block (&block);
5622 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5623 : build_empty_stmt (input_location));
5624 3874 : }
5625 : else
5626 2329 : tmp = gfc_finish_block (&block);
5627 :
5628 6203 : gfc_add_expr_to_block (&body, tmp);
5629 6203 : gfc_add_modify (&body, second_loop_entry, logical_false_node);
5630 : }
5631 :
5632 9951 : gfc_trans_scalarizing_loops (ploop, &body);
5633 :
5634 9951 : if (lab2)
5635 6203 : gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2));
5636 :
5637 : /* For a scalar mask, enclose the loop in an if statement. */
5638 9951 : if (maskexpr && maskexpr->rank == 0)
5639 : {
5640 2644 : tree ifmask;
5641 :
5642 2644 : gfc_init_se (&maskse, nested_loop ? se : nullptr);
5643 2644 : gfc_conv_expr_val (&maskse, maskexpr);
5644 2644 : gfc_add_block_to_block (&se->pre, &maskse.pre);
5645 2644 : gfc_init_block (&block);
5646 2644 : gfc_add_block_to_block (&block, &ploop->pre);
5647 2644 : gfc_add_block_to_block (&block, &ploop->post);
5648 2644 : tmp = gfc_finish_block (&block);
5649 :
5650 : /* For the else part of the scalar mask, just initialize
5651 : the pos variable the same way as above. */
5652 :
5653 2644 : gfc_init_block (&elseblock);
5654 5580 : for (int i = 0; i < ploop->dimen; i++)
5655 2936 : gfc_add_modify (&elseblock, pos[i], gfc_index_zero_node);
5656 2644 : elsetmp = gfc_finish_block (&elseblock);
5657 2644 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5658 2644 : tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5659 2644 : gfc_add_expr_to_block (&block, tmp);
5660 2644 : gfc_add_block_to_block (&se->pre, &block);
5661 2644 : }
5662 : else
5663 : {
5664 7307 : gfc_add_block_to_block (&se->pre, &ploop->pre);
5665 7307 : gfc_add_block_to_block (&se->pre, &ploop->post);
5666 : }
5667 :
5668 9951 : if (!nested_loop)
5669 7155 : gfc_cleanup_loop (&loop);
5670 :
5671 9951 : if (!dim_present)
5672 : {
5673 8837 : for (int i = 0; i < arrayexpr->rank; i++)
5674 : {
5675 5556 : tree res_idx = build_int_cst (gfc_array_index_type, i);
5676 5556 : tree res_arr_ref = gfc_build_array_ref (result_var, res_idx,
5677 : NULL_TREE, true);
5678 :
5679 5556 : tree value = convert (type, pos[i]);
5680 5556 : gfc_add_modify (&se->pre, res_arr_ref, value);
5681 : }
5682 :
5683 3281 : se->expr = result_var;
5684 : }
5685 : else
5686 6670 : se->expr = convert (type, pos[0]);
5687 : }
5688 :
5689 : /* Emit code for findloc. */
5690 :
5691 : static void
5692 1332 : gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5693 : {
5694 1332 : gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5695 : *kind_arg, *back_arg;
5696 1332 : gfc_expr *value_expr;
5697 1332 : int ikind;
5698 1332 : tree resvar;
5699 1332 : stmtblock_t block;
5700 1332 : stmtblock_t body;
5701 1332 : stmtblock_t loopblock;
5702 1332 : tree type;
5703 1332 : tree tmp;
5704 1332 : tree found;
5705 1332 : tree forward_branch = NULL_TREE;
5706 1332 : tree back_branch;
5707 1332 : gfc_loopinfo loop;
5708 1332 : gfc_ss *arrayss;
5709 1332 : gfc_ss *maskss;
5710 1332 : gfc_se arrayse;
5711 1332 : gfc_se valuese;
5712 1332 : gfc_se maskse;
5713 1332 : gfc_se backse;
5714 1332 : tree exit_label;
5715 1332 : gfc_expr *maskexpr;
5716 1332 : tree offset;
5717 1332 : int i;
5718 1332 : bool optional_mask;
5719 :
5720 1332 : array_arg = expr->value.function.actual;
5721 1332 : value_arg = array_arg->next;
5722 1332 : dim_arg = value_arg->next;
5723 1332 : mask_arg = dim_arg->next;
5724 1332 : kind_arg = mask_arg->next;
5725 1332 : back_arg = kind_arg->next;
5726 :
5727 : /* Remove kind and set ikind. */
5728 1332 : if (kind_arg->expr)
5729 : {
5730 0 : ikind = mpz_get_si (kind_arg->expr->value.integer);
5731 0 : gfc_free_expr (kind_arg->expr);
5732 0 : kind_arg->expr = NULL;
5733 : }
5734 : else
5735 1332 : ikind = gfc_default_integer_kind;
5736 :
5737 1332 : value_expr = value_arg->expr;
5738 :
5739 : /* Unless it's a string, pass VALUE by value. */
5740 1332 : if (value_expr->ts.type != BT_CHARACTER)
5741 732 : value_arg->name = "%VAL";
5742 :
5743 : /* Pass BACK argument by value. */
5744 1332 : back_arg->name = "%VAL";
5745 :
5746 : /* Call the library if we have a character function or if
5747 : rank > 0. */
5748 1332 : if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5749 : {
5750 1200 : se->ignore_optional = 1;
5751 1200 : if (expr->rank == 0)
5752 : {
5753 : /* Remove dim argument. */
5754 84 : gfc_free_expr (dim_arg->expr);
5755 84 : dim_arg->expr = NULL;
5756 : }
5757 1200 : gfc_conv_intrinsic_funcall (se, expr);
5758 1200 : return;
5759 : }
5760 :
5761 132 : type = gfc_get_int_type (ikind);
5762 :
5763 : /* Initialize the result. */
5764 132 : resvar = gfc_create_var (gfc_array_index_type, "pos");
5765 132 : gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5766 132 : offset = gfc_create_var (gfc_array_index_type, "offset");
5767 :
5768 132 : maskexpr = mask_arg->expr;
5769 72 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5770 60 : && maskexpr->symtree->n.sym->attr.dummy
5771 144 : && maskexpr->symtree->n.sym->attr.optional;
5772 :
5773 : /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5774 :
5775 396 : for (i = 0 ; i < 2; i++)
5776 : {
5777 : /* Walk the arguments. */
5778 264 : arrayss = gfc_walk_expr (array_arg->expr);
5779 264 : gcc_assert (arrayss != gfc_ss_terminator);
5780 :
5781 264 : if (maskexpr && maskexpr->rank != 0)
5782 : {
5783 84 : maskss = gfc_walk_expr (maskexpr);
5784 84 : gcc_assert (maskss != gfc_ss_terminator);
5785 : }
5786 : else
5787 : maskss = NULL;
5788 :
5789 : /* Initialize the scalarizer. */
5790 264 : gfc_init_loopinfo (&loop);
5791 264 : exit_label = gfc_build_label_decl (NULL_TREE);
5792 264 : TREE_USED (exit_label) = 1;
5793 :
5794 : /* We add the mask first because the number of iterations is
5795 : taken from the last ss, and this breaks if an absent
5796 : optional argument is used for mask. */
5797 :
5798 264 : if (maskss)
5799 84 : gfc_add_ss_to_loop (&loop, maskss);
5800 264 : gfc_add_ss_to_loop (&loop, arrayss);
5801 :
5802 : /* Initialize the loop. */
5803 264 : gfc_conv_ss_startstride (&loop);
5804 264 : gfc_conv_loop_setup (&loop, &expr->where);
5805 :
5806 : /* Calculate the offset. */
5807 264 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5808 : gfc_index_one_node, loop.from[0]);
5809 264 : gfc_add_modify (&loop.pre, offset, tmp);
5810 :
5811 264 : gfc_mark_ss_chain_used (arrayss, 1);
5812 264 : if (maskss)
5813 84 : gfc_mark_ss_chain_used (maskss, 1);
5814 :
5815 : /* The first loop is for BACK=.true. */
5816 264 : if (i == 0)
5817 132 : loop.reverse[0] = GFC_REVERSE_SET;
5818 :
5819 : /* Generate the loop body. */
5820 264 : gfc_start_scalarized_body (&loop, &body);
5821 :
5822 : /* If we have an array mask, only add the element if it is
5823 : set. */
5824 264 : if (maskss)
5825 : {
5826 84 : gfc_init_se (&maskse, NULL);
5827 84 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5828 84 : maskse.ss = maskss;
5829 84 : gfc_conv_expr_val (&maskse, maskexpr);
5830 84 : gfc_add_block_to_block (&body, &maskse.pre);
5831 : }
5832 :
5833 : /* If the condition matches then set the return value. */
5834 264 : gfc_start_block (&block);
5835 :
5836 : /* Add the offset. */
5837 264 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5838 264 : TREE_TYPE (resvar),
5839 : loop.loopvar[0], offset);
5840 264 : gfc_add_modify (&block, resvar, tmp);
5841 : /* And break out of the loop. */
5842 264 : tmp = build1_v (GOTO_EXPR, exit_label);
5843 264 : gfc_add_expr_to_block (&block, tmp);
5844 :
5845 264 : found = gfc_finish_block (&block);
5846 :
5847 : /* Check this element. */
5848 264 : gfc_init_se (&arrayse, NULL);
5849 264 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5850 264 : arrayse.ss = arrayss;
5851 264 : gfc_conv_expr_val (&arrayse, array_arg->expr);
5852 264 : gfc_add_block_to_block (&body, &arrayse.pre);
5853 :
5854 264 : gfc_init_se (&valuese, NULL);
5855 264 : gfc_conv_expr_val (&valuese, value_arg->expr);
5856 264 : gfc_add_block_to_block (&body, &valuese.pre);
5857 :
5858 264 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5859 : arrayse.expr, valuese.expr);
5860 :
5861 264 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5862 264 : if (maskss)
5863 : {
5864 : /* We enclose the above in if (mask) {...}. If the mask is
5865 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5866 : .OR. MASK(I)). */
5867 :
5868 84 : tree ifmask;
5869 84 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5870 84 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5871 : build_empty_stmt (input_location));
5872 : }
5873 :
5874 264 : gfc_add_expr_to_block (&body, tmp);
5875 264 : gfc_add_block_to_block (&body, &arrayse.post);
5876 :
5877 264 : gfc_trans_scalarizing_loops (&loop, &body);
5878 :
5879 : /* Add the exit label. */
5880 264 : tmp = build1_v (LABEL_EXPR, exit_label);
5881 264 : gfc_add_expr_to_block (&loop.pre, tmp);
5882 264 : gfc_start_block (&loopblock);
5883 264 : gfc_add_block_to_block (&loopblock, &loop.pre);
5884 264 : gfc_add_block_to_block (&loopblock, &loop.post);
5885 264 : if (i == 0)
5886 132 : forward_branch = gfc_finish_block (&loopblock);
5887 : else
5888 132 : back_branch = gfc_finish_block (&loopblock);
5889 :
5890 264 : gfc_cleanup_loop (&loop);
5891 : }
5892 :
5893 : /* Enclose the two loops in an IF statement. */
5894 :
5895 132 : gfc_init_se (&backse, NULL);
5896 132 : gfc_conv_expr_val (&backse, back_arg->expr);
5897 132 : gfc_add_block_to_block (&se->pre, &backse.pre);
5898 132 : tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5899 :
5900 : /* For a scalar mask, enclose the loop in an if statement. */
5901 132 : if (maskexpr && maskss == NULL)
5902 : {
5903 30 : tree ifmask;
5904 30 : tree if_stmt;
5905 :
5906 30 : gfc_init_se (&maskse, NULL);
5907 30 : gfc_conv_expr_val (&maskse, maskexpr);
5908 30 : gfc_init_block (&block);
5909 30 : gfc_add_expr_to_block (&block, maskse.expr);
5910 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5911 30 : if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5912 : build_empty_stmt (input_location));
5913 30 : gfc_add_expr_to_block (&block, if_stmt);
5914 30 : tmp = gfc_finish_block (&block);
5915 : }
5916 :
5917 132 : gfc_add_expr_to_block (&se->pre, tmp);
5918 132 : se->expr = convert (type, resvar);
5919 :
5920 : }
5921 :
5922 : /* Emit code for fstat, lstat and stat intrinsic subroutines. */
5923 :
5924 : static tree
5925 55 : conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code)
5926 : {
5927 55 : stmtblock_t block;
5928 55 : gfc_se se, se_stat;
5929 55 : tree unit = NULL_TREE;
5930 55 : tree name = NULL_TREE;
5931 55 : tree slen = NULL_TREE;
5932 55 : tree vals;
5933 55 : tree arg3 = NULL_TREE;
5934 55 : tree stat = NULL_TREE ;
5935 55 : tree present = NULL_TREE;
5936 55 : tree tmp;
5937 55 : int kind;
5938 :
5939 55 : gfc_init_block (&block);
5940 55 : gfc_init_se (&se, NULL);
5941 :
5942 55 : switch (code->resolved_isym->id)
5943 : {
5944 21 : case GFC_ISYM_FSTAT:
5945 : /* Deal with the UNIT argument. */
5946 21 : gfc_conv_expr (&se, code->ext.actual->expr);
5947 21 : gfc_add_block_to_block (&block, &se.pre);
5948 21 : unit = gfc_evaluate_now (se.expr, &block);
5949 21 : unit = gfc_build_addr_expr (NULL_TREE, unit);
5950 21 : gfc_add_block_to_block (&block, &se.post);
5951 21 : break;
5952 :
5953 34 : case GFC_ISYM_LSTAT:
5954 34 : case GFC_ISYM_STAT:
5955 : /* Deal with the NAME argument. */
5956 34 : gfc_conv_expr (&se, code->ext.actual->expr);
5957 34 : gfc_conv_string_parameter (&se);
5958 34 : gfc_add_block_to_block (&block, &se.pre);
5959 34 : name = se.expr;
5960 34 : slen = se.string_length;
5961 34 : gfc_add_block_to_block (&block, &se.post);
5962 34 : break;
5963 :
5964 0 : default:
5965 0 : gcc_unreachable ();
5966 : }
5967 :
5968 : /* Deal with the VALUES argument. */
5969 55 : gfc_init_se (&se, NULL);
5970 55 : gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr);
5971 55 : vals = gfc_build_addr_expr (NULL_TREE, se.expr);
5972 55 : gfc_add_block_to_block (&block, &se.pre);
5973 55 : gfc_add_block_to_block (&block, &se.post);
5974 55 : kind = code->ext.actual->next->expr->ts.kind;
5975 :
5976 : /* Deal with an optional STATUS. */
5977 55 : if (code->ext.actual->next->next->expr)
5978 : {
5979 45 : gfc_init_se (&se_stat, NULL);
5980 45 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
5981 45 : stat = gfc_create_var (gfc_get_int_type (kind), "_stat");
5982 45 : arg3 = gfc_build_addr_expr (NULL_TREE, stat);
5983 :
5984 : /* Handle case of status being an optional dummy. */
5985 45 : gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym;
5986 45 : if (sym->attr.dummy && sym->attr.optional)
5987 : {
5988 6 : present = gfc_conv_expr_present (sym);
5989 12 : arg3 = fold_build3_loc (input_location, COND_EXPR,
5990 6 : TREE_TYPE (arg3), present, arg3,
5991 6 : fold_convert (TREE_TYPE (arg3),
5992 : null_pointer_node));
5993 : }
5994 : }
5995 :
5996 : /* Call library function depending on KIND of VALUES argument. */
5997 55 : switch (code->resolved_isym->id)
5998 : {
5999 21 : case GFC_ISYM_FSTAT:
6000 21 : tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub);
6001 : break;
6002 14 : case GFC_ISYM_LSTAT:
6003 14 : tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub);
6004 : break;
6005 20 : case GFC_ISYM_STAT:
6006 20 : tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub);
6007 : break;
6008 0 : default:
6009 0 : gcc_unreachable ();
6010 : }
6011 :
6012 55 : if (code->resolved_isym->id == GFC_ISYM_FSTAT)
6013 21 : tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals,
6014 : stat ? arg3 : null_pointer_node);
6015 : else
6016 34 : tmp = build_call_expr_loc (input_location, tmp, 4, name, vals,
6017 : stat ? arg3 : null_pointer_node, slen);
6018 55 : gfc_add_expr_to_block (&block, tmp);
6019 :
6020 : /* Handle kind conversion of status. */
6021 55 : if (stat && stat != se_stat.expr)
6022 : {
6023 45 : stmtblock_t block2;
6024 :
6025 45 : gfc_init_block (&block2);
6026 45 : gfc_add_modify (&block2, se_stat.expr,
6027 45 : fold_convert (TREE_TYPE (se_stat.expr), stat));
6028 :
6029 45 : if (present)
6030 : {
6031 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2),
6032 : build_empty_stmt (input_location));
6033 6 : gfc_add_expr_to_block (&block, tmp);
6034 : }
6035 : else
6036 39 : gfc_add_block_to_block (&block, &block2);
6037 : }
6038 :
6039 55 : return gfc_finish_block (&block);
6040 : }
6041 :
6042 : /* Emit code for minval or maxval intrinsic. There are many different cases
6043 : we need to handle. For performance reasons we sometimes create two
6044 : loops instead of one, where the second one is much simpler.
6045 : Examples for minval intrinsic:
6046 : 1) Result is an array, a call is generated
6047 : 2) Array mask is used and NaNs need to be supported, rank 1:
6048 : limit = Infinity;
6049 : nonempty = false;
6050 : S = from;
6051 : while (S <= to) {
6052 : if (mask[S]) {
6053 : nonempty = true;
6054 : if (a[S] <= limit) {
6055 : limit = a[S];
6056 : S++;
6057 : goto lab;
6058 : }
6059 : else
6060 : S++;
6061 : }
6062 : }
6063 : limit = nonempty ? NaN : huge (limit);
6064 : lab:
6065 : while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6066 : 3) NaNs need to be supported, but it is known at compile time or cheaply
6067 : at runtime whether array is nonempty or not, rank 1:
6068 : limit = Infinity;
6069 : S = from;
6070 : while (S <= to) {
6071 : if (a[S] <= limit) {
6072 : limit = a[S];
6073 : S++;
6074 : goto lab;
6075 : }
6076 : else
6077 : S++;
6078 : }
6079 : limit = (from <= to) ? NaN : huge (limit);
6080 : lab:
6081 : while (S <= to) { limit = min (a[S], limit); S++; }
6082 : 4) Array mask is used and NaNs need to be supported, rank > 1:
6083 : limit = Infinity;
6084 : nonempty = false;
6085 : fast = false;
6086 : S1 = from1;
6087 : while (S1 <= to1) {
6088 : S2 = from2;
6089 : while (S2 <= to2) {
6090 : if (mask[S1][S2]) {
6091 : if (fast) limit = min (a[S1][S2], limit);
6092 : else {
6093 : nonempty = true;
6094 : if (a[S1][S2] <= limit) {
6095 : limit = a[S1][S2];
6096 : fast = true;
6097 : }
6098 : }
6099 : }
6100 : S2++;
6101 : }
6102 : S1++;
6103 : }
6104 : if (!fast)
6105 : limit = nonempty ? NaN : huge (limit);
6106 : 5) NaNs need to be supported, but it is known at compile time or cheaply
6107 : at runtime whether array is nonempty or not, rank > 1:
6108 : limit = Infinity;
6109 : fast = false;
6110 : S1 = from1;
6111 : while (S1 <= to1) {
6112 : S2 = from2;
6113 : while (S2 <= to2) {
6114 : if (fast) limit = min (a[S1][S2], limit);
6115 : else {
6116 : if (a[S1][S2] <= limit) {
6117 : limit = a[S1][S2];
6118 : fast = true;
6119 : }
6120 : }
6121 : S2++;
6122 : }
6123 : S1++;
6124 : }
6125 : if (!fast)
6126 : limit = (nonempty_array) ? NaN : huge (limit);
6127 : 6) NaNs aren't supported, but infinities are. Array mask is used:
6128 : limit = Infinity;
6129 : nonempty = false;
6130 : S = from;
6131 : while (S <= to) {
6132 : if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6133 : S++;
6134 : }
6135 : limit = nonempty ? limit : huge (limit);
6136 : 7) Same without array mask:
6137 : limit = Infinity;
6138 : S = from;
6139 : while (S <= to) { limit = min (a[S], limit); S++; }
6140 : limit = (from <= to) ? limit : huge (limit);
6141 : 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6142 : limit = huge (limit);
6143 : S = from;
6144 : while (S <= to) { limit = min (a[S], limit); S++); }
6145 : (or
6146 : while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6147 : with array mask instead).
6148 : For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6149 : setting limit = huge (limit); in the else branch. */
6150 :
6151 : static void
6152 2417 : gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6153 : {
6154 2417 : tree limit;
6155 2417 : tree type;
6156 2417 : tree tmp;
6157 2417 : tree ifbody;
6158 2417 : tree nonempty;
6159 2417 : tree nonempty_var;
6160 2417 : tree lab;
6161 2417 : tree fast;
6162 2417 : tree huge_cst = NULL, nan_cst = NULL;
6163 2417 : stmtblock_t body;
6164 2417 : stmtblock_t block, block2;
6165 2417 : gfc_loopinfo loop;
6166 2417 : gfc_actual_arglist *actual;
6167 2417 : gfc_ss *arrayss;
6168 2417 : gfc_ss *maskss;
6169 2417 : gfc_se arrayse;
6170 2417 : gfc_se maskse;
6171 2417 : gfc_expr *arrayexpr;
6172 2417 : gfc_expr *maskexpr;
6173 2417 : int n;
6174 2417 : bool optional_mask;
6175 :
6176 2417 : if (se->ss)
6177 : {
6178 0 : gfc_conv_intrinsic_funcall (se, expr);
6179 186 : return;
6180 : }
6181 :
6182 2417 : actual = expr->value.function.actual;
6183 2417 : arrayexpr = actual->expr;
6184 :
6185 2417 : if (arrayexpr->ts.type == BT_CHARACTER)
6186 : {
6187 186 : gfc_actual_arglist *dim = actual->next;
6188 186 : if (expr->rank == 0 && dim->expr != 0)
6189 : {
6190 6 : gfc_free_expr (dim->expr);
6191 6 : dim->expr = NULL;
6192 : }
6193 186 : gfc_conv_intrinsic_funcall (se, expr);
6194 186 : return;
6195 : }
6196 :
6197 2231 : type = gfc_typenode_for_spec (&expr->ts);
6198 : /* Initialize the result. */
6199 2231 : limit = gfc_create_var (type, "limit");
6200 2231 : n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6201 2231 : switch (expr->ts.type)
6202 : {
6203 1245 : case BT_REAL:
6204 1245 : huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6205 : expr->ts.kind, 0);
6206 1245 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6207 : {
6208 1241 : REAL_VALUE_TYPE real;
6209 1241 : real_inf (&real);
6210 1241 : tmp = build_real (type, real);
6211 : }
6212 : else
6213 : tmp = huge_cst;
6214 1245 : if (HONOR_NANS (DECL_MODE (limit)))
6215 1241 : nan_cst = gfc_build_nan (type, "");
6216 : break;
6217 :
6218 956 : case BT_INTEGER:
6219 956 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6220 956 : break;
6221 :
6222 30 : case BT_UNSIGNED:
6223 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
6224 30 : if (op == GT_EXPR)
6225 18 : tmp = build_int_cst (type, 0);
6226 : else
6227 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
6228 : expr->ts.kind);
6229 : break;
6230 :
6231 0 : default:
6232 0 : gcc_unreachable ();
6233 : }
6234 :
6235 : /* We start with the most negative possible value for MAXVAL, and the most
6236 : positive possible value for MINVAL. The most negative possible value is
6237 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6238 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
6239 : with above. */
6240 2231 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
6241 : {
6242 987 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6243 987 : if (huge_cst)
6244 560 : huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6245 560 : TREE_TYPE (huge_cst), huge_cst);
6246 : }
6247 :
6248 1005 : if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6249 427 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6250 : tmp, build_int_cst (type, 1));
6251 :
6252 2231 : gfc_add_modify (&se->pre, limit, tmp);
6253 :
6254 : /* Walk the arguments. */
6255 2231 : arrayss = gfc_walk_expr (arrayexpr);
6256 2231 : gcc_assert (arrayss != gfc_ss_terminator);
6257 :
6258 2231 : actual = actual->next->next;
6259 2231 : gcc_assert (actual);
6260 2231 : maskexpr = actual->expr;
6261 1572 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6262 1560 : && maskexpr->symtree->n.sym->attr.dummy
6263 2243 : && maskexpr->symtree->n.sym->attr.optional;
6264 1560 : nonempty = NULL;
6265 1572 : if (maskexpr && maskexpr->rank != 0)
6266 : {
6267 1026 : maskss = gfc_walk_expr (maskexpr);
6268 1026 : gcc_assert (maskss != gfc_ss_terminator);
6269 : }
6270 : else
6271 : {
6272 1205 : mpz_t asize;
6273 1205 : if (gfc_array_size (arrayexpr, &asize))
6274 : {
6275 678 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6276 678 : mpz_clear (asize);
6277 678 : nonempty = fold_build2_loc (input_location, GT_EXPR,
6278 : logical_type_node, nonempty,
6279 : gfc_index_zero_node);
6280 : }
6281 1205 : maskss = NULL;
6282 : }
6283 :
6284 : /* Initialize the scalarizer. */
6285 2231 : gfc_init_loopinfo (&loop);
6286 :
6287 : /* We add the mask first because the number of iterations is taken
6288 : from the last ss, and this breaks if an absent optional argument
6289 : is used for mask. */
6290 :
6291 2231 : if (maskss)
6292 1026 : gfc_add_ss_to_loop (&loop, maskss);
6293 2231 : gfc_add_ss_to_loop (&loop, arrayss);
6294 :
6295 : /* Initialize the loop. */
6296 2231 : gfc_conv_ss_startstride (&loop);
6297 :
6298 : /* The code generated can have more than one loop in sequence (see the
6299 : comment at the function header). This doesn't work well with the
6300 : scalarizer, which changes arrays' offset when the scalarization loops
6301 : are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6302 : are currently inlined in the scalar case only. As there is no dependency
6303 : to care about in that case, there is no temporary, so that we can use the
6304 : scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6305 : here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6306 : gfc_trans_scalarized_loop_boundary even later to restore offset.
6307 : TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6308 : should eventually go away. We could either create two loops properly,
6309 : or find another way to save/restore the array offsets between the two
6310 : loops (without conflicting with temporary management), or use a single
6311 : loop minmaxval implementation. See PR 31067. */
6312 2231 : loop.temp_dim = loop.dimen;
6313 2231 : gfc_conv_loop_setup (&loop, &expr->where);
6314 :
6315 2231 : if (nonempty == NULL && maskss == NULL
6316 527 : && loop.dimen == 1 && loop.from[0] && loop.to[0])
6317 491 : nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6318 : loop.from[0], loop.to[0]);
6319 2231 : nonempty_var = NULL;
6320 2231 : if (nonempty == NULL
6321 2231 : && (HONOR_INFINITIES (DECL_MODE (limit))
6322 480 : || HONOR_NANS (DECL_MODE (limit))))
6323 : {
6324 582 : nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6325 582 : gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6326 582 : nonempty = nonempty_var;
6327 : }
6328 2231 : lab = NULL;
6329 2231 : fast = NULL;
6330 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6331 : {
6332 1241 : if (loop.dimen == 1)
6333 : {
6334 821 : lab = gfc_build_label_decl (NULL_TREE);
6335 821 : TREE_USED (lab) = 1;
6336 : }
6337 : else
6338 : {
6339 420 : fast = gfc_create_var (logical_type_node, "fast");
6340 420 : gfc_add_modify (&se->pre, fast, logical_false_node);
6341 : }
6342 : }
6343 :
6344 2231 : gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6345 2231 : if (maskss)
6346 1704 : gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6347 : /* Generate the loop body. */
6348 2231 : gfc_start_scalarized_body (&loop, &body);
6349 :
6350 : /* If we have a mask, only add this element if the mask is set. */
6351 2231 : if (maskss)
6352 : {
6353 1026 : gfc_init_se (&maskse, NULL);
6354 1026 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6355 1026 : maskse.ss = maskss;
6356 1026 : gfc_conv_expr_val (&maskse, maskexpr);
6357 1026 : gfc_add_block_to_block (&body, &maskse.pre);
6358 :
6359 1026 : gfc_start_block (&block);
6360 : }
6361 : else
6362 1205 : gfc_init_block (&block);
6363 :
6364 : /* Compare with the current limit. */
6365 2231 : gfc_init_se (&arrayse, NULL);
6366 2231 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6367 2231 : arrayse.ss = arrayss;
6368 2231 : gfc_conv_expr_val (&arrayse, arrayexpr);
6369 2231 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6370 2231 : gfc_add_block_to_block (&block, &arrayse.pre);
6371 :
6372 2231 : gfc_init_block (&block2);
6373 :
6374 2231 : if (nonempty_var)
6375 582 : gfc_add_modify (&block2, nonempty_var, logical_true_node);
6376 :
6377 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6378 : {
6379 1922 : tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6380 : logical_type_node, arrayse.expr, limit);
6381 1241 : if (lab)
6382 : {
6383 821 : stmtblock_t ifblock;
6384 821 : tree inc_loop;
6385 821 : inc_loop = fold_build2_loc (input_location, PLUS_EXPR,
6386 821 : TREE_TYPE (loop.loopvar[0]),
6387 : loop.loopvar[0], gfc_index_one_node);
6388 821 : gfc_init_block (&ifblock);
6389 821 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6390 821 : gfc_add_modify (&ifblock, loop.loopvar[0], inc_loop);
6391 821 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab));
6392 821 : ifbody = gfc_finish_block (&ifblock);
6393 : }
6394 : else
6395 : {
6396 420 : stmtblock_t ifblock;
6397 :
6398 420 : gfc_init_block (&ifblock);
6399 420 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6400 420 : gfc_add_modify (&ifblock, fast, logical_true_node);
6401 420 : ifbody = gfc_finish_block (&ifblock);
6402 : }
6403 1241 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6404 : build_empty_stmt (input_location));
6405 1241 : gfc_add_expr_to_block (&block2, tmp);
6406 : }
6407 : else
6408 : {
6409 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6410 : signed zeros. */
6411 1535 : tmp = fold_build2_loc (input_location,
6412 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6413 : type, arrayse.expr, limit);
6414 990 : gfc_add_modify (&block2, limit, tmp);
6415 : }
6416 :
6417 2231 : if (fast)
6418 : {
6419 420 : tree elsebody = gfc_finish_block (&block2);
6420 :
6421 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6422 : signed zeros. */
6423 420 : if (HONOR_NANS (DECL_MODE (limit)))
6424 : {
6425 420 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6426 : arrayse.expr, limit);
6427 420 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6428 420 : ifbody = build3_v (COND_EXPR, tmp, ifbody,
6429 : build_empty_stmt (input_location));
6430 : }
6431 : else
6432 : {
6433 0 : tmp = fold_build2_loc (input_location,
6434 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6435 : type, arrayse.expr, limit);
6436 0 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6437 : }
6438 420 : tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6439 420 : gfc_add_expr_to_block (&block, tmp);
6440 : }
6441 : else
6442 1811 : gfc_add_block_to_block (&block, &block2);
6443 :
6444 2231 : gfc_add_block_to_block (&block, &arrayse.post);
6445 :
6446 2231 : tmp = gfc_finish_block (&block);
6447 2231 : if (maskss)
6448 : {
6449 : /* We enclose the above in if (mask) {...}. If the mask is an
6450 : optional argument, generate IF (.NOT. PRESENT(MASK)
6451 : .OR. MASK(I)). */
6452 1026 : tree ifmask;
6453 1026 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6454 1026 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6455 : build_empty_stmt (input_location));
6456 : }
6457 2231 : gfc_add_expr_to_block (&body, tmp);
6458 :
6459 2231 : if (lab)
6460 : {
6461 821 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6462 :
6463 821 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6464 : nan_cst, huge_cst);
6465 821 : gfc_add_modify (&loop.code[0], limit, tmp);
6466 821 : gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6467 :
6468 : /* If we have a mask, only add this element if the mask is set. */
6469 821 : if (maskss)
6470 : {
6471 348 : gfc_init_se (&maskse, NULL);
6472 348 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6473 348 : maskse.ss = maskss;
6474 348 : gfc_conv_expr_val (&maskse, maskexpr);
6475 348 : gfc_add_block_to_block (&body, &maskse.pre);
6476 :
6477 348 : gfc_start_block (&block);
6478 : }
6479 : else
6480 473 : gfc_init_block (&block);
6481 :
6482 : /* Compare with the current limit. */
6483 821 : gfc_init_se (&arrayse, NULL);
6484 821 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6485 821 : arrayse.ss = arrayss;
6486 821 : gfc_conv_expr_val (&arrayse, arrayexpr);
6487 821 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6488 821 : gfc_add_block_to_block (&block, &arrayse.pre);
6489 :
6490 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6491 : signed zeros. */
6492 821 : if (HONOR_NANS (DECL_MODE (limit)))
6493 : {
6494 821 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6495 : arrayse.expr, limit);
6496 821 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6497 821 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6498 : build_empty_stmt (input_location));
6499 821 : gfc_add_expr_to_block (&block, tmp);
6500 : }
6501 : else
6502 : {
6503 0 : tmp = fold_build2_loc (input_location,
6504 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6505 : type, arrayse.expr, limit);
6506 0 : gfc_add_modify (&block, limit, tmp);
6507 : }
6508 :
6509 821 : gfc_add_block_to_block (&block, &arrayse.post);
6510 :
6511 821 : tmp = gfc_finish_block (&block);
6512 821 : if (maskss)
6513 : /* We enclose the above in if (mask) {...}. */
6514 : {
6515 348 : tree ifmask;
6516 348 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6517 348 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6518 : build_empty_stmt (input_location));
6519 : }
6520 :
6521 821 : gfc_add_expr_to_block (&body, tmp);
6522 : /* Avoid initializing loopvar[0] again, it should be left where
6523 : it finished by the first loop. */
6524 821 : loop.from[0] = loop.loopvar[0];
6525 : }
6526 2231 : gfc_trans_scalarizing_loops (&loop, &body);
6527 :
6528 2231 : if (fast)
6529 : {
6530 420 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6531 : nan_cst, huge_cst);
6532 420 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6533 420 : tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6534 : ifbody);
6535 420 : gfc_add_expr_to_block (&loop.pre, tmp);
6536 : }
6537 1811 : else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6538 : {
6539 0 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6540 : huge_cst);
6541 0 : gfc_add_modify (&loop.pre, limit, tmp);
6542 : }
6543 :
6544 : /* For a scalar mask, enclose the loop in an if statement. */
6545 2231 : if (maskexpr && maskss == NULL)
6546 : {
6547 546 : tree else_stmt;
6548 546 : tree ifmask;
6549 :
6550 546 : gfc_init_se (&maskse, NULL);
6551 546 : gfc_conv_expr_val (&maskse, maskexpr);
6552 546 : gfc_init_block (&block);
6553 546 : gfc_add_block_to_block (&block, &loop.pre);
6554 546 : gfc_add_block_to_block (&block, &loop.post);
6555 546 : tmp = gfc_finish_block (&block);
6556 :
6557 546 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6558 354 : else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6559 : else
6560 192 : else_stmt = build_empty_stmt (input_location);
6561 :
6562 546 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6563 546 : tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6564 546 : gfc_add_expr_to_block (&block, tmp);
6565 546 : gfc_add_block_to_block (&se->pre, &block);
6566 : }
6567 : else
6568 : {
6569 1685 : gfc_add_block_to_block (&se->pre, &loop.pre);
6570 1685 : gfc_add_block_to_block (&se->pre, &loop.post);
6571 : }
6572 :
6573 2231 : gfc_cleanup_loop (&loop);
6574 :
6575 2231 : se->expr = limit;
6576 : }
6577 :
6578 : /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6579 : static void
6580 145 : gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6581 : {
6582 145 : tree args[2];
6583 145 : tree type;
6584 145 : tree tmp;
6585 :
6586 145 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6587 145 : type = TREE_TYPE (args[0]);
6588 :
6589 : /* Optionally generate code for runtime argument check. */
6590 145 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6591 : {
6592 6 : tree below = fold_build2_loc (input_location, LT_EXPR,
6593 : logical_type_node, args[1],
6594 6 : build_int_cst (TREE_TYPE (args[1]), 0));
6595 6 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6596 6 : tree above = fold_build2_loc (input_location, GE_EXPR,
6597 : logical_type_node, args[1], nbits);
6598 6 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6599 : logical_type_node, below, above);
6600 6 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6601 : "POS argument (%ld) out of range 0:%ld "
6602 : "in intrinsic BTEST",
6603 : fold_convert (long_integer_type_node, args[1]),
6604 : fold_convert (long_integer_type_node, nbits));
6605 : }
6606 :
6607 145 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6608 : build_int_cst (type, 1), args[1]);
6609 145 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6610 145 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6611 : build_int_cst (type, 0));
6612 145 : type = gfc_typenode_for_spec (&expr->ts);
6613 145 : se->expr = convert (type, tmp);
6614 145 : }
6615 :
6616 :
6617 : /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6618 : static void
6619 216 : gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6620 : {
6621 216 : tree args[2];
6622 :
6623 216 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6624 :
6625 : /* Convert both arguments to the unsigned type of the same size. */
6626 216 : args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6627 216 : args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6628 :
6629 : /* If they have unequal type size, convert to the larger one. */
6630 216 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
6631 216 : > TYPE_PRECISION (TREE_TYPE (args[1])))
6632 0 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6633 216 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6634 216 : > TYPE_PRECISION (TREE_TYPE (args[0])))
6635 0 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6636 :
6637 : /* Now, we compare them. */
6638 216 : se->expr = fold_build2_loc (input_location, op, logical_type_node,
6639 : args[0], args[1]);
6640 216 : }
6641 :
6642 :
6643 : /* Generate code to perform the specified operation. */
6644 : static void
6645 1915 : gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6646 : {
6647 1915 : tree args[2];
6648 :
6649 1915 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6650 1915 : se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6651 : args[0], args[1]);
6652 1915 : }
6653 :
6654 : /* Bitwise not. */
6655 : static void
6656 230 : gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6657 : {
6658 230 : tree arg;
6659 :
6660 230 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6661 230 : se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6662 230 : TREE_TYPE (arg), arg);
6663 230 : }
6664 :
6665 :
6666 : /* Generate code for OUT_OF_RANGE. */
6667 : static void
6668 468 : gfc_conv_intrinsic_out_of_range (gfc_se * se, gfc_expr * expr)
6669 : {
6670 468 : tree *args;
6671 468 : tree type;
6672 468 : tree tmp = NULL_TREE, tmp1, tmp2;
6673 468 : unsigned int num_args;
6674 468 : int k;
6675 468 : gfc_se rnd_se;
6676 468 : gfc_actual_arglist *arg = expr->value.function.actual;
6677 468 : gfc_expr *x = arg->expr;
6678 468 : gfc_expr *mold = arg->next->expr;
6679 :
6680 468 : num_args = gfc_intrinsic_argument_list_length (expr);
6681 468 : args = XALLOCAVEC (tree, num_args);
6682 :
6683 468 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6684 :
6685 468 : gfc_init_se (&rnd_se, NULL);
6686 :
6687 468 : if (num_args == 3)
6688 : {
6689 : /* The ROUND argument is optional and shall appear only if X is
6690 : of type real and MOLD is of type integer (see edit F23/004). */
6691 270 : gfc_expr *round = arg->next->next->expr;
6692 270 : gfc_conv_expr (&rnd_se, round);
6693 :
6694 270 : if (round->expr_type == EXPR_VARIABLE
6695 198 : && round->symtree->n.sym->attr.dummy
6696 30 : && round->symtree->n.sym->attr.optional)
6697 : {
6698 30 : tree present = gfc_conv_expr_present (round->symtree->n.sym);
6699 30 : rnd_se.expr = build3_loc (input_location, COND_EXPR,
6700 : logical_type_node, present,
6701 : rnd_se.expr, logical_false_node);
6702 30 : gfc_add_block_to_block (&se->pre, &rnd_se.pre);
6703 : }
6704 : }
6705 : else
6706 : {
6707 : /* If ROUND is absent, it is equivalent to having the value false. */
6708 198 : rnd_se.expr = logical_false_node;
6709 : }
6710 :
6711 468 : type = TREE_TYPE (args[0]);
6712 468 : k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
6713 :
6714 468 : switch (x->ts.type)
6715 : {
6716 378 : case BT_REAL:
6717 : /* X may be IEEE infinity or NaN, but the representation of MOLD may not
6718 : support infinity or NaN. */
6719 378 : tree finite;
6720 378 : finite = build_call_expr_loc (input_location,
6721 : builtin_decl_explicit (BUILT_IN_ISFINITE),
6722 : 1, args[0]);
6723 378 : finite = convert (logical_type_node, finite);
6724 :
6725 378 : if (mold->ts.type == BT_REAL)
6726 : {
6727 24 : tmp1 = build1 (ABS_EXPR, type, args[0]);
6728 24 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6729 : mold->ts.kind, 0);
6730 24 : tmp = build2 (GT_EXPR, logical_type_node, tmp1,
6731 : convert (type, tmp2));
6732 :
6733 : /* Check if MOLD representation supports infinity or NaN. */
6734 24 : bool infnan = (HONOR_INFINITIES (TREE_TYPE (args[1]))
6735 24 : || HONOR_NANS (TREE_TYPE (args[1])));
6736 24 : tmp = build3 (COND_EXPR, logical_type_node, finite, tmp,
6737 : infnan ? logical_false_node : logical_true_node);
6738 : }
6739 : else
6740 : {
6741 354 : tree rounded;
6742 354 : tree decl;
6743 :
6744 354 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, x->ts.kind);
6745 354 : gcc_assert (decl != NULL_TREE);
6746 :
6747 : /* Round or truncate argument X, depending on the optional argument
6748 : ROUND (default: .false.). */
6749 354 : tmp1 = build_round_expr (args[0], type);
6750 354 : tmp2 = build_call_expr_loc (input_location, decl, 1, args[0]);
6751 354 : rounded = build3 (COND_EXPR, type, rnd_se.expr, tmp1, tmp2);
6752 :
6753 354 : if (mold->ts.type == BT_INTEGER)
6754 : {
6755 180 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6756 : x->ts.kind);
6757 180 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6758 : x->ts.kind);
6759 : }
6760 174 : else if (mold->ts.type == BT_UNSIGNED)
6761 : {
6762 174 : tmp1 = build_real_from_int_cst (type, integer_zero_node);
6763 174 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6764 : x->ts.kind);
6765 : }
6766 : else
6767 0 : gcc_unreachable ();
6768 :
6769 354 : tmp1 = build2 (LT_EXPR, logical_type_node, rounded,
6770 : convert (type, tmp1));
6771 354 : tmp2 = build2 (GT_EXPR, logical_type_node, rounded,
6772 : convert (type, tmp2));
6773 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6774 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node,
6775 : build1 (TRUTH_NOT_EXPR, logical_type_node, finite),
6776 : tmp);
6777 : }
6778 : break;
6779 :
6780 48 : case BT_INTEGER:
6781 48 : if (mold->ts.type == BT_INTEGER)
6782 : {
6783 12 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6784 : x->ts.kind);
6785 12 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6786 : x->ts.kind);
6787 12 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6788 : convert (type, tmp1));
6789 12 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6790 : convert (type, tmp2));
6791 12 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6792 : }
6793 36 : else if (mold->ts.type == BT_UNSIGNED)
6794 : {
6795 36 : int i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6796 36 : tmp = build_int_cst (type, 0);
6797 36 : tmp = build2 (LT_EXPR, logical_type_node, args[0], tmp);
6798 36 : if (mpz_cmp (gfc_integer_kinds[i].huge,
6799 36 : gfc_unsigned_kinds[k].huge) > 0)
6800 : {
6801 0 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6802 : x->ts.kind);
6803 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6804 : convert (type, tmp2));
6805 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp, tmp2);
6806 : }
6807 : }
6808 0 : else if (mold->ts.type == BT_REAL)
6809 : {
6810 0 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6811 : mold->ts.kind, 0);
6812 0 : tmp1 = build1 (NEGATE_EXPR, TREE_TYPE (tmp2), tmp2);
6813 0 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6814 : convert (type, tmp1));
6815 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6816 : convert (type, tmp2));
6817 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6818 : }
6819 : else
6820 0 : gcc_unreachable ();
6821 : break;
6822 :
6823 42 : case BT_UNSIGNED:
6824 42 : if (mold->ts.type == BT_UNSIGNED)
6825 : {
6826 12 : tmp = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6827 : x->ts.kind);
6828 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6829 : convert (type, tmp));
6830 : }
6831 30 : else if (mold->ts.type == BT_INTEGER)
6832 : {
6833 18 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6834 : x->ts.kind);
6835 18 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6836 : convert (type, tmp));
6837 : }
6838 12 : else if (mold->ts.type == BT_REAL)
6839 : {
6840 12 : tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6841 : mold->ts.kind, 0);
6842 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6843 : convert (type, tmp));
6844 : }
6845 : else
6846 0 : gcc_unreachable ();
6847 : break;
6848 :
6849 0 : default:
6850 0 : gcc_unreachable ();
6851 : }
6852 :
6853 468 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6854 468 : }
6855 :
6856 :
6857 : /* Set or clear a single bit. */
6858 : static void
6859 306 : gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6860 : {
6861 306 : tree args[2];
6862 306 : tree type;
6863 306 : tree tmp;
6864 306 : enum tree_code op;
6865 :
6866 306 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6867 306 : type = TREE_TYPE (args[0]);
6868 :
6869 : /* Optionally generate code for runtime argument check. */
6870 306 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6871 : {
6872 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6873 : logical_type_node, args[1],
6874 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6875 12 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6876 12 : tree above = fold_build2_loc (input_location, GE_EXPR,
6877 : logical_type_node, args[1], nbits);
6878 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6879 : logical_type_node, below, above);
6880 12 : size_t len_name = strlen (expr->value.function.isym->name);
6881 12 : char *name = XALLOCAVEC (char, len_name + 1);
6882 72 : for (size_t i = 0; i < len_name; i++)
6883 60 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
6884 12 : name[len_name] = '\0';
6885 12 : tree iname = gfc_build_addr_expr (pchar_type_node,
6886 : gfc_build_cstring_const (name));
6887 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6888 : "POS argument (%ld) out of range 0:%ld "
6889 : "in intrinsic %s",
6890 : fold_convert (long_integer_type_node, args[1]),
6891 : fold_convert (long_integer_type_node, nbits),
6892 : iname);
6893 : }
6894 :
6895 306 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6896 : build_int_cst (type, 1), args[1]);
6897 306 : if (set)
6898 : op = BIT_IOR_EXPR;
6899 : else
6900 : {
6901 168 : op = BIT_AND_EXPR;
6902 168 : tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6903 : }
6904 306 : se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6905 306 : }
6906 :
6907 : /* Extract a sequence of bits.
6908 : IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6909 : static void
6910 27 : gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6911 : {
6912 27 : tree args[3];
6913 27 : tree type;
6914 27 : tree tmp;
6915 27 : tree mask;
6916 27 : tree num_bits, cond;
6917 :
6918 27 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
6919 27 : type = TREE_TYPE (args[0]);
6920 :
6921 : /* Optionally generate code for runtime argument check. */
6922 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6923 : {
6924 12 : tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6925 12 : tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6926 12 : tree nbits = build_int_cst (long_integer_type_node,
6927 12 : TYPE_PRECISION (type));
6928 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6929 : logical_type_node, args[1],
6930 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6931 12 : tree above = fold_build2_loc (input_location, GT_EXPR,
6932 : logical_type_node, tmp1, nbits);
6933 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6934 : logical_type_node, below, above);
6935 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6936 : "POS argument (%ld) out of range 0:%ld "
6937 : "in intrinsic IBITS", tmp1, nbits);
6938 12 : below = fold_build2_loc (input_location, LT_EXPR,
6939 : logical_type_node, args[2],
6940 12 : build_int_cst (TREE_TYPE (args[2]), 0));
6941 12 : above = fold_build2_loc (input_location, GT_EXPR,
6942 : logical_type_node, tmp2, nbits);
6943 12 : scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6944 : logical_type_node, below, above);
6945 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6946 : "LEN argument (%ld) out of range 0:%ld "
6947 : "in intrinsic IBITS", tmp2, nbits);
6948 12 : above = fold_build2_loc (input_location, PLUS_EXPR,
6949 : long_integer_type_node, tmp1, tmp2);
6950 12 : scond = fold_build2_loc (input_location, GT_EXPR,
6951 : logical_type_node, above, nbits);
6952 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6953 : "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6954 : "in intrinsic IBITS", tmp1, tmp2, nbits);
6955 : }
6956 :
6957 : /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6958 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6959 : special case. See also gfc_conv_intrinsic_ishft (). */
6960 27 : num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
6961 :
6962 27 : mask = build_int_cst (type, -1);
6963 27 : mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6964 27 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
6965 : num_bits);
6966 27 : mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
6967 : build_int_cst (type, 0), mask);
6968 27 : mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6969 :
6970 27 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6971 :
6972 27 : se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6973 27 : }
6974 :
6975 : static void
6976 492 : gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6977 : bool arithmetic)
6978 : {
6979 492 : tree args[2], type, num_bits, cond;
6980 492 : tree bigshift;
6981 492 : bool do_convert = false;
6982 :
6983 492 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6984 :
6985 492 : args[0] = gfc_evaluate_now (args[0], &se->pre);
6986 492 : args[1] = gfc_evaluate_now (args[1], &se->pre);
6987 492 : type = TREE_TYPE (args[0]);
6988 :
6989 492 : if (!arithmetic)
6990 : {
6991 390 : args[0] = fold_convert (unsigned_type_for (type), args[0]);
6992 390 : do_convert = true;
6993 : }
6994 : else
6995 102 : gcc_assert (right_shift);
6996 :
6997 492 : if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED)
6998 : {
6999 30 : do_convert = true;
7000 30 : args[0] = fold_convert (signed_type_for (type), args[0]);
7001 : }
7002 :
7003 816 : se->expr = fold_build2_loc (input_location,
7004 : right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
7005 492 : TREE_TYPE (args[0]), args[0], args[1]);
7006 :
7007 492 : if (do_convert)
7008 420 : se->expr = fold_convert (type, se->expr);
7009 :
7010 492 : if (!arithmetic)
7011 390 : bigshift = build_int_cst (type, 0);
7012 : else
7013 : {
7014 102 : tree nonneg = fold_build2_loc (input_location, GE_EXPR,
7015 : logical_type_node, args[0],
7016 102 : build_int_cst (TREE_TYPE (args[0]), 0));
7017 102 : bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
7018 : build_int_cst (type, 0),
7019 : build_int_cst (type, -1));
7020 : }
7021 :
7022 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7023 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7024 : special case. */
7025 492 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7026 :
7027 : /* Optionally generate code for runtime argument check. */
7028 492 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7029 : {
7030 30 : tree below = fold_build2_loc (input_location, LT_EXPR,
7031 : logical_type_node, args[1],
7032 30 : build_int_cst (TREE_TYPE (args[1]), 0));
7033 30 : tree above = fold_build2_loc (input_location, GT_EXPR,
7034 : logical_type_node, args[1], num_bits);
7035 30 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7036 : logical_type_node, below, above);
7037 30 : size_t len_name = strlen (expr->value.function.isym->name);
7038 30 : char *name = XALLOCAVEC (char, len_name + 1);
7039 210 : for (size_t i = 0; i < len_name; i++)
7040 180 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
7041 30 : name[len_name] = '\0';
7042 30 : tree iname = gfc_build_addr_expr (pchar_type_node,
7043 : gfc_build_cstring_const (name));
7044 30 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7045 : "SHIFT argument (%ld) out of range 0:%ld "
7046 : "in intrinsic %s",
7047 : fold_convert (long_integer_type_node, args[1]),
7048 : fold_convert (long_integer_type_node, num_bits),
7049 : iname);
7050 : }
7051 :
7052 492 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7053 : args[1], num_bits);
7054 :
7055 492 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7056 : bigshift, se->expr);
7057 492 : }
7058 :
7059 : /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
7060 : ? 0
7061 : : ((shift >= 0) ? i << shift : i >> -shift)
7062 : where all shifts are logical shifts. */
7063 : static void
7064 318 : gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
7065 : {
7066 318 : tree args[2];
7067 318 : tree type;
7068 318 : tree utype;
7069 318 : tree tmp;
7070 318 : tree width;
7071 318 : tree num_bits;
7072 318 : tree cond;
7073 318 : tree lshift;
7074 318 : tree rshift;
7075 :
7076 318 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7077 :
7078 318 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7079 318 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7080 :
7081 318 : type = TREE_TYPE (args[0]);
7082 318 : utype = unsigned_type_for (type);
7083 :
7084 318 : width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
7085 : args[1]);
7086 :
7087 : /* Left shift if positive. */
7088 318 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
7089 :
7090 : /* Right shift if negative.
7091 : We convert to an unsigned type because we want a logical shift.
7092 : The standard doesn't define the case of shifting negative
7093 : numbers, and we try to be compatible with other compilers, most
7094 : notably g77, here. */
7095 318 : rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
7096 : utype, convert (utype, args[0]), width));
7097 :
7098 318 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
7099 318 : build_int_cst (TREE_TYPE (args[1]), 0));
7100 318 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
7101 :
7102 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7103 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7104 : special case. */
7105 318 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7106 :
7107 : /* Optionally generate code for runtime argument check. */
7108 318 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7109 : {
7110 24 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7111 : logical_type_node, width, num_bits);
7112 24 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7113 : "SHIFT argument (%ld) out of range -%ld:%ld "
7114 : "in intrinsic ISHFT",
7115 : fold_convert (long_integer_type_node, args[1]),
7116 : fold_convert (long_integer_type_node, num_bits),
7117 : fold_convert (long_integer_type_node, num_bits));
7118 : }
7119 :
7120 318 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
7121 : num_bits);
7122 318 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7123 : build_int_cst (type, 0), tmp);
7124 318 : }
7125 :
7126 :
7127 : /* Circular shift. AKA rotate or barrel shift. */
7128 :
7129 : static void
7130 658 : gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
7131 : {
7132 658 : tree *args;
7133 658 : tree type;
7134 658 : tree tmp;
7135 658 : tree lrot;
7136 658 : tree rrot;
7137 658 : tree zero;
7138 658 : tree nbits;
7139 658 : unsigned int num_args;
7140 :
7141 658 : num_args = gfc_intrinsic_argument_list_length (expr);
7142 658 : args = XALLOCAVEC (tree, num_args);
7143 :
7144 658 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7145 :
7146 658 : type = TREE_TYPE (args[0]);
7147 658 : nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
7148 :
7149 658 : if (num_args == 3)
7150 : {
7151 550 : gfc_expr *size = expr->value.function.actual->next->next->expr;
7152 :
7153 : /* Use a library function for the 3 parameter version. */
7154 550 : tree int4type = gfc_get_int_type (4);
7155 :
7156 : /* Treat optional SIZE argument when it is passed as an optional
7157 : dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
7158 550 : if (size->expr_type == EXPR_VARIABLE
7159 438 : && size->symtree->n.sym->attr.dummy
7160 36 : && size->symtree->n.sym->attr.optional)
7161 : {
7162 36 : tree type_of_size = TREE_TYPE (args[2]);
7163 72 : args[2] = build3_loc (input_location, COND_EXPR, type_of_size,
7164 36 : gfc_conv_expr_present (size->symtree->n.sym),
7165 : args[2], fold_convert (type_of_size, nbits));
7166 : }
7167 :
7168 : /* We convert the first argument to at least 4 bytes, and
7169 : convert back afterwards. This removes the need for library
7170 : functions for all argument sizes, and function will be
7171 : aligned to at least 32 bits, so there's no loss. */
7172 550 : if (expr->ts.kind < 4)
7173 242 : args[0] = convert (int4type, args[0]);
7174 :
7175 : /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
7176 : need loads of library functions. They cannot have values >
7177 : BIT_SIZE (I) so the conversion is safe. */
7178 550 : args[1] = convert (int4type, args[1]);
7179 550 : args[2] = convert (int4type, args[2]);
7180 :
7181 : /* Optionally generate code for runtime argument check. */
7182 550 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7183 : {
7184 18 : tree size = fold_convert (long_integer_type_node, args[2]);
7185 18 : tree below = fold_build2_loc (input_location, LE_EXPR,
7186 : logical_type_node, size,
7187 18 : build_int_cst (TREE_TYPE (args[1]), 0));
7188 18 : tree above = fold_build2_loc (input_location, GT_EXPR,
7189 : logical_type_node, size, nbits);
7190 18 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7191 : logical_type_node, below, above);
7192 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7193 : "SIZE argument (%ld) out of range 1:%ld "
7194 : "in intrinsic ISHFTC", size, nbits);
7195 18 : tree width = fold_convert (long_integer_type_node, args[1]);
7196 18 : width = fold_build1_loc (input_location, ABS_EXPR,
7197 : long_integer_type_node, width);
7198 18 : scond = fold_build2_loc (input_location, GT_EXPR,
7199 : logical_type_node, width, size);
7200 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7201 : "SHIFT argument (%ld) out of range -%ld:%ld "
7202 : "in intrinsic ISHFTC",
7203 : fold_convert (long_integer_type_node, args[1]),
7204 : size, size);
7205 : }
7206 :
7207 550 : switch (expr->ts.kind)
7208 : {
7209 426 : case 1:
7210 426 : case 2:
7211 426 : case 4:
7212 426 : tmp = gfor_fndecl_math_ishftc4;
7213 426 : break;
7214 124 : case 8:
7215 124 : tmp = gfor_fndecl_math_ishftc8;
7216 124 : break;
7217 0 : case 16:
7218 0 : tmp = gfor_fndecl_math_ishftc16;
7219 0 : break;
7220 0 : default:
7221 0 : gcc_unreachable ();
7222 : }
7223 550 : se->expr = build_call_expr_loc (input_location,
7224 : tmp, 3, args[0], args[1], args[2]);
7225 : /* Convert the result back to the original type, if we extended
7226 : the first argument's width above. */
7227 550 : if (expr->ts.kind < 4)
7228 242 : se->expr = convert (type, se->expr);
7229 :
7230 550 : return;
7231 : }
7232 :
7233 : /* Evaluate arguments only once. */
7234 108 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7235 108 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7236 :
7237 : /* Optionally generate code for runtime argument check. */
7238 108 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7239 : {
7240 12 : tree width = fold_convert (long_integer_type_node, args[1]);
7241 12 : width = fold_build1_loc (input_location, ABS_EXPR,
7242 : long_integer_type_node, width);
7243 12 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7244 : logical_type_node, width, nbits);
7245 12 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7246 : "SHIFT argument (%ld) out of range -%ld:%ld "
7247 : "in intrinsic ISHFTC",
7248 : fold_convert (long_integer_type_node, args[1]),
7249 : nbits, nbits);
7250 : }
7251 :
7252 : /* Rotate left if positive. */
7253 108 : lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
7254 :
7255 : /* Rotate right if negative. */
7256 108 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
7257 : args[1]);
7258 108 : rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
7259 :
7260 108 : zero = build_int_cst (TREE_TYPE (args[1]), 0);
7261 108 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
7262 : zero);
7263 108 : rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
7264 :
7265 : /* Do nothing if shift == 0. */
7266 108 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
7267 : zero);
7268 108 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
7269 : rrot);
7270 : }
7271 :
7272 :
7273 : /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7274 : : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7275 :
7276 : The conditional expression is necessary because the result of LEADZ(0)
7277 : is defined, but the result of __builtin_clz(0) is undefined for most
7278 : targets.
7279 :
7280 : For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7281 : difference in bit size between the argument of LEADZ and the C int. */
7282 :
7283 : static void
7284 270 : gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7285 : {
7286 270 : tree arg;
7287 270 : tree arg_type;
7288 270 : tree cond;
7289 270 : tree result_type;
7290 270 : tree leadz;
7291 270 : tree bit_size;
7292 270 : tree tmp;
7293 270 : tree func;
7294 270 : int s, argsize;
7295 :
7296 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7297 270 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7298 :
7299 : /* Which variant of __builtin_clz* should we call? */
7300 270 : if (argsize <= INT_TYPE_SIZE)
7301 : {
7302 183 : arg_type = unsigned_type_node;
7303 183 : func = builtin_decl_explicit (BUILT_IN_CLZ);
7304 : }
7305 87 : else if (argsize <= LONG_TYPE_SIZE)
7306 : {
7307 57 : arg_type = long_unsigned_type_node;
7308 57 : func = builtin_decl_explicit (BUILT_IN_CLZL);
7309 : }
7310 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7311 : {
7312 0 : arg_type = long_long_unsigned_type_node;
7313 0 : func = builtin_decl_explicit (BUILT_IN_CLZLL);
7314 : }
7315 : else
7316 : {
7317 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7318 30 : arg_type = gfc_build_uint_type (argsize);
7319 30 : func = NULL_TREE;
7320 : }
7321 :
7322 : /* Convert the actual argument twice: first, to the unsigned type of the
7323 : same size; then, to the proper argument type for the built-in
7324 : function. But the return type is of the default INTEGER kind. */
7325 270 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7326 270 : arg = fold_convert (arg_type, arg);
7327 270 : arg = gfc_evaluate_now (arg, &se->pre);
7328 270 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7329 :
7330 : /* Compute LEADZ for the case i .ne. 0. */
7331 270 : if (func)
7332 : {
7333 240 : s = TYPE_PRECISION (arg_type) - argsize;
7334 240 : tmp = fold_convert (result_type,
7335 : build_call_expr_loc (input_location, func,
7336 : 1, arg));
7337 240 : leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7338 240 : tmp, build_int_cst (result_type, s));
7339 : }
7340 : else
7341 : {
7342 : /* We end up here if the argument type is larger than 'long long'.
7343 : We generate this code:
7344 :
7345 : if (x & (ULL_MAX << ULL_SIZE) != 0)
7346 : return clzll ((unsigned long long) (x >> ULLSIZE));
7347 : else
7348 : return ULL_SIZE + clzll ((unsigned long long) x);
7349 : where ULL_MAX is the largest value that a ULL_MAX can hold
7350 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7351 : is the bit-size of the long long type (64 in this example). */
7352 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7353 :
7354 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7355 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7356 : long_long_unsigned_type_node,
7357 : build_int_cst (long_long_unsigned_type_node,
7358 : 0));
7359 :
7360 30 : cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7361 : fold_convert (arg_type, ullmax), ullsize);
7362 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7363 : arg, cond);
7364 30 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7365 : cond, build_int_cst (arg_type, 0));
7366 :
7367 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7368 : arg, ullsize);
7369 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7370 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7371 30 : tmp1 = fold_convert (result_type,
7372 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7373 :
7374 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7375 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7376 30 : tmp2 = fold_convert (result_type,
7377 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7378 30 : tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7379 : tmp2, ullsize);
7380 :
7381 30 : leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7382 : cond, tmp1, tmp2);
7383 : }
7384 :
7385 : /* Build BIT_SIZE. */
7386 270 : bit_size = build_int_cst (result_type, argsize);
7387 :
7388 270 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7389 : arg, build_int_cst (arg_type, 0));
7390 270 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7391 : bit_size, leadz);
7392 270 : }
7393 :
7394 :
7395 : /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7396 :
7397 : The conditional expression is necessary because the result of TRAILZ(0)
7398 : is defined, but the result of __builtin_ctz(0) is undefined for most
7399 : targets. */
7400 :
7401 : static void
7402 282 : gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7403 : {
7404 282 : tree arg;
7405 282 : tree arg_type;
7406 282 : tree cond;
7407 282 : tree result_type;
7408 282 : tree trailz;
7409 282 : tree bit_size;
7410 282 : tree func;
7411 282 : int argsize;
7412 :
7413 282 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7414 282 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7415 :
7416 : /* Which variant of __builtin_ctz* should we call? */
7417 282 : if (argsize <= INT_TYPE_SIZE)
7418 : {
7419 195 : arg_type = unsigned_type_node;
7420 195 : func = builtin_decl_explicit (BUILT_IN_CTZ);
7421 : }
7422 87 : else if (argsize <= LONG_TYPE_SIZE)
7423 : {
7424 57 : arg_type = long_unsigned_type_node;
7425 57 : func = builtin_decl_explicit (BUILT_IN_CTZL);
7426 : }
7427 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7428 : {
7429 0 : arg_type = long_long_unsigned_type_node;
7430 0 : func = builtin_decl_explicit (BUILT_IN_CTZLL);
7431 : }
7432 : else
7433 : {
7434 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7435 30 : arg_type = gfc_build_uint_type (argsize);
7436 30 : func = NULL_TREE;
7437 : }
7438 :
7439 : /* Convert the actual argument twice: first, to the unsigned type of the
7440 : same size; then, to the proper argument type for the built-in
7441 : function. But the return type is of the default INTEGER kind. */
7442 282 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7443 282 : arg = fold_convert (arg_type, arg);
7444 282 : arg = gfc_evaluate_now (arg, &se->pre);
7445 282 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7446 :
7447 : /* Compute TRAILZ for the case i .ne. 0. */
7448 282 : if (func)
7449 252 : trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7450 : func, 1, arg));
7451 : else
7452 : {
7453 : /* We end up here if the argument type is larger than 'long long'.
7454 : We generate this code:
7455 :
7456 : if ((x & ULL_MAX) == 0)
7457 : return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7458 : else
7459 : return ctzll ((unsigned long long) x);
7460 :
7461 : where ULL_MAX is the largest value that a ULL_MAX can hold
7462 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7463 : is the bit-size of the long long type (64 in this example). */
7464 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7465 :
7466 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7467 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7468 : long_long_unsigned_type_node,
7469 : build_int_cst (long_long_unsigned_type_node, 0));
7470 :
7471 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7472 : fold_convert (arg_type, ullmax));
7473 30 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7474 : build_int_cst (arg_type, 0));
7475 :
7476 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7477 : arg, ullsize);
7478 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7479 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7480 30 : tmp1 = fold_convert (result_type,
7481 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7482 30 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7483 : tmp1, ullsize);
7484 :
7485 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7486 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7487 30 : tmp2 = fold_convert (result_type,
7488 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7489 :
7490 30 : trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7491 : cond, tmp1, tmp2);
7492 : }
7493 :
7494 : /* Build BIT_SIZE. */
7495 282 : bit_size = build_int_cst (result_type, argsize);
7496 :
7497 282 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7498 : arg, build_int_cst (arg_type, 0));
7499 282 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7500 : bit_size, trailz);
7501 282 : }
7502 :
7503 : /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7504 : for types larger than "long long", we call the long long built-in for
7505 : the lower and higher bits and combine the result. */
7506 :
7507 : static void
7508 134 : gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7509 : {
7510 134 : tree arg;
7511 134 : tree arg_type;
7512 134 : tree result_type;
7513 134 : tree func;
7514 134 : int argsize;
7515 :
7516 134 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7517 134 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7518 134 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7519 :
7520 : /* Which variant of the builtin should we call? */
7521 134 : if (argsize <= INT_TYPE_SIZE)
7522 : {
7523 108 : arg_type = unsigned_type_node;
7524 198 : func = builtin_decl_explicit (parity
7525 : ? BUILT_IN_PARITY
7526 : : BUILT_IN_POPCOUNT);
7527 : }
7528 26 : else if (argsize <= LONG_TYPE_SIZE)
7529 : {
7530 12 : arg_type = long_unsigned_type_node;
7531 18 : func = builtin_decl_explicit (parity
7532 : ? BUILT_IN_PARITYL
7533 : : BUILT_IN_POPCOUNTL);
7534 : }
7535 14 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7536 : {
7537 0 : arg_type = long_long_unsigned_type_node;
7538 0 : func = builtin_decl_explicit (parity
7539 : ? BUILT_IN_PARITYLL
7540 : : BUILT_IN_POPCOUNTLL);
7541 : }
7542 : else
7543 : {
7544 : /* Our argument type is larger than 'long long', which mean none
7545 : of the POPCOUNT builtins covers it. We thus call the 'long long'
7546 : variant multiple times, and add the results. */
7547 14 : tree utype, arg2, call1, call2;
7548 :
7549 : /* For now, we only cover the case where argsize is twice as large
7550 : as 'long long'. */
7551 14 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7552 :
7553 21 : func = builtin_decl_explicit (parity
7554 : ? BUILT_IN_PARITYLL
7555 : : BUILT_IN_POPCOUNTLL);
7556 :
7557 : /* Convert it to an integer, and store into a variable. */
7558 14 : utype = gfc_build_uint_type (argsize);
7559 14 : arg = fold_convert (utype, arg);
7560 14 : arg = gfc_evaluate_now (arg, &se->pre);
7561 :
7562 : /* Call the builtin twice. */
7563 14 : call1 = build_call_expr_loc (input_location, func, 1,
7564 : fold_convert (long_long_unsigned_type_node,
7565 : arg));
7566 :
7567 14 : arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7568 : build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7569 14 : call2 = build_call_expr_loc (input_location, func, 1,
7570 : fold_convert (long_long_unsigned_type_node,
7571 : arg2));
7572 :
7573 : /* Combine the results. */
7574 14 : if (parity)
7575 7 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7576 : integer_type_node, call1, call2);
7577 : else
7578 7 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7579 : integer_type_node, call1, call2);
7580 :
7581 14 : se->expr = convert (result_type, se->expr);
7582 14 : return;
7583 : }
7584 :
7585 : /* Convert the actual argument twice: first, to the unsigned type of the
7586 : same size; then, to the proper argument type for the built-in
7587 : function. */
7588 120 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7589 120 : arg = fold_convert (arg_type, arg);
7590 :
7591 120 : se->expr = fold_convert (result_type,
7592 : build_call_expr_loc (input_location, func, 1, arg));
7593 : }
7594 :
7595 :
7596 : /* Process an intrinsic with unspecified argument-types that has an optional
7597 : argument (which could be of type character), e.g. EOSHIFT. For those, we
7598 : need to append the string length of the optional argument if it is not
7599 : present and the type is really character.
7600 : primary specifies the position (starting at 1) of the non-optional argument
7601 : specifying the type and optional gives the position of the optional
7602 : argument in the arglist. */
7603 :
7604 : static void
7605 5831 : conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7606 : unsigned primary, unsigned optional)
7607 : {
7608 5831 : gfc_actual_arglist* prim_arg;
7609 5831 : gfc_actual_arglist* opt_arg;
7610 5831 : unsigned cur_pos;
7611 5831 : gfc_actual_arglist* arg;
7612 5831 : gfc_symbol* sym;
7613 5831 : vec<tree, va_gc> *append_args;
7614 :
7615 : /* Find the two arguments given as position. */
7616 5831 : cur_pos = 0;
7617 5831 : prim_arg = NULL;
7618 5831 : opt_arg = NULL;
7619 17493 : for (arg = expr->value.function.actual; arg; arg = arg->next)
7620 : {
7621 17493 : ++cur_pos;
7622 :
7623 17493 : if (cur_pos == primary)
7624 5831 : prim_arg = arg;
7625 17493 : if (cur_pos == optional)
7626 5831 : opt_arg = arg;
7627 :
7628 17493 : if (cur_pos >= primary && cur_pos >= optional)
7629 : break;
7630 : }
7631 5831 : gcc_assert (prim_arg);
7632 5831 : gcc_assert (prim_arg->expr);
7633 5831 : gcc_assert (opt_arg);
7634 :
7635 : /* If we do have type CHARACTER and the optional argument is really absent,
7636 : append a dummy 0 as string length. */
7637 5831 : append_args = NULL;
7638 5831 : if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7639 : {
7640 608 : tree dummy;
7641 :
7642 608 : dummy = build_int_cst (gfc_charlen_type_node, 0);
7643 608 : vec_alloc (append_args, 1);
7644 608 : append_args->quick_push (dummy);
7645 : }
7646 :
7647 : /* Build the call itself. */
7648 5831 : gcc_assert (!se->ignore_optional);
7649 5831 : sym = gfc_get_symbol_for_expr (expr, false);
7650 5831 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7651 : append_args);
7652 5831 : gfc_free_symbol (sym);
7653 5831 : }
7654 :
7655 : /* The length of a character string. */
7656 : static void
7657 5855 : gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7658 : {
7659 5855 : tree len;
7660 5855 : tree type;
7661 5855 : tree decl;
7662 5855 : gfc_symbol *sym;
7663 5855 : gfc_se argse;
7664 5855 : gfc_expr *arg;
7665 :
7666 5855 : gcc_assert (!se->ss);
7667 :
7668 5855 : arg = expr->value.function.actual->expr;
7669 :
7670 5855 : type = gfc_typenode_for_spec (&expr->ts);
7671 5855 : switch (arg->expr_type)
7672 : {
7673 0 : case EXPR_CONSTANT:
7674 0 : len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7675 0 : break;
7676 :
7677 2 : case EXPR_ARRAY:
7678 : /* If there is an explicit type-spec, use it. */
7679 2 : if (arg->ts.u.cl->length && arg->ts.u.cl->length_from_typespec)
7680 : {
7681 0 : gfc_conv_string_length (arg->ts.u.cl, arg, &se->pre);
7682 0 : len = arg->ts.u.cl->backend_decl;
7683 0 : break;
7684 : }
7685 :
7686 : /* Obtain the string length from the function used by
7687 : trans-array.cc(gfc_trans_array_constructor). */
7688 2 : len = NULL_TREE;
7689 2 : get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7690 2 : break;
7691 :
7692 5268 : case EXPR_VARIABLE:
7693 5268 : if (arg->ref == NULL
7694 2385 : || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7695 : {
7696 : /* This doesn't catch all cases.
7697 : See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7698 : and the surrounding thread. */
7699 4736 : sym = arg->symtree->n.sym;
7700 4736 : decl = gfc_get_symbol_decl (sym);
7701 4736 : if (decl == current_function_decl && sym->attr.function
7702 55 : && (sym->result == sym))
7703 55 : decl = gfc_get_fake_result_decl (sym, 0);
7704 :
7705 4736 : len = sym->ts.u.cl->backend_decl;
7706 4736 : gcc_assert (len);
7707 : break;
7708 : }
7709 :
7710 : /* Fall through. */
7711 :
7712 1117 : default:
7713 1117 : gfc_init_se (&argse, se);
7714 1117 : if (arg->rank == 0)
7715 995 : gfc_conv_expr (&argse, arg);
7716 : else
7717 122 : gfc_conv_expr_descriptor (&argse, arg);
7718 1117 : gfc_add_block_to_block (&se->pre, &argse.pre);
7719 1117 : gfc_add_block_to_block (&se->post, &argse.post);
7720 1117 : len = argse.string_length;
7721 1117 : break;
7722 : }
7723 5855 : se->expr = convert (type, len);
7724 5855 : }
7725 :
7726 : /* The length of a character string not including trailing blanks. */
7727 : static void
7728 2335 : gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7729 : {
7730 2335 : int kind = expr->value.function.actual->expr->ts.kind;
7731 2335 : tree args[2], type, fndecl;
7732 :
7733 2335 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7734 2335 : type = gfc_typenode_for_spec (&expr->ts);
7735 :
7736 2335 : if (kind == 1)
7737 1933 : fndecl = gfor_fndecl_string_len_trim;
7738 402 : else if (kind == 4)
7739 402 : fndecl = gfor_fndecl_string_len_trim_char4;
7740 : else
7741 0 : gcc_unreachable ();
7742 :
7743 2335 : se->expr = build_call_expr_loc (input_location,
7744 : fndecl, 2, args[0], args[1]);
7745 2335 : se->expr = convert (type, se->expr);
7746 2335 : }
7747 :
7748 :
7749 : /* Returns the starting position of a substring within a string. */
7750 :
7751 : static void
7752 751 : gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7753 : tree function)
7754 : {
7755 751 : tree logical4_type_node = gfc_get_logical_type (4);
7756 751 : tree type;
7757 751 : tree fndecl;
7758 751 : tree *args;
7759 751 : unsigned int num_args;
7760 :
7761 751 : args = XALLOCAVEC (tree, 5);
7762 :
7763 : /* Get number of arguments; characters count double due to the
7764 : string length argument. Kind= is not passed to the library
7765 : and thus ignored. */
7766 751 : if (expr->value.function.actual->next->next->expr == NULL)
7767 : num_args = 4;
7768 : else
7769 304 : num_args = 5;
7770 :
7771 751 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7772 751 : type = gfc_typenode_for_spec (&expr->ts);
7773 :
7774 751 : if (num_args == 4)
7775 447 : args[4] = build_int_cst (logical4_type_node, 0);
7776 : else
7777 304 : args[4] = convert (logical4_type_node, args[4]);
7778 :
7779 751 : fndecl = build_addr (function);
7780 751 : se->expr = build_call_array_loc (input_location,
7781 751 : TREE_TYPE (TREE_TYPE (function)), fndecl,
7782 : 5, args);
7783 751 : se->expr = convert (type, se->expr);
7784 :
7785 751 : }
7786 :
7787 : /* The ascii value for a single character. */
7788 : static void
7789 2033 : gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7790 : {
7791 2033 : tree args[3], type, pchartype;
7792 2033 : int nargs;
7793 :
7794 2033 : nargs = gfc_intrinsic_argument_list_length (expr);
7795 2033 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7796 2033 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7797 2033 : pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7798 2033 : args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7799 2033 : type = gfc_typenode_for_spec (&expr->ts);
7800 :
7801 2033 : se->expr = build_fold_indirect_ref_loc (input_location,
7802 : args[1]);
7803 2033 : se->expr = convert (type, se->expr);
7804 2033 : }
7805 :
7806 :
7807 : /* Intrinsic ISNAN calls __builtin_isnan. */
7808 :
7809 : static void
7810 432 : gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7811 : {
7812 432 : tree arg;
7813 :
7814 432 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7815 432 : se->expr = build_call_expr_loc (input_location,
7816 : builtin_decl_explicit (BUILT_IN_ISNAN),
7817 : 1, arg);
7818 864 : STRIP_TYPE_NOPS (se->expr);
7819 432 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7820 432 : }
7821 :
7822 :
7823 : /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7824 : their argument against a constant integer value. */
7825 :
7826 : static void
7827 24 : gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7828 : {
7829 24 : tree arg;
7830 :
7831 24 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7832 24 : se->expr = fold_build2_loc (input_location, EQ_EXPR,
7833 : gfc_typenode_for_spec (&expr->ts),
7834 24 : arg, build_int_cst (TREE_TYPE (arg), value));
7835 24 : }
7836 :
7837 :
7838 :
7839 : /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7840 :
7841 : static void
7842 949 : gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7843 : {
7844 949 : tree tsource;
7845 949 : tree fsource;
7846 949 : tree mask;
7847 949 : tree type;
7848 949 : tree len, len2;
7849 949 : tree *args;
7850 949 : unsigned int num_args;
7851 :
7852 949 : num_args = gfc_intrinsic_argument_list_length (expr);
7853 949 : args = XALLOCAVEC (tree, num_args);
7854 :
7855 949 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7856 949 : if (expr->ts.type != BT_CHARACTER)
7857 : {
7858 422 : tsource = args[0];
7859 422 : fsource = args[1];
7860 422 : mask = args[2];
7861 : }
7862 : else
7863 : {
7864 : /* We do the same as in the non-character case, but the argument
7865 : list is different because of the string length arguments. We
7866 : also have to set the string length for the result. */
7867 527 : len = args[0];
7868 527 : tsource = args[1];
7869 527 : len2 = args[2];
7870 527 : fsource = args[3];
7871 527 : mask = args[4];
7872 :
7873 527 : gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7874 : &se->pre);
7875 527 : se->string_length = len;
7876 : }
7877 949 : tsource = gfc_evaluate_now (tsource, &se->pre);
7878 949 : fsource = gfc_evaluate_now (fsource, &se->pre);
7879 949 : mask = gfc_evaluate_now (mask, &se->pre);
7880 949 : type = TREE_TYPE (tsource);
7881 949 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7882 : fold_convert (type, fsource));
7883 949 : }
7884 :
7885 :
7886 : /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7887 :
7888 : static void
7889 42 : gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7890 : {
7891 42 : tree args[3], mask, type;
7892 :
7893 42 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
7894 42 : mask = gfc_evaluate_now (args[2], &se->pre);
7895 :
7896 42 : type = TREE_TYPE (args[0]);
7897 42 : gcc_assert (TREE_TYPE (args[1]) == type);
7898 42 : gcc_assert (TREE_TYPE (mask) == type);
7899 :
7900 42 : args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7901 42 : args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7902 : fold_build1_loc (input_location, BIT_NOT_EXPR,
7903 : type, mask));
7904 42 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7905 : args[0], args[1]);
7906 42 : }
7907 :
7908 :
7909 : /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7910 : MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7911 :
7912 : static void
7913 64 : gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7914 : {
7915 64 : tree arg, allones, type, utype, res, cond, bitsize;
7916 64 : int i;
7917 :
7918 64 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7919 64 : arg = gfc_evaluate_now (arg, &se->pre);
7920 :
7921 64 : type = gfc_get_int_type (expr->ts.kind);
7922 64 : utype = unsigned_type_for (type);
7923 :
7924 64 : i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7925 64 : bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7926 :
7927 64 : allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7928 : build_int_cst (utype, 0));
7929 :
7930 64 : if (left)
7931 : {
7932 : /* Left-justified mask. */
7933 32 : res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7934 : bitsize, arg);
7935 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7936 : fold_convert (utype, res));
7937 :
7938 : /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7939 : smaller than type width. */
7940 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7941 32 : build_int_cst (TREE_TYPE (arg), 0));
7942 32 : res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7943 : build_int_cst (utype, 0), res);
7944 : }
7945 : else
7946 : {
7947 : /* Right-justified mask. */
7948 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7949 : fold_convert (utype, arg));
7950 32 : res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7951 :
7952 : /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7953 : strictly smaller than type width. */
7954 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7955 : arg, bitsize);
7956 32 : res = fold_build3_loc (input_location, COND_EXPR, utype,
7957 : cond, allones, res);
7958 : }
7959 :
7960 64 : se->expr = fold_convert (type, res);
7961 64 : }
7962 :
7963 :
7964 : /* FRACTION (s) is translated into:
7965 : isfinite (s) ? frexp (s, &dummy_int) : NaN */
7966 : static void
7967 60 : gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7968 : {
7969 60 : tree arg, type, tmp, res, frexp, cond;
7970 :
7971 60 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7972 :
7973 60 : type = gfc_typenode_for_spec (&expr->ts);
7974 60 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7975 60 : arg = gfc_evaluate_now (arg, &se->pre);
7976 :
7977 60 : cond = build_call_expr_loc (input_location,
7978 : builtin_decl_explicit (BUILT_IN_ISFINITE),
7979 : 1, arg);
7980 :
7981 60 : tmp = gfc_create_var (integer_type_node, NULL);
7982 60 : res = build_call_expr_loc (input_location, frexp, 2,
7983 : fold_convert (type, arg),
7984 : gfc_build_addr_expr (NULL_TREE, tmp));
7985 60 : res = fold_convert (type, res);
7986 :
7987 60 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7988 : cond, res, gfc_build_nan (type, ""));
7989 60 : }
7990 :
7991 :
7992 : /* NEAREST (s, dir) is translated into
7993 : tmp = copysign (HUGE_VAL, dir);
7994 : return nextafter (s, tmp);
7995 : */
7996 : static void
7997 1595 : gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
7998 : {
7999 1595 : tree args[2], type, tmp, nextafter, copysign, huge_val;
8000 :
8001 1595 : nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
8002 1595 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
8003 :
8004 1595 : type = gfc_typenode_for_spec (&expr->ts);
8005 1595 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8006 :
8007 1595 : huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
8008 1595 : tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
8009 : fold_convert (type, args[1]));
8010 1595 : se->expr = build_call_expr_loc (input_location, nextafter, 2,
8011 : fold_convert (type, args[0]), tmp);
8012 1595 : se->expr = fold_convert (type, se->expr);
8013 1595 : }
8014 :
8015 :
8016 : /* SPACING (s) is translated into
8017 : int e;
8018 : if (!isfinite (s))
8019 : res = NaN;
8020 : else if (s == 0)
8021 : res = tiny;
8022 : else
8023 : {
8024 : frexp (s, &e);
8025 : e = e - prec;
8026 : e = MAX_EXPR (e, emin);
8027 : res = scalbn (1., e);
8028 : }
8029 : return res;
8030 :
8031 : where prec is the precision of s, gfc_real_kinds[k].digits,
8032 : emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
8033 : and tiny is tiny(s), gfc_real_kinds[k].tiny. */
8034 :
8035 : static void
8036 70 : gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
8037 : {
8038 70 : tree arg, type, prec, emin, tiny, res, e;
8039 70 : tree cond, nan, tmp, frexp, scalbn;
8040 70 : int k;
8041 70 : stmtblock_t block;
8042 :
8043 70 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8044 70 : prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
8045 70 : emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
8046 70 : tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
8047 :
8048 70 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8049 70 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8050 :
8051 70 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8052 70 : arg = gfc_evaluate_now (arg, &se->pre);
8053 :
8054 70 : type = gfc_typenode_for_spec (&expr->ts);
8055 70 : e = gfc_create_var (integer_type_node, NULL);
8056 70 : res = gfc_create_var (type, NULL);
8057 :
8058 :
8059 : /* Build the block for s /= 0. */
8060 70 : gfc_start_block (&block);
8061 70 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8062 : gfc_build_addr_expr (NULL_TREE, e));
8063 70 : gfc_add_expr_to_block (&block, tmp);
8064 :
8065 70 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
8066 : prec);
8067 70 : gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
8068 : integer_type_node, tmp, emin));
8069 :
8070 70 : tmp = build_call_expr_loc (input_location, scalbn, 2,
8071 70 : build_real_from_int_cst (type, integer_one_node), e);
8072 70 : gfc_add_modify (&block, res, tmp);
8073 :
8074 : /* Finish by building the IF statement for value zero. */
8075 70 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8076 70 : build_real_from_int_cst (type, integer_zero_node));
8077 70 : tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
8078 : gfc_finish_block (&block));
8079 :
8080 : /* And deal with infinities and NaNs. */
8081 70 : cond = build_call_expr_loc (input_location,
8082 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8083 : 1, arg);
8084 70 : nan = gfc_build_nan (type, "");
8085 70 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
8086 :
8087 70 : gfc_add_expr_to_block (&se->pre, tmp);
8088 70 : se->expr = res;
8089 70 : }
8090 :
8091 :
8092 : /* RRSPACING (s) is translated into
8093 : int e;
8094 : real x;
8095 : x = fabs (s);
8096 : if (isfinite (x))
8097 : {
8098 : if (x != 0)
8099 : {
8100 : frexp (s, &e);
8101 : x = scalbn (x, precision - e);
8102 : }
8103 : }
8104 : else
8105 : x = NaN;
8106 : return x;
8107 :
8108 : where precision is gfc_real_kinds[k].digits. */
8109 :
8110 : static void
8111 48 : gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
8112 : {
8113 48 : tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
8114 48 : int prec, k;
8115 48 : stmtblock_t block;
8116 :
8117 48 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8118 48 : prec = gfc_real_kinds[k].digits;
8119 :
8120 48 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8121 48 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8122 48 : fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
8123 :
8124 48 : type = gfc_typenode_for_spec (&expr->ts);
8125 48 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8126 48 : arg = gfc_evaluate_now (arg, &se->pre);
8127 :
8128 48 : e = gfc_create_var (integer_type_node, NULL);
8129 48 : x = gfc_create_var (type, NULL);
8130 48 : gfc_add_modify (&se->pre, x,
8131 : build_call_expr_loc (input_location, fabs, 1, arg));
8132 :
8133 :
8134 48 : gfc_start_block (&block);
8135 48 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8136 : gfc_build_addr_expr (NULL_TREE, e));
8137 48 : gfc_add_expr_to_block (&block, tmp);
8138 :
8139 48 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
8140 48 : build_int_cst (integer_type_node, prec), e);
8141 48 : tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
8142 48 : gfc_add_modify (&block, x, tmp);
8143 48 : stmt = gfc_finish_block (&block);
8144 :
8145 : /* if (x != 0) */
8146 48 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
8147 48 : build_real_from_int_cst (type, integer_zero_node));
8148 48 : tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
8149 :
8150 : /* And deal with infinities and NaNs. */
8151 48 : cond = build_call_expr_loc (input_location,
8152 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8153 : 1, x);
8154 48 : nan = gfc_build_nan (type, "");
8155 48 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
8156 :
8157 48 : gfc_add_expr_to_block (&se->pre, tmp);
8158 48 : se->expr = fold_convert (type, x);
8159 48 : }
8160 :
8161 :
8162 : /* SCALE (s, i) is translated into scalbn (s, i). */
8163 : static void
8164 72 : gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
8165 : {
8166 72 : tree args[2], type, scalbn;
8167 :
8168 72 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8169 :
8170 72 : type = gfc_typenode_for_spec (&expr->ts);
8171 72 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8172 72 : se->expr = build_call_expr_loc (input_location, scalbn, 2,
8173 : fold_convert (type, args[0]),
8174 : fold_convert (integer_type_node, args[1]));
8175 72 : se->expr = fold_convert (type, se->expr);
8176 72 : }
8177 :
8178 :
8179 : /* SET_EXPONENT (s, i) is translated into
8180 : isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
8181 : static void
8182 262 : gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
8183 : {
8184 262 : tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
8185 :
8186 262 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8187 262 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8188 :
8189 262 : type = gfc_typenode_for_spec (&expr->ts);
8190 262 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8191 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
8192 :
8193 262 : tmp = gfc_create_var (integer_type_node, NULL);
8194 262 : tmp = build_call_expr_loc (input_location, frexp, 2,
8195 : fold_convert (type, args[0]),
8196 : gfc_build_addr_expr (NULL_TREE, tmp));
8197 262 : res = build_call_expr_loc (input_location, scalbn, 2, tmp,
8198 : fold_convert (integer_type_node, args[1]));
8199 262 : res = fold_convert (type, res);
8200 :
8201 : /* Call to isfinite */
8202 262 : cond = build_call_expr_loc (input_location,
8203 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8204 : 1, args[0]);
8205 262 : nan = gfc_build_nan (type, "");
8206 :
8207 262 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
8208 : res, nan);
8209 262 : }
8210 :
8211 :
8212 : static void
8213 15242 : gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
8214 : {
8215 15242 : gfc_actual_arglist *actual;
8216 15242 : tree arg1;
8217 15242 : tree type;
8218 15242 : tree size;
8219 15242 : gfc_se argse;
8220 15242 : gfc_expr *e;
8221 15242 : gfc_symbol *sym = NULL;
8222 :
8223 15242 : gfc_init_se (&argse, NULL);
8224 15242 : actual = expr->value.function.actual;
8225 :
8226 15242 : if (actual->expr->ts.type == BT_CLASS)
8227 609 : gfc_add_class_array_ref (actual->expr);
8228 :
8229 15242 : e = actual->expr;
8230 :
8231 : /* These are emerging from the interface mapping, when a class valued
8232 : function appears as the rhs in a realloc on assign statement, where
8233 : the size of the result is that of one of the actual arguments. */
8234 15242 : if (e->expr_type == EXPR_VARIABLE
8235 14766 : && e->symtree->n.sym->ns == NULL /* This is distinctive! */
8236 573 : && e->symtree->n.sym->ts.type == BT_CLASS
8237 62 : && e->ref && e->ref->type == REF_COMPONENT
8238 44 : && strcmp (e->ref->u.c.component->name, "_data") == 0)
8239 15242 : sym = e->symtree->n.sym;
8240 :
8241 15242 : if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
8242 : && e
8243 854 : && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
8244 : {
8245 854 : symbol_attribute attr;
8246 854 : char *msg;
8247 854 : tree temp;
8248 854 : tree cond;
8249 :
8250 854 : if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
8251 : {
8252 33 : attr = CLASS_DATA (e->symtree->n.sym)->attr;
8253 33 : attr.pointer = attr.class_pointer;
8254 : }
8255 : else
8256 821 : attr = gfc_expr_attr (e);
8257 :
8258 854 : if (attr.allocatable)
8259 100 : msg = xasprintf ("Allocatable argument '%s' is not allocated",
8260 100 : e->symtree->n.sym->name);
8261 754 : else if (attr.pointer)
8262 46 : msg = xasprintf ("Pointer argument '%s' is not associated",
8263 46 : e->symtree->n.sym->name);
8264 : else
8265 708 : goto end_arg_check;
8266 :
8267 146 : if (sym)
8268 : {
8269 0 : temp = gfc_class_data_get (sym->backend_decl);
8270 0 : temp = gfc_conv_descriptor_data_get (temp);
8271 : }
8272 : else
8273 : {
8274 146 : argse.descriptor_only = 1;
8275 146 : gfc_conv_expr_descriptor (&argse, actual->expr);
8276 146 : temp = gfc_conv_descriptor_data_get (argse.expr);
8277 : }
8278 :
8279 146 : cond = fold_build2_loc (input_location, EQ_EXPR,
8280 : logical_type_node, temp,
8281 146 : fold_convert (TREE_TYPE (temp),
8282 : null_pointer_node));
8283 146 : gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
8284 :
8285 146 : free (msg);
8286 : }
8287 14388 : end_arg_check:
8288 :
8289 15242 : argse.data_not_needed = 1;
8290 15242 : if (gfc_is_class_array_function (e))
8291 : {
8292 : /* For functions that return a class array conv_expr_descriptor is not
8293 : able to get the descriptor right. Therefore this special case. */
8294 7 : gfc_conv_expr_reference (&argse, e);
8295 7 : argse.expr = gfc_class_data_get (argse.expr);
8296 : }
8297 15235 : else if (sym && sym->backend_decl)
8298 : {
8299 32 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8300 32 : argse.expr = gfc_class_data_get (sym->backend_decl);
8301 : }
8302 : else
8303 15203 : gfc_conv_expr_descriptor (&argse, actual->expr);
8304 15242 : gfc_add_block_to_block (&se->pre, &argse.pre);
8305 15242 : gfc_add_block_to_block (&se->post, &argse.post);
8306 15242 : arg1 = argse.expr;
8307 :
8308 15242 : actual = actual->next;
8309 15242 : if (actual->expr)
8310 : {
8311 9075 : stmtblock_t block;
8312 9075 : gfc_init_block (&block);
8313 9075 : gfc_init_se (&argse, NULL);
8314 9075 : gfc_conv_expr_type (&argse, actual->expr,
8315 : gfc_array_index_type);
8316 9075 : gfc_add_block_to_block (&block, &argse.pre);
8317 9075 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8318 : argse.expr, gfc_index_one_node);
8319 9075 : size = gfc_tree_array_size (&block, arg1, e, tmp);
8320 :
8321 : /* Unusually, for an intrinsic, size does not exclude
8322 : an optional arg2, so we must test for it. */
8323 9075 : if (actual->expr->expr_type == EXPR_VARIABLE
8324 2423 : && actual->expr->symtree->n.sym->attr.dummy
8325 31 : && actual->expr->symtree->n.sym->attr.optional)
8326 : {
8327 31 : tree cond;
8328 31 : stmtblock_t block2;
8329 31 : gfc_init_block (&block2);
8330 31 : gfc_init_se (&argse, NULL);
8331 31 : argse.want_pointer = 1;
8332 31 : argse.data_not_needed = 1;
8333 31 : gfc_conv_expr (&argse, actual->expr);
8334 31 : gfc_add_block_to_block (&se->pre, &argse.pre);
8335 : /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8336 : case; size_var can be used in both blocks. */
8337 31 : tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8338 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8339 31 : TREE_TYPE (size_var), size_var, size);
8340 31 : gfc_add_expr_to_block (&block, tmp);
8341 31 : size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8342 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8343 31 : TREE_TYPE (size_var), size_var, size);
8344 31 : gfc_add_expr_to_block (&block2, tmp);
8345 31 : cond = gfc_conv_expr_present (actual->expr->symtree->n.sym);
8346 31 : tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8347 : gfc_finish_block (&block2));
8348 31 : gfc_add_expr_to_block (&se->pre, tmp);
8349 31 : size = size_var;
8350 31 : }
8351 : else
8352 9044 : gfc_add_block_to_block (&se->pre, &block);
8353 : }
8354 : else
8355 6167 : size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8356 15242 : type = gfc_typenode_for_spec (&expr->ts);
8357 15242 : se->expr = convert (type, size);
8358 15242 : }
8359 :
8360 :
8361 : /* Helper function to compute the size of a character variable,
8362 : excluding the terminating null characters. The result has
8363 : gfc_array_index_type type. */
8364 :
8365 : tree
8366 1864 : size_of_string_in_bytes (int kind, tree string_length)
8367 : {
8368 1864 : tree bytesize;
8369 1864 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8370 :
8371 3728 : bytesize = build_int_cst (gfc_array_index_type,
8372 1864 : gfc_character_kinds[i].bit_size / 8);
8373 :
8374 1864 : return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8375 : bytesize,
8376 1864 : fold_convert (gfc_array_index_type, string_length));
8377 : }
8378 :
8379 :
8380 : static void
8381 1309 : gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8382 : {
8383 1309 : gfc_expr *arg;
8384 1309 : gfc_se argse;
8385 1309 : tree source_bytes;
8386 1309 : tree tmp;
8387 1309 : tree lower;
8388 1309 : tree upper;
8389 1309 : tree byte_size;
8390 1309 : tree field;
8391 1309 : int n;
8392 :
8393 1309 : gfc_init_se (&argse, NULL);
8394 1309 : arg = expr->value.function.actual->expr;
8395 :
8396 1309 : if (arg->rank || arg->ts.type == BT_ASSUMED)
8397 1012 : gfc_conv_expr_descriptor (&argse, arg);
8398 : else
8399 297 : gfc_conv_expr_reference (&argse, arg);
8400 :
8401 1309 : if (arg->ts.type == BT_ASSUMED)
8402 : {
8403 : /* This only works if an array descriptor has been passed; thus, extract
8404 : the size from the descriptor. */
8405 172 : gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8406 : == TYPE_PRECISION (size_type_node));
8407 172 : tmp = arg->symtree->n.sym->backend_decl;
8408 172 : tmp = DECL_LANG_SPECIFIC (tmp)
8409 60 : && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8410 226 : ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8411 172 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8412 172 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8413 :
8414 172 : tmp = gfc_conv_descriptor_dtype (tmp);
8415 172 : field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8416 : GFC_DTYPE_ELEM_LEN);
8417 172 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8418 : tmp, field, NULL_TREE);
8419 :
8420 172 : byte_size = fold_convert (gfc_array_index_type, tmp);
8421 : }
8422 1137 : else if (arg->ts.type == BT_CLASS)
8423 : {
8424 : /* Conv_expr_descriptor returns a component_ref to _data component of the
8425 : class object. The class object may be a non-pointer object, e.g.
8426 : located on the stack, or a memory location pointed to, e.g. a
8427 : parameter, i.e., an indirect_ref. */
8428 959 : if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8429 589 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8430 198 : byte_size
8431 198 : = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8432 391 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8433 0 : byte_size = gfc_class_vtab_size_get (argse.expr);
8434 391 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8435 391 : && TREE_CODE (argse.expr) == COMPONENT_REF)
8436 328 : byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8437 63 : else if (arg->rank > 0
8438 21 : || (arg->rank == 0
8439 21 : && arg->ref && arg->ref->type == REF_COMPONENT))
8440 : {
8441 : /* The scalarizer added an additional temp. To get the class' vptr
8442 : one has to look at the original backend_decl. */
8443 63 : if (argse.class_container)
8444 21 : byte_size = gfc_class_vtab_size_get (argse.class_container);
8445 42 : else if (DECL_LANG_SPECIFIC (arg->symtree->n.sym->backend_decl))
8446 84 : byte_size = gfc_class_vtab_size_get (
8447 42 : GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8448 : else
8449 0 : gcc_unreachable ();
8450 : }
8451 : else
8452 0 : gcc_unreachable ();
8453 : }
8454 : else
8455 : {
8456 548 : if (arg->ts.type == BT_CHARACTER)
8457 84 : byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8458 : else
8459 : {
8460 464 : if (arg->rank == 0)
8461 0 : byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8462 : argse.expr));
8463 : else
8464 464 : byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8465 464 : byte_size = fold_convert (gfc_array_index_type,
8466 : size_in_bytes (byte_size));
8467 : }
8468 : }
8469 :
8470 1309 : if (arg->rank == 0)
8471 297 : se->expr = byte_size;
8472 : else
8473 : {
8474 1012 : source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8475 1012 : gfc_add_modify (&argse.pre, source_bytes, byte_size);
8476 :
8477 1012 : if (arg->rank == -1)
8478 : {
8479 365 : tree cond, loop_var, exit_label;
8480 365 : stmtblock_t body;
8481 :
8482 365 : tmp = fold_convert (gfc_array_index_type,
8483 : gfc_conv_descriptor_rank (argse.expr));
8484 365 : loop_var = gfc_create_var (gfc_array_index_type, "i");
8485 365 : gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
8486 365 : exit_label = gfc_build_label_decl (NULL_TREE);
8487 :
8488 : /* Create loop:
8489 : for (;;)
8490 : {
8491 : if (i >= rank)
8492 : goto exit;
8493 : source_bytes = source_bytes * array.dim[i].extent;
8494 : i = i + 1;
8495 : }
8496 : exit: */
8497 365 : gfc_start_block (&body);
8498 365 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8499 : loop_var, tmp);
8500 365 : tmp = build1_v (GOTO_EXPR, exit_label);
8501 365 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8502 : cond, tmp, build_empty_stmt (input_location));
8503 365 : gfc_add_expr_to_block (&body, tmp);
8504 :
8505 365 : lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8506 365 : upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8507 365 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8508 365 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8509 : gfc_array_index_type, tmp, source_bytes);
8510 365 : gfc_add_modify (&body, source_bytes, tmp);
8511 :
8512 365 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8513 : gfc_array_index_type, loop_var,
8514 : gfc_index_one_node);
8515 365 : gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8516 :
8517 365 : tmp = gfc_finish_block (&body);
8518 :
8519 365 : tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8520 : tmp);
8521 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8522 :
8523 365 : tmp = build1_v (LABEL_EXPR, exit_label);
8524 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8525 : }
8526 : else
8527 : {
8528 : /* Obtain the size of the array in bytes. */
8529 1834 : for (n = 0; n < arg->rank; n++)
8530 : {
8531 1187 : tree idx;
8532 1187 : idx = gfc_rank_cst[n];
8533 1187 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8534 1187 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8535 1187 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8536 1187 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8537 : gfc_array_index_type, tmp, source_bytes);
8538 1187 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8539 : }
8540 : }
8541 1012 : se->expr = source_bytes;
8542 : }
8543 :
8544 1309 : gfc_add_block_to_block (&se->pre, &argse.pre);
8545 1309 : }
8546 :
8547 :
8548 : static void
8549 840 : gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8550 : {
8551 840 : gfc_expr *arg;
8552 840 : gfc_se argse;
8553 840 : tree type, result_type, tmp, class_decl = NULL;
8554 840 : gfc_symbol *sym;
8555 840 : bool unlimited = false;
8556 :
8557 840 : arg = expr->value.function.actual->expr;
8558 :
8559 840 : gfc_init_se (&argse, NULL);
8560 840 : result_type = gfc_get_int_type (expr->ts.kind);
8561 :
8562 840 : if (arg->rank == 0)
8563 : {
8564 230 : if (arg->ts.type == BT_CLASS)
8565 : {
8566 86 : unlimited = UNLIMITED_POLY (arg);
8567 86 : gfc_add_vptr_component (arg);
8568 86 : gfc_add_size_component (arg);
8569 86 : gfc_conv_expr (&argse, arg);
8570 86 : tmp = fold_convert (result_type, argse.expr);
8571 86 : class_decl = gfc_get_class_from_expr (argse.expr);
8572 86 : goto done;
8573 : }
8574 :
8575 144 : gfc_conv_expr_reference (&argse, arg);
8576 144 : type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8577 : argse.expr));
8578 : }
8579 : else
8580 : {
8581 610 : argse.want_pointer = 0;
8582 610 : gfc_conv_expr_descriptor (&argse, arg);
8583 610 : sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
8584 610 : if (arg->ts.type == BT_CLASS)
8585 : {
8586 60 : unlimited = UNLIMITED_POLY (arg);
8587 60 : if (TREE_CODE (argse.expr) == COMPONENT_REF)
8588 54 : tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8589 6 : else if (arg->rank > 0 && sym
8590 12 : && DECL_LANG_SPECIFIC (sym->backend_decl))
8591 12 : tmp = gfc_class_vtab_size_get (
8592 6 : GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
8593 : else
8594 0 : gcc_unreachable ();
8595 60 : tmp = fold_convert (result_type, tmp);
8596 60 : class_decl = gfc_get_class_from_expr (argse.expr);
8597 60 : goto done;
8598 : }
8599 550 : type = gfc_get_element_type (TREE_TYPE (argse.expr));
8600 : }
8601 :
8602 : /* Obtain the argument's word length. */
8603 694 : if (arg->ts.type == BT_CHARACTER)
8604 241 : tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8605 : else
8606 453 : tmp = size_in_bytes (type);
8607 694 : tmp = fold_convert (result_type, tmp);
8608 :
8609 840 : done:
8610 840 : if (unlimited && class_decl)
8611 68 : tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
8612 :
8613 840 : se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8614 : build_int_cst (result_type, BITS_PER_UNIT));
8615 840 : gfc_add_block_to_block (&se->pre, &argse.pre);
8616 840 : }
8617 :
8618 :
8619 : /* Intrinsic string comparison functions. */
8620 :
8621 : static void
8622 99 : gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8623 : {
8624 99 : tree args[4];
8625 :
8626 99 : gfc_conv_intrinsic_function_args (se, expr, args, 4);
8627 :
8628 99 : se->expr
8629 198 : = gfc_build_compare_string (args[0], args[1], args[2], args[3],
8630 99 : expr->value.function.actual->expr->ts.kind,
8631 : op);
8632 99 : se->expr = fold_build2_loc (input_location, op,
8633 : gfc_typenode_for_spec (&expr->ts), se->expr,
8634 99 : build_int_cst (TREE_TYPE (se->expr), 0));
8635 99 : }
8636 :
8637 : /* Generate a call to the adjustl/adjustr library function. */
8638 : static void
8639 474 : gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8640 : {
8641 474 : tree args[3];
8642 474 : tree len;
8643 474 : tree type;
8644 474 : tree var;
8645 474 : tree tmp;
8646 :
8647 474 : gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
8648 474 : len = args[1];
8649 :
8650 474 : type = TREE_TYPE (args[2]);
8651 474 : var = gfc_conv_string_tmp (se, type, len);
8652 474 : args[0] = var;
8653 :
8654 474 : tmp = build_call_expr_loc (input_location,
8655 : fndecl, 3, args[0], args[1], args[2]);
8656 474 : gfc_add_expr_to_block (&se->pre, tmp);
8657 474 : se->expr = var;
8658 474 : se->string_length = len;
8659 474 : }
8660 :
8661 :
8662 : /* Generate code for the TRANSFER intrinsic:
8663 : For scalar results:
8664 : DEST = TRANSFER (SOURCE, MOLD)
8665 : where:
8666 : typeof<DEST> = typeof<MOLD>
8667 : and:
8668 : MOLD is scalar.
8669 :
8670 : For array results:
8671 : DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8672 : where:
8673 : typeof<DEST> = typeof<MOLD>
8674 : and:
8675 : N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8676 : sizeof (DEST(0) * SIZE). */
8677 : static void
8678 3803 : gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8679 : {
8680 3803 : tree tmp;
8681 3803 : tree tmpdecl;
8682 3803 : tree ptr;
8683 3803 : tree extent;
8684 3803 : tree source;
8685 3803 : tree source_type;
8686 3803 : tree source_bytes;
8687 3803 : tree mold_type;
8688 3803 : tree dest_word_len;
8689 3803 : tree size_words;
8690 3803 : tree size_bytes;
8691 3803 : tree upper;
8692 3803 : tree lower;
8693 3803 : tree stmt;
8694 3803 : tree class_ref = NULL_TREE;
8695 3803 : gfc_actual_arglist *arg;
8696 3803 : gfc_se argse;
8697 3803 : gfc_array_info *info;
8698 3803 : stmtblock_t block;
8699 3803 : int n;
8700 3803 : bool scalar_mold;
8701 3803 : gfc_expr *source_expr, *mold_expr, *class_expr;
8702 :
8703 3803 : info = NULL;
8704 3803 : if (se->loop)
8705 472 : info = &se->ss->info->data.array;
8706 :
8707 : /* Convert SOURCE. The output from this stage is:-
8708 : source_bytes = length of the source in bytes
8709 : source = pointer to the source data. */
8710 3803 : arg = expr->value.function.actual;
8711 3803 : source_expr = arg->expr;
8712 :
8713 : /* Ensure double transfer through LOGICAL preserves all
8714 : the needed bits. */
8715 3803 : if (arg->expr->expr_type == EXPR_FUNCTION
8716 2811 : && arg->expr->value.function.esym == NULL
8717 2787 : && arg->expr->value.function.isym != NULL
8718 2787 : && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8719 12 : && arg->expr->ts.type == BT_LOGICAL
8720 12 : && expr->ts.type != arg->expr->ts.type)
8721 12 : arg->expr->value.function.name = "__transfer_in_transfer";
8722 :
8723 3803 : gfc_init_se (&argse, NULL);
8724 :
8725 3803 : source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8726 :
8727 : /* Obtain the pointer to source and the length of source in bytes. */
8728 3803 : if (arg->expr->rank == 0)
8729 : {
8730 3447 : gfc_conv_expr_reference (&argse, arg->expr);
8731 3447 : if (arg->expr->ts.type == BT_CLASS)
8732 : {
8733 37 : tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8734 37 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8735 : {
8736 19 : source = gfc_class_data_get (tmp);
8737 19 : class_ref = tmp;
8738 : }
8739 : else
8740 : {
8741 : /* Array elements are evaluated as a reference to the data.
8742 : To obtain the vptr for the element size, the argument
8743 : expression must be stripped to the class reference and
8744 : re-evaluated. The pre and post blocks are not needed. */
8745 18 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8746 18 : source = argse.expr;
8747 18 : class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8748 18 : gfc_init_se (&argse, NULL);
8749 18 : gfc_conv_expr (&argse, class_expr);
8750 18 : class_ref = argse.expr;
8751 : }
8752 : }
8753 : else
8754 3410 : source = argse.expr;
8755 :
8756 : /* Obtain the source word length. */
8757 3447 : switch (arg->expr->ts.type)
8758 : {
8759 294 : case BT_CHARACTER:
8760 294 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8761 : argse.string_length);
8762 294 : break;
8763 37 : case BT_CLASS:
8764 37 : if (class_ref != NULL_TREE)
8765 : {
8766 37 : tmp = gfc_class_vtab_size_get (class_ref);
8767 37 : if (UNLIMITED_POLY (source_expr))
8768 30 : tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
8769 : }
8770 : else
8771 : {
8772 0 : tmp = gfc_class_vtab_size_get (argse.expr);
8773 0 : if (UNLIMITED_POLY (source_expr))
8774 0 : tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
8775 : }
8776 : break;
8777 3116 : default:
8778 3116 : source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8779 : source));
8780 3116 : tmp = fold_convert (gfc_array_index_type,
8781 : size_in_bytes (source_type));
8782 3116 : break;
8783 : }
8784 : }
8785 : else
8786 : {
8787 356 : bool simply_contiguous = gfc_is_simply_contiguous (arg->expr,
8788 : false, true);
8789 356 : argse.want_pointer = 0;
8790 : /* A non-contiguous SOURCE needs packing. */
8791 356 : if (!simply_contiguous)
8792 74 : argse.force_tmp = 1;
8793 356 : gfc_conv_expr_descriptor (&argse, arg->expr);
8794 356 : source = gfc_conv_descriptor_data_get (argse.expr);
8795 356 : source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8796 :
8797 : /* Repack the source if not simply contiguous. */
8798 356 : if (!simply_contiguous)
8799 : {
8800 74 : tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8801 :
8802 74 : if (warn_array_temporaries)
8803 0 : gfc_warning (OPT_Warray_temporaries,
8804 : "Creating array temporary at %L", &expr->where);
8805 :
8806 74 : source = build_call_expr_loc (input_location,
8807 : gfor_fndecl_in_pack, 1, tmp);
8808 74 : source = gfc_evaluate_now (source, &argse.pre);
8809 :
8810 : /* Free the temporary. */
8811 74 : gfc_start_block (&block);
8812 74 : tmp = gfc_call_free (source);
8813 74 : gfc_add_expr_to_block (&block, tmp);
8814 74 : stmt = gfc_finish_block (&block);
8815 :
8816 : /* Clean up if it was repacked. */
8817 74 : gfc_init_block (&block);
8818 74 : tmp = gfc_conv_array_data (argse.expr);
8819 74 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8820 : source, tmp);
8821 74 : tmp = build3_v (COND_EXPR, tmp, stmt,
8822 : build_empty_stmt (input_location));
8823 74 : gfc_add_expr_to_block (&block, tmp);
8824 74 : gfc_add_block_to_block (&block, &se->post);
8825 74 : gfc_init_block (&se->post);
8826 74 : gfc_add_block_to_block (&se->post, &block);
8827 : }
8828 :
8829 : /* Obtain the source word length. */
8830 356 : if (arg->expr->ts.type == BT_CHARACTER)
8831 144 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8832 : argse.string_length);
8833 212 : else if (arg->expr->ts.type == BT_CLASS)
8834 : {
8835 54 : if (UNLIMITED_POLY (source_expr)
8836 54 : && DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl))
8837 12 : class_ref = GFC_DECL_SAVED_DESCRIPTOR
8838 : (source_expr->symtree->n.sym->backend_decl);
8839 : else
8840 42 : class_ref = TREE_OPERAND (argse.expr, 0);
8841 54 : tmp = gfc_class_vtab_size_get (class_ref);
8842 54 : if (UNLIMITED_POLY (arg->expr))
8843 54 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8844 : }
8845 : else
8846 158 : tmp = fold_convert (gfc_array_index_type,
8847 : size_in_bytes (source_type));
8848 :
8849 : /* Obtain the size of the array in bytes. */
8850 356 : extent = gfc_create_var (gfc_array_index_type, NULL);
8851 742 : for (n = 0; n < arg->expr->rank; n++)
8852 : {
8853 386 : tree idx;
8854 386 : idx = gfc_rank_cst[n];
8855 386 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8856 386 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8857 386 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8858 386 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8859 : gfc_array_index_type, upper, lower);
8860 386 : gfc_add_modify (&argse.pre, extent, tmp);
8861 386 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8862 : gfc_array_index_type, extent,
8863 : gfc_index_one_node);
8864 386 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8865 : gfc_array_index_type, tmp, source_bytes);
8866 : }
8867 : }
8868 :
8869 3803 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8870 3803 : gfc_add_block_to_block (&se->pre, &argse.pre);
8871 3803 : gfc_add_block_to_block (&se->post, &argse.post);
8872 :
8873 : /* Now convert MOLD. The outputs are:
8874 : mold_type = the TREE type of MOLD
8875 : dest_word_len = destination word length in bytes. */
8876 3803 : arg = arg->next;
8877 3803 : mold_expr = arg->expr;
8878 :
8879 3803 : gfc_init_se (&argse, NULL);
8880 :
8881 3803 : scalar_mold = arg->expr->rank == 0;
8882 :
8883 3803 : if (arg->expr->rank == 0)
8884 : {
8885 3480 : gfc_conv_expr_reference (&argse, mold_expr);
8886 3480 : mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8887 : argse.expr));
8888 : }
8889 : else
8890 : {
8891 323 : argse.want_pointer = 0;
8892 323 : gfc_conv_expr_descriptor (&argse, mold_expr);
8893 323 : mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8894 : }
8895 :
8896 3803 : gfc_add_block_to_block (&se->pre, &argse.pre);
8897 3803 : gfc_add_block_to_block (&se->post, &argse.post);
8898 :
8899 3803 : if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8900 : {
8901 : /* If this TRANSFER is nested in another TRANSFER, use a type
8902 : that preserves all bits. */
8903 12 : if (mold_expr->ts.type == BT_LOGICAL)
8904 12 : mold_type = gfc_get_int_type (mold_expr->ts.kind);
8905 : }
8906 :
8907 : /* Obtain the destination word length. */
8908 3803 : switch (mold_expr->ts.type)
8909 : {
8910 467 : case BT_CHARACTER:
8911 467 : tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length);
8912 467 : mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
8913 : argse.string_length);
8914 467 : break;
8915 6 : case BT_CLASS:
8916 6 : if (scalar_mold)
8917 6 : class_ref = argse.expr;
8918 : else
8919 0 : class_ref = TREE_OPERAND (argse.expr, 0);
8920 6 : tmp = gfc_class_vtab_size_get (class_ref);
8921 6 : if (UNLIMITED_POLY (arg->expr))
8922 0 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8923 : break;
8924 3330 : default:
8925 3330 : tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8926 3330 : break;
8927 : }
8928 :
8929 : /* Do not fix dest_word_len if it is a variable, since the temporary can wind
8930 : up being used before the assignment. */
8931 3803 : if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
8932 : dest_word_len = tmp;
8933 : else
8934 : {
8935 3749 : dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8936 3749 : gfc_add_modify (&se->pre, dest_word_len, tmp);
8937 : }
8938 :
8939 : /* Finally convert SIZE, if it is present. */
8940 3803 : arg = arg->next;
8941 3803 : size_words = gfc_create_var (gfc_array_index_type, NULL);
8942 :
8943 3803 : if (arg->expr)
8944 : {
8945 222 : gfc_init_se (&argse, NULL);
8946 222 : gfc_conv_expr_reference (&argse, arg->expr);
8947 222 : tmp = convert (gfc_array_index_type,
8948 : build_fold_indirect_ref_loc (input_location,
8949 : argse.expr));
8950 222 : gfc_add_block_to_block (&se->pre, &argse.pre);
8951 222 : gfc_add_block_to_block (&se->post, &argse.post);
8952 : }
8953 : else
8954 : tmp = NULL_TREE;
8955 :
8956 : /* Separate array and scalar results. */
8957 3803 : if (scalar_mold && tmp == NULL_TREE)
8958 3331 : goto scalar_transfer;
8959 :
8960 472 : size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8961 472 : if (tmp != NULL_TREE)
8962 222 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8963 : tmp, dest_word_len);
8964 : else
8965 : tmp = source_bytes;
8966 :
8967 472 : gfc_add_modify (&se->pre, size_bytes, tmp);
8968 472 : gfc_add_modify (&se->pre, size_words,
8969 : fold_build2_loc (input_location, CEIL_DIV_EXPR,
8970 : gfc_array_index_type,
8971 : size_bytes, dest_word_len));
8972 :
8973 : /* Evaluate the bounds of the result. If the loop range exists, we have
8974 : to check if it is too large. If so, we modify loop->to be consistent
8975 : with min(size, size(source)). Otherwise, size is made consistent with
8976 : the loop range, so that the right number of bytes is transferred.*/
8977 472 : n = se->loop->order[0];
8978 472 : if (se->loop->to[n] != NULL_TREE)
8979 : {
8980 205 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8981 : se->loop->to[n], se->loop->from[n]);
8982 205 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8983 : tmp, gfc_index_one_node);
8984 205 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8985 : tmp, size_words);
8986 205 : gfc_add_modify (&se->pre, size_words, tmp);
8987 205 : gfc_add_modify (&se->pre, size_bytes,
8988 : fold_build2_loc (input_location, MULT_EXPR,
8989 : gfc_array_index_type,
8990 : size_words, dest_word_len));
8991 410 : upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8992 205 : size_words, se->loop->from[n]);
8993 205 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8994 : upper, gfc_index_one_node);
8995 : }
8996 : else
8997 : {
8998 267 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8999 : size_words, gfc_index_one_node);
9000 267 : se->loop->from[n] = gfc_index_zero_node;
9001 : }
9002 :
9003 472 : se->loop->to[n] = upper;
9004 :
9005 : /* Build a destination descriptor, using the pointer, source, as the
9006 : data field. */
9007 472 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
9008 : NULL_TREE, false, true, false, &expr->where);
9009 :
9010 : /* Cast the pointer to the result. */
9011 472 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9012 472 : tmp = fold_convert (pvoid_type_node, tmp);
9013 :
9014 : /* Use memcpy to do the transfer. */
9015 472 : tmp
9016 472 : = build_call_expr_loc (input_location,
9017 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
9018 : fold_convert (pvoid_type_node, source),
9019 : fold_convert (size_type_node,
9020 : fold_build2_loc (input_location,
9021 : MIN_EXPR,
9022 : gfc_array_index_type,
9023 : size_bytes,
9024 : source_bytes)));
9025 472 : gfc_add_expr_to_block (&se->pre, tmp);
9026 :
9027 472 : se->expr = info->descriptor;
9028 472 : if (expr->ts.type == BT_CHARACTER)
9029 : {
9030 275 : tmp = fold_convert (gfc_charlen_type_node,
9031 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9032 275 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9033 : gfc_charlen_type_node,
9034 : dest_word_len, tmp);
9035 : }
9036 :
9037 472 : return;
9038 :
9039 : /* Deal with scalar results. */
9040 3331 : scalar_transfer:
9041 3331 : extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9042 : dest_word_len, source_bytes);
9043 3331 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9044 : extent, gfc_index_zero_node);
9045 :
9046 3331 : if (expr->ts.type == BT_CHARACTER)
9047 : {
9048 192 : tree direct, indirect, free;
9049 :
9050 192 : ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
9051 192 : tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
9052 : "transfer");
9053 :
9054 : /* If source is longer than the destination, use a pointer to
9055 : the source directly. */
9056 192 : gfc_init_block (&block);
9057 192 : gfc_add_modify (&block, tmpdecl, ptr);
9058 192 : direct = gfc_finish_block (&block);
9059 :
9060 : /* Otherwise, allocate a string with the length of the destination
9061 : and copy the source into it. */
9062 192 : gfc_init_block (&block);
9063 192 : tmp = gfc_get_pchar_type (expr->ts.kind);
9064 192 : tmp = gfc_call_malloc (&block, tmp, dest_word_len);
9065 192 : gfc_add_modify (&block, tmpdecl,
9066 192 : fold_convert (TREE_TYPE (ptr), tmp));
9067 192 : tmp = build_call_expr_loc (input_location,
9068 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9069 : fold_convert (pvoid_type_node, tmpdecl),
9070 : fold_convert (pvoid_type_node, ptr),
9071 : fold_convert (size_type_node, extent));
9072 192 : gfc_add_expr_to_block (&block, tmp);
9073 192 : indirect = gfc_finish_block (&block);
9074 :
9075 : /* Wrap it up with the condition. */
9076 192 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
9077 : dest_word_len, source_bytes);
9078 192 : tmp = build3_v (COND_EXPR, tmp, direct, indirect);
9079 192 : gfc_add_expr_to_block (&se->pre, tmp);
9080 :
9081 : /* Free the temporary string, if necessary. */
9082 192 : free = gfc_call_free (tmpdecl);
9083 192 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9084 : dest_word_len, source_bytes);
9085 192 : tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
9086 192 : gfc_add_expr_to_block (&se->post, tmp);
9087 :
9088 192 : se->expr = tmpdecl;
9089 192 : tmp = fold_convert (gfc_charlen_type_node,
9090 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9091 192 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9092 : gfc_charlen_type_node,
9093 : dest_word_len, tmp);
9094 : }
9095 : else
9096 : {
9097 3139 : tmpdecl = gfc_create_var (mold_type, "transfer");
9098 :
9099 3139 : ptr = convert (build_pointer_type (mold_type), source);
9100 :
9101 : /* For CLASS results, allocate the needed memory first. */
9102 3139 : if (mold_expr->ts.type == BT_CLASS)
9103 : {
9104 6 : tree cdata;
9105 6 : cdata = gfc_class_data_get (tmpdecl);
9106 6 : tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
9107 6 : gfc_add_modify (&se->pre, cdata, tmp);
9108 : }
9109 :
9110 : /* Use memcpy to do the transfer. */
9111 3139 : if (mold_expr->ts.type == BT_CLASS)
9112 6 : tmp = gfc_class_data_get (tmpdecl);
9113 : else
9114 3133 : tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
9115 :
9116 3139 : tmp = build_call_expr_loc (input_location,
9117 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9118 : fold_convert (pvoid_type_node, tmp),
9119 : fold_convert (pvoid_type_node, ptr),
9120 : fold_convert (size_type_node, extent));
9121 3139 : gfc_add_expr_to_block (&se->pre, tmp);
9122 :
9123 : /* For CLASS results, set the _vptr. */
9124 3139 : if (mold_expr->ts.type == BT_CLASS)
9125 6 : gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
9126 :
9127 3139 : se->expr = tmpdecl;
9128 : }
9129 : }
9130 :
9131 :
9132 : /* Generate code for the ALLOCATED intrinsic.
9133 : Generate inline code that directly check the address of the argument. */
9134 :
9135 : static void
9136 7381 : gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
9137 : {
9138 7381 : gfc_se arg1se;
9139 7381 : tree tmp;
9140 7381 : gfc_expr *e = expr->value.function.actual->expr;
9141 :
9142 7381 : gfc_init_se (&arg1se, NULL);
9143 7381 : if (e->ts.type == BT_CLASS)
9144 : {
9145 : /* Make sure that class array expressions have both a _data
9146 : component reference and an array reference.... */
9147 899 : if (CLASS_DATA (e)->attr.dimension)
9148 418 : gfc_add_class_array_ref (e);
9149 : /* .... whilst scalars only need the _data component. */
9150 : else
9151 481 : gfc_add_data_component (e);
9152 : }
9153 :
9154 7381 : gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
9155 :
9156 7381 : if (e->rank == 0)
9157 : {
9158 : /* Allocatable scalar. */
9159 2876 : arg1se.want_pointer = 1;
9160 2876 : gfc_conv_expr (&arg1se, e);
9161 2876 : tmp = arg1se.expr;
9162 : }
9163 : else
9164 : {
9165 : /* Allocatable array. */
9166 4505 : arg1se.descriptor_only = 1;
9167 4505 : gfc_conv_expr_descriptor (&arg1se, e);
9168 4505 : tmp = gfc_conv_descriptor_data_get (arg1se.expr);
9169 : }
9170 :
9171 7381 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
9172 7381 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9173 :
9174 : /* Components of pointer array references sometimes come back with a pre block. */
9175 7381 : if (arg1se.pre.head)
9176 327 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9177 :
9178 7381 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9179 7381 : }
9180 :
9181 :
9182 : /* Generate code for the ASSOCIATED intrinsic.
9183 : If both POINTER and TARGET are arrays, generate a call to library function
9184 : _gfor_associated, and pass descriptors of POINTER and TARGET to it.
9185 : In other cases, generate inline code that directly compare the address of
9186 : POINTER with the address of TARGET. */
9187 :
9188 : static void
9189 9491 : gfc_conv_associated (gfc_se *se, gfc_expr *expr)
9190 : {
9191 9491 : gfc_actual_arglist *arg1;
9192 9491 : gfc_actual_arglist *arg2;
9193 9491 : gfc_se arg1se;
9194 9491 : gfc_se arg2se;
9195 9491 : tree tmp2;
9196 9491 : tree tmp;
9197 9491 : tree nonzero_arraylen = NULL_TREE;
9198 9491 : gfc_ss *ss;
9199 9491 : bool scalar;
9200 :
9201 9491 : gfc_init_se (&arg1se, NULL);
9202 9491 : gfc_init_se (&arg2se, NULL);
9203 9491 : arg1 = expr->value.function.actual;
9204 9491 : arg2 = arg1->next;
9205 :
9206 : /* Check whether the expression is a scalar or not; we cannot use
9207 : arg1->expr->rank as it can be nonzero for proc pointers. */
9208 9491 : ss = gfc_walk_expr (arg1->expr);
9209 9491 : scalar = ss == gfc_ss_terminator;
9210 9491 : if (!scalar)
9211 3913 : gfc_free_ss_chain (ss);
9212 :
9213 9491 : if (!arg2->expr)
9214 : {
9215 : /* No optional target. */
9216 7114 : if (scalar)
9217 : {
9218 : /* A pointer to a scalar. */
9219 4653 : arg1se.want_pointer = 1;
9220 4653 : gfc_conv_expr (&arg1se, arg1->expr);
9221 4653 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9222 185 : && arg1->expr->symtree->n.sym->attr.dummy)
9223 78 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9224 : arg1se.expr);
9225 4653 : if (arg1->expr->ts.type == BT_CLASS)
9226 : {
9227 390 : tmp2 = gfc_class_data_get (arg1se.expr);
9228 390 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9229 0 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
9230 : }
9231 : else
9232 4263 : tmp2 = arg1se.expr;
9233 : }
9234 : else
9235 : {
9236 : /* A pointer to an array. */
9237 2461 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9238 2461 : tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
9239 : }
9240 7114 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9241 7114 : gfc_add_block_to_block (&se->post, &arg1se.post);
9242 7114 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9243 7114 : fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9244 7114 : se->expr = tmp;
9245 : }
9246 : else
9247 : {
9248 : /* An optional target. */
9249 2377 : if (arg2->expr->ts.type == BT_CLASS
9250 30 : && arg2->expr->expr_type != EXPR_FUNCTION)
9251 24 : gfc_add_data_component (arg2->expr);
9252 :
9253 2377 : if (scalar)
9254 : {
9255 : /* A pointer to a scalar. */
9256 925 : arg1se.want_pointer = 1;
9257 925 : gfc_conv_expr (&arg1se, arg1->expr);
9258 925 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9259 128 : && arg1->expr->symtree->n.sym->attr.dummy)
9260 42 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9261 : arg1se.expr);
9262 925 : if (arg1->expr->ts.type == BT_CLASS)
9263 252 : arg1se.expr = gfc_class_data_get (arg1se.expr);
9264 :
9265 925 : arg2se.want_pointer = 1;
9266 925 : gfc_conv_expr (&arg2se, arg2->expr);
9267 925 : if (arg2->expr->symtree->n.sym->attr.proc_pointer
9268 36 : && arg2->expr->symtree->n.sym->attr.dummy)
9269 0 : arg2se.expr = build_fold_indirect_ref_loc (input_location,
9270 : arg2se.expr);
9271 925 : if (arg2->expr->ts.type == BT_CLASS)
9272 : {
9273 6 : arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
9274 6 : arg2se.expr = gfc_class_data_get (arg2se.expr);
9275 : }
9276 925 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9277 925 : gfc_add_block_to_block (&se->post, &arg1se.post);
9278 925 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9279 925 : gfc_add_block_to_block (&se->post, &arg2se.post);
9280 925 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9281 : arg1se.expr, arg2se.expr);
9282 925 : tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9283 : arg1se.expr, null_pointer_node);
9284 925 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9285 : logical_type_node, tmp, tmp2);
9286 : }
9287 : else
9288 : {
9289 : /* An array pointer of zero length is not associated if target is
9290 : present. */
9291 1452 : arg1se.descriptor_only = 1;
9292 1452 : gfc_conv_expr_lhs (&arg1se, arg1->expr);
9293 1452 : if (arg1->expr->rank == -1)
9294 : {
9295 84 : tmp = gfc_conv_descriptor_rank (arg1se.expr);
9296 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9297 84 : TREE_TYPE (tmp), tmp,
9298 84 : build_int_cst (TREE_TYPE (tmp), 1));
9299 : }
9300 : else
9301 1368 : tmp = gfc_rank_cst[arg1->expr->rank - 1];
9302 1452 : tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9303 1452 : if (arg2->expr->rank != 0)
9304 1422 : nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9305 : logical_type_node, tmp,
9306 1422 : build_int_cst (TREE_TYPE (tmp), 0));
9307 :
9308 : /* A pointer to an array, call library function _gfor_associated. */
9309 1452 : arg1se.want_pointer = 1;
9310 1452 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9311 1452 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9312 1452 : gfc_add_block_to_block (&se->post, &arg1se.post);
9313 :
9314 1452 : arg2se.want_pointer = 1;
9315 1452 : arg2se.force_no_tmp = 1;
9316 1452 : if (arg2->expr->rank != 0)
9317 1422 : gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9318 : else
9319 : {
9320 30 : gfc_conv_expr (&arg2se, arg2->expr);
9321 30 : arg2se.expr
9322 30 : = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9323 30 : gfc_expr_attr (arg2->expr));
9324 30 : arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9325 : }
9326 1452 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9327 1452 : gfc_add_block_to_block (&se->post, &arg2se.post);
9328 1452 : se->expr = build_call_expr_loc (input_location,
9329 : gfor_fndecl_associated, 2,
9330 : arg1se.expr, arg2se.expr);
9331 1452 : se->expr = convert (logical_type_node, se->expr);
9332 1452 : if (arg2->expr->rank != 0)
9333 1422 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9334 : logical_type_node, se->expr,
9335 : nonzero_arraylen);
9336 : }
9337 :
9338 : /* If target is present zero character length pointers cannot
9339 : be associated. */
9340 2377 : if (arg1->expr->ts.type == BT_CHARACTER)
9341 : {
9342 631 : tmp = arg1se.string_length;
9343 631 : tmp = fold_build2_loc (input_location, NE_EXPR,
9344 : logical_type_node, tmp,
9345 631 : build_zero_cst (TREE_TYPE (tmp)));
9346 631 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9347 : logical_type_node, se->expr, tmp);
9348 : }
9349 : }
9350 :
9351 9491 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9352 9491 : }
9353 :
9354 :
9355 : /* Generate code for the SAME_TYPE_AS intrinsic.
9356 : Generate inline code that directly checks the vindices. */
9357 :
9358 : static void
9359 409 : gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9360 : {
9361 409 : gfc_expr *a, *b;
9362 409 : gfc_se se1, se2;
9363 409 : tree tmp;
9364 409 : tree conda = NULL_TREE, condb = NULL_TREE;
9365 :
9366 409 : gfc_init_se (&se1, NULL);
9367 409 : gfc_init_se (&se2, NULL);
9368 :
9369 409 : a = expr->value.function.actual->expr;
9370 409 : b = expr->value.function.actual->next->expr;
9371 :
9372 409 : bool unlimited_poly_a = UNLIMITED_POLY (a);
9373 409 : bool unlimited_poly_b = UNLIMITED_POLY (b);
9374 409 : if (unlimited_poly_a)
9375 : {
9376 111 : se1.want_pointer = 1;
9377 111 : gfc_add_vptr_component (a);
9378 : }
9379 298 : else if (a->ts.type == BT_CLASS)
9380 : {
9381 256 : gfc_add_vptr_component (a);
9382 256 : gfc_add_hash_component (a);
9383 : }
9384 42 : else if (a->ts.type == BT_DERIVED)
9385 42 : a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9386 42 : a->ts.u.derived->hash_value);
9387 :
9388 409 : if (unlimited_poly_b)
9389 : {
9390 72 : se2.want_pointer = 1;
9391 72 : gfc_add_vptr_component (b);
9392 : }
9393 337 : else if (b->ts.type == BT_CLASS)
9394 : {
9395 169 : gfc_add_vptr_component (b);
9396 169 : gfc_add_hash_component (b);
9397 : }
9398 168 : else if (b->ts.type == BT_DERIVED)
9399 168 : b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9400 168 : b->ts.u.derived->hash_value);
9401 :
9402 409 : gfc_conv_expr (&se1, a);
9403 409 : gfc_conv_expr (&se2, b);
9404 :
9405 409 : if (unlimited_poly_a)
9406 : {
9407 111 : conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9408 : se1.expr,
9409 111 : build_int_cst (TREE_TYPE (se1.expr), 0));
9410 111 : se1.expr = gfc_vptr_hash_get (se1.expr);
9411 : }
9412 :
9413 409 : if (unlimited_poly_b)
9414 : {
9415 72 : condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9416 : se2.expr,
9417 72 : build_int_cst (TREE_TYPE (se2.expr), 0));
9418 72 : se2.expr = gfc_vptr_hash_get (se2.expr);
9419 : }
9420 :
9421 409 : tmp = fold_build2_loc (input_location, EQ_EXPR,
9422 : logical_type_node, se1.expr,
9423 409 : fold_convert (TREE_TYPE (se1.expr), se2.expr));
9424 :
9425 409 : if (conda)
9426 111 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9427 : logical_type_node, conda, tmp);
9428 :
9429 409 : if (condb)
9430 72 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9431 : logical_type_node, condb, tmp);
9432 :
9433 409 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9434 409 : }
9435 :
9436 :
9437 : /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9438 :
9439 : static void
9440 42 : gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9441 : {
9442 42 : tree args[2];
9443 :
9444 42 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
9445 42 : se->expr = build_call_expr_loc (input_location,
9446 : gfor_fndecl_sc_kind, 2, args[0], args[1]);
9447 42 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9448 42 : }
9449 :
9450 :
9451 : /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9452 :
9453 : static void
9454 45 : gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9455 : {
9456 45 : tree arg, type;
9457 :
9458 45 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9459 :
9460 : /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9461 45 : type = gfc_get_int_type (4);
9462 45 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9463 :
9464 : /* Convert it to the required type. */
9465 45 : type = gfc_typenode_for_spec (&expr->ts);
9466 45 : se->expr = build_call_expr_loc (input_location,
9467 : gfor_fndecl_si_kind, 1, arg);
9468 45 : se->expr = fold_convert (type, se->expr);
9469 45 : }
9470 :
9471 :
9472 : /* Generate code for SELECTED_LOGICAL_KIND (BITS) intrinsic function. */
9473 :
9474 : static void
9475 6 : gfc_conv_intrinsic_sl_kind (gfc_se *se, gfc_expr *expr)
9476 : {
9477 6 : tree arg, type;
9478 :
9479 6 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9480 :
9481 : /* The argument to SELECTED_LOGICAL_KIND is INTEGER(4). */
9482 6 : type = gfc_get_int_type (4);
9483 6 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9484 :
9485 : /* Convert it to the required type. */
9486 6 : type = gfc_typenode_for_spec (&expr->ts);
9487 6 : se->expr = build_call_expr_loc (input_location,
9488 : gfor_fndecl_sl_kind, 1, arg);
9489 6 : se->expr = fold_convert (type, se->expr);
9490 6 : }
9491 :
9492 :
9493 : /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9494 :
9495 : static void
9496 82 : gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9497 : {
9498 82 : gfc_actual_arglist *actual;
9499 82 : tree type;
9500 82 : gfc_se argse;
9501 82 : vec<tree, va_gc> *args = NULL;
9502 :
9503 328 : for (actual = expr->value.function.actual; actual; actual = actual->next)
9504 : {
9505 246 : gfc_init_se (&argse, se);
9506 :
9507 : /* Pass a NULL pointer for an absent arg. */
9508 246 : if (actual->expr == NULL)
9509 96 : argse.expr = null_pointer_node;
9510 : else
9511 : {
9512 150 : gfc_typespec ts;
9513 150 : gfc_clear_ts (&ts);
9514 :
9515 150 : if (actual->expr->ts.kind != gfc_c_int_kind)
9516 : {
9517 : /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9518 0 : ts.type = BT_INTEGER;
9519 0 : ts.kind = gfc_c_int_kind;
9520 0 : gfc_convert_type (actual->expr, &ts, 2);
9521 : }
9522 150 : gfc_conv_expr_reference (&argse, actual->expr);
9523 : }
9524 :
9525 246 : gfc_add_block_to_block (&se->pre, &argse.pre);
9526 246 : gfc_add_block_to_block (&se->post, &argse.post);
9527 246 : vec_safe_push (args, argse.expr);
9528 : }
9529 :
9530 : /* Convert it to the required type. */
9531 82 : type = gfc_typenode_for_spec (&expr->ts);
9532 82 : se->expr = build_call_expr_loc_vec (input_location,
9533 : gfor_fndecl_sr_kind, args);
9534 82 : se->expr = fold_convert (type, se->expr);
9535 82 : }
9536 :
9537 :
9538 : /* Generate code for TRIM (A) intrinsic function. */
9539 :
9540 : static void
9541 578 : gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9542 : {
9543 578 : tree var;
9544 578 : tree len;
9545 578 : tree addr;
9546 578 : tree tmp;
9547 578 : tree cond;
9548 578 : tree fndecl;
9549 578 : tree function;
9550 578 : tree *args;
9551 578 : unsigned int num_args;
9552 :
9553 578 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9554 578 : args = XALLOCAVEC (tree, num_args);
9555 :
9556 578 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9557 578 : addr = gfc_build_addr_expr (ppvoid_type_node, var);
9558 578 : len = gfc_create_var (gfc_charlen_type_node, "len");
9559 :
9560 578 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
9561 578 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
9562 578 : args[1] = addr;
9563 :
9564 578 : if (expr->ts.kind == 1)
9565 546 : function = gfor_fndecl_string_trim;
9566 32 : else if (expr->ts.kind == 4)
9567 32 : function = gfor_fndecl_string_trim_char4;
9568 : else
9569 0 : gcc_unreachable ();
9570 :
9571 578 : fndecl = build_addr (function);
9572 578 : tmp = build_call_array_loc (input_location,
9573 578 : TREE_TYPE (TREE_TYPE (function)), fndecl,
9574 : num_args, args);
9575 578 : gfc_add_expr_to_block (&se->pre, tmp);
9576 :
9577 : /* Free the temporary afterwards, if necessary. */
9578 578 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9579 578 : len, build_int_cst (TREE_TYPE (len), 0));
9580 578 : tmp = gfc_call_free (var);
9581 578 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9582 578 : gfc_add_expr_to_block (&se->post, tmp);
9583 :
9584 578 : se->expr = var;
9585 578 : se->string_length = len;
9586 578 : }
9587 :
9588 :
9589 : /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9590 :
9591 : static void
9592 529 : gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9593 : {
9594 529 : tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9595 529 : tree type, cond, tmp, count, exit_label, n, max, largest;
9596 529 : tree size;
9597 529 : stmtblock_t block, body;
9598 529 : int i;
9599 :
9600 : /* We store in charsize the size of a character. */
9601 529 : i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9602 529 : size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9603 :
9604 : /* Get the arguments. */
9605 529 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
9606 529 : slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9607 529 : src = args[1];
9608 529 : ncopies = gfc_evaluate_now (args[2], &se->pre);
9609 529 : ncopies_type = TREE_TYPE (ncopies);
9610 :
9611 : /* Check that NCOPIES is not negative. */
9612 529 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9613 : build_int_cst (ncopies_type, 0));
9614 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9615 : "Argument NCOPIES of REPEAT intrinsic is negative "
9616 : "(its value is %ld)",
9617 : fold_convert (long_integer_type_node, ncopies));
9618 :
9619 : /* If the source length is zero, any non negative value of NCOPIES
9620 : is valid, and nothing happens. */
9621 529 : n = gfc_create_var (ncopies_type, "ncopies");
9622 529 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9623 : size_zero_node);
9624 529 : tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9625 : build_int_cst (ncopies_type, 0), ncopies);
9626 529 : gfc_add_modify (&se->pre, n, tmp);
9627 529 : ncopies = n;
9628 :
9629 : /* Check that ncopies is not too large: ncopies should be less than
9630 : (or equal to) MAX / slen, where MAX is the maximal integer of
9631 : the gfc_charlen_type_node type. If slen == 0, we need a special
9632 : case to avoid the division by zero. */
9633 529 : max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9634 529 : fold_convert (sizetype,
9635 : TYPE_MAX_VALUE (gfc_charlen_type_node)),
9636 : slen);
9637 1054 : largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9638 529 : ? sizetype : ncopies_type;
9639 529 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9640 : fold_convert (largest, ncopies),
9641 : fold_convert (largest, max));
9642 529 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9643 : size_zero_node);
9644 529 : cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9645 : logical_false_node, cond);
9646 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9647 : "Argument NCOPIES of REPEAT intrinsic is too large");
9648 :
9649 : /* Compute the destination length. */
9650 529 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9651 : fold_convert (gfc_charlen_type_node, slen),
9652 : fold_convert (gfc_charlen_type_node, ncopies));
9653 529 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9654 529 : dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9655 :
9656 : /* Generate the code to do the repeat operation:
9657 : for (i = 0; i < ncopies; i++)
9658 : memmove (dest + (i * slen * size), src, slen*size); */
9659 529 : gfc_start_block (&block);
9660 529 : count = gfc_create_var (sizetype, "count");
9661 529 : gfc_add_modify (&block, count, size_zero_node);
9662 529 : exit_label = gfc_build_label_decl (NULL_TREE);
9663 :
9664 : /* Start the loop body. */
9665 529 : gfc_start_block (&body);
9666 :
9667 : /* Exit the loop if count >= ncopies. */
9668 529 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9669 : fold_convert (sizetype, ncopies));
9670 529 : tmp = build1_v (GOTO_EXPR, exit_label);
9671 529 : TREE_USED (exit_label) = 1;
9672 529 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9673 : build_empty_stmt (input_location));
9674 529 : gfc_add_expr_to_block (&body, tmp);
9675 :
9676 : /* Call memmove (dest + (i*slen*size), src, slen*size). */
9677 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9678 : count);
9679 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9680 : size);
9681 529 : tmp = fold_build_pointer_plus_loc (input_location,
9682 : fold_convert (pvoid_type_node, dest), tmp);
9683 529 : tmp = build_call_expr_loc (input_location,
9684 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9685 : 3, tmp, src,
9686 : fold_build2_loc (input_location, MULT_EXPR,
9687 : size_type_node, slen, size));
9688 529 : gfc_add_expr_to_block (&body, tmp);
9689 :
9690 : /* Increment count. */
9691 529 : tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9692 : count, size_one_node);
9693 529 : gfc_add_modify (&body, count, tmp);
9694 :
9695 : /* Build the loop. */
9696 529 : tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9697 529 : gfc_add_expr_to_block (&block, tmp);
9698 :
9699 : /* Add the exit label. */
9700 529 : tmp = build1_v (LABEL_EXPR, exit_label);
9701 529 : gfc_add_expr_to_block (&block, tmp);
9702 :
9703 : /* Finish the block. */
9704 529 : tmp = gfc_finish_block (&block);
9705 529 : gfc_add_expr_to_block (&se->pre, tmp);
9706 :
9707 : /* Set the result value. */
9708 529 : se->expr = dest;
9709 529 : se->string_length = dlen;
9710 529 : }
9711 :
9712 :
9713 : /* Generate code for the IARGC intrinsic. */
9714 :
9715 : static void
9716 12 : gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9717 : {
9718 12 : tree tmp;
9719 12 : tree fndecl;
9720 12 : tree type;
9721 :
9722 : /* Call the library function. This always returns an INTEGER(4). */
9723 12 : fndecl = gfor_fndecl_iargc;
9724 12 : tmp = build_call_expr_loc (input_location,
9725 : fndecl, 0);
9726 :
9727 : /* Convert it to the required type. */
9728 12 : type = gfc_typenode_for_spec (&expr->ts);
9729 12 : tmp = fold_convert (type, tmp);
9730 :
9731 12 : se->expr = tmp;
9732 12 : }
9733 :
9734 :
9735 : /* Generate code for the KILL intrinsic. */
9736 :
9737 : static void
9738 8 : conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9739 : {
9740 8 : tree *args;
9741 8 : tree int4_type_node = gfc_get_int_type (4);
9742 8 : tree pid;
9743 8 : tree sig;
9744 8 : tree tmp;
9745 8 : unsigned int num_args;
9746 :
9747 8 : num_args = gfc_intrinsic_argument_list_length (expr);
9748 8 : args = XALLOCAVEC (tree, num_args);
9749 8 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
9750 :
9751 : /* Convert PID to a INTEGER(4) entity. */
9752 8 : pid = convert (int4_type_node, args[0]);
9753 :
9754 : /* Convert SIG to a INTEGER(4) entity. */
9755 8 : sig = convert (int4_type_node, args[1]);
9756 :
9757 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9758 :
9759 8 : se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9760 8 : }
9761 :
9762 :
9763 : static tree
9764 15 : conv_intrinsic_kill_sub (gfc_code *code)
9765 : {
9766 15 : stmtblock_t block;
9767 15 : gfc_se se, se_stat;
9768 15 : tree int4_type_node = gfc_get_int_type (4);
9769 15 : tree pid;
9770 15 : tree sig;
9771 15 : tree statp;
9772 15 : tree tmp;
9773 :
9774 : /* Make the function call. */
9775 15 : gfc_init_block (&block);
9776 15 : gfc_init_se (&se, NULL);
9777 :
9778 : /* Convert PID to a INTEGER(4) entity. */
9779 15 : gfc_conv_expr (&se, code->ext.actual->expr);
9780 15 : gfc_add_block_to_block (&block, &se.pre);
9781 15 : pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9782 15 : gfc_add_block_to_block (&block, &se.post);
9783 :
9784 : /* Convert SIG to a INTEGER(4) entity. */
9785 15 : gfc_conv_expr (&se, code->ext.actual->next->expr);
9786 15 : gfc_add_block_to_block (&block, &se.pre);
9787 15 : sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9788 15 : gfc_add_block_to_block (&block, &se.post);
9789 :
9790 : /* Deal with an optional STATUS. */
9791 15 : if (code->ext.actual->next->next->expr)
9792 : {
9793 10 : gfc_init_se (&se_stat, NULL);
9794 10 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
9795 10 : statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9796 : }
9797 : else
9798 : statp = NULL_TREE;
9799 :
9800 25 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9801 10 : statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9802 :
9803 15 : gfc_add_expr_to_block (&block, tmp);
9804 :
9805 15 : if (statp && statp != se_stat.expr)
9806 10 : gfc_add_modify (&block, se_stat.expr,
9807 10 : fold_convert (TREE_TYPE (se_stat.expr), statp));
9808 :
9809 15 : return gfc_finish_block (&block);
9810 : }
9811 :
9812 :
9813 :
9814 : /* The loc intrinsic returns the address of its argument as
9815 : gfc_index_integer_kind integer. */
9816 :
9817 : static void
9818 8852 : gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9819 : {
9820 8852 : tree temp_var;
9821 8852 : gfc_expr *arg_expr;
9822 :
9823 8852 : gcc_assert (!se->ss);
9824 :
9825 8852 : arg_expr = expr->value.function.actual->expr;
9826 8852 : if (arg_expr->rank == 0)
9827 : {
9828 6437 : if (arg_expr->ts.type == BT_CLASS)
9829 18 : gfc_add_data_component (arg_expr);
9830 6437 : gfc_conv_expr_reference (se, arg_expr);
9831 : }
9832 : else
9833 2415 : gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9834 8852 : se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9835 :
9836 : /* Create a temporary variable for loc return value. Without this,
9837 : we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9838 8852 : temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9839 8852 : gfc_add_modify (&se->pre, temp_var, se->expr);
9840 8852 : se->expr = temp_var;
9841 8852 : }
9842 :
9843 : /* The following routine generates code for the intrinsic functions from
9844 : the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
9845 : F_C_STRING. */
9846 :
9847 : static void
9848 9773 : conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9849 : {
9850 9773 : gfc_actual_arglist *arg = expr->value.function.actual;
9851 :
9852 9773 : if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9853 : {
9854 7383 : if (arg->expr->rank == 0)
9855 2010 : gfc_conv_expr_reference (se, arg->expr);
9856 5373 : else if (gfc_is_simply_contiguous (arg->expr, false, false))
9857 4289 : gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9858 : else
9859 : {
9860 1084 : gfc_conv_expr_descriptor (se, arg->expr);
9861 1084 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9862 : }
9863 :
9864 : /* TODO -- the following two lines shouldn't be necessary, but if
9865 : they're removed, a bug is exposed later in the code path.
9866 : This workaround was thus introduced, but will have to be
9867 : removed; please see PR 35150 for details about the issue. */
9868 7383 : se->expr = convert (pvoid_type_node, se->expr);
9869 7383 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9870 : }
9871 2390 : else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9872 : {
9873 260 : gfc_conv_expr_reference (se, arg->expr);
9874 260 : if (arg->expr->symtree->n.sym->attr.proc_pointer
9875 29 : && arg->expr->symtree->n.sym->attr.dummy)
9876 7 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9877 : /* The code below is necessary to create a reference from the calling
9878 : subprogram to the argument of C_FUNLOC() in the call graph.
9879 : Please see PR 117303 for more details. */
9880 260 : se->expr = convert (pvoid_type_node, se->expr);
9881 260 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9882 : }
9883 2130 : else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9884 : {
9885 2054 : gfc_se arg1se;
9886 2054 : gfc_se arg2se;
9887 :
9888 : /* Build the addr_expr for the first argument. The argument is
9889 : already an *address* so we don't need to set want_pointer in
9890 : the gfc_se. */
9891 2054 : gfc_init_se (&arg1se, NULL);
9892 2054 : gfc_conv_expr (&arg1se, arg->expr);
9893 2054 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9894 2054 : gfc_add_block_to_block (&se->post, &arg1se.post);
9895 :
9896 : /* See if we were given two arguments. */
9897 2054 : if (arg->next->expr == NULL)
9898 : /* Only given one arg so generate a null and do a
9899 : not-equal comparison against the first arg. */
9900 1675 : se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9901 : arg1se.expr,
9902 1675 : fold_convert (TREE_TYPE (arg1se.expr),
9903 : null_pointer_node));
9904 : else
9905 : {
9906 379 : tree eq_expr;
9907 379 : tree not_null_expr;
9908 :
9909 : /* Given two arguments so build the arg2se from second arg. */
9910 379 : gfc_init_se (&arg2se, NULL);
9911 379 : gfc_conv_expr (&arg2se, arg->next->expr);
9912 379 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9913 379 : gfc_add_block_to_block (&se->post, &arg2se.post);
9914 :
9915 : /* Generate test to compare that the two args are equal. */
9916 379 : eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9917 : arg1se.expr, arg2se.expr);
9918 : /* Generate test to ensure that the first arg is not null. */
9919 379 : not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9920 : logical_type_node,
9921 : arg1se.expr, null_pointer_node);
9922 :
9923 : /* Finally, the generated test must check that both arg1 is not
9924 : NULL and that it is equal to the second arg. */
9925 379 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9926 : logical_type_node,
9927 : not_null_expr, eq_expr);
9928 : }
9929 : }
9930 76 : else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
9931 : {
9932 : /* There are three cases:
9933 : f_c_string(string) -> trim(string) // c_null_char
9934 : f_c_string(string, .false.) -> trim(string) // c_null_char
9935 : f_c_string(string, .true.) -> string // c_null_char */
9936 :
9937 76 : gfc_expr *string = arg->expr;
9938 76 : gfc_expr *asis = arg->next->expr;
9939 76 : bool need_asis = false, need_trim = false;
9940 76 : gfc_se asis_se;
9941 :
9942 76 : if (!asis)
9943 : {
9944 : need_trim = true;
9945 : need_asis = false;
9946 : }
9947 54 : else if (asis->expr_type == EXPR_CONSTANT)
9948 : {
9949 32 : need_asis = asis->value.logical;
9950 32 : need_trim = !need_asis;
9951 : }
9952 : else
9953 : {
9954 : /* A conditional expression is needed. */
9955 22 : need_asis = true;
9956 22 : need_trim = true;
9957 22 : gfc_init_se (&asis_se, se);
9958 22 : gfc_conv_expr (&asis_se, asis);
9959 22 : if (asis->expr_type == EXPR_VARIABLE
9960 22 : && asis->symtree->n.sym->attr.dummy
9961 10 : && asis->symtree->n.sym->attr.optional)
9962 : {
9963 6 : tree present = gfc_conv_expr_present (asis->symtree->n.sym);
9964 6 : asis_se.expr
9965 6 : = build3_loc (input_location, COND_EXPR,
9966 : logical_type_node, present,
9967 : asis_se.expr, logical_false_node);
9968 : }
9969 22 : gfc_make_safe_expr (&asis_se);
9970 : }
9971 :
9972 : /* Handle the case of a constant string argument first. */
9973 76 : if (string->expr_type == EXPR_CONSTANT)
9974 : {
9975 : /* Output for the asis "then" case goes tlen/tstr, and the
9976 : trimmed case in elen/estr. */
9977 34 : tree elen, estr, tlen, tstr;
9978 34 : elen = estr = tlen = tstr = NULL_TREE;
9979 :
9980 34 : gfc_char_t *orig_string = string->value.character.string;
9981 34 : gfc_charlen_t orig_len = string->value.character.length;
9982 34 : gfc_charlen_t n;
9983 34 : gfc_char_t *buf
9984 34 : = (gfc_char_t *) alloca ((orig_len + 1) * sizeof (gfc_char_t));
9985 34 : memcpy (buf, orig_string, orig_len * sizeof (gfc_char_t));
9986 34 : buf[orig_len] = '\0';
9987 34 : int kind = gfc_default_character_kind;
9988 34 : gcc_assert (string->ts.kind == kind);
9989 :
9990 : /* Build the new string constant(s). */
9991 34 : if (need_asis)
9992 : {
9993 14 : tstr = gfc_build_wide_string_const (kind, orig_len + 1, buf);
9994 14 : tlen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tstr)));
9995 14 : if (!need_trim)
9996 : {
9997 10 : se->expr = tstr;
9998 10 : se->string_length = tlen;
9999 10 : return;
10000 : }
10001 : }
10002 24 : if (need_trim)
10003 : {
10004 72 : for (n = orig_len; n; n--)
10005 72 : if (buf[n - 1] != ' ')
10006 : break;
10007 24 : buf[n] = '\0';
10008 24 : if (need_asis && n == orig_len)
10009 : {
10010 : /* Special case; trimming is a no-op. Add side-effects
10011 : from the condition and then just return the string
10012 : without a conditional. */
10013 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10014 2 : se->expr = tstr;
10015 2 : se->string_length = tlen;
10016 2 : return;
10017 : }
10018 : else
10019 : {
10020 22 : estr = gfc_build_wide_string_const (kind, n + 1, buf);
10021 22 : elen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (estr)));
10022 : }
10023 22 : if (!need_asis)
10024 : {
10025 20 : se->expr = estr;
10026 20 : se->string_length = elen;
10027 20 : return;
10028 : }
10029 : }
10030 0 : gcc_assert (need_asis && need_trim);
10031 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10032 2 : se->expr
10033 2 : = fold_build3_loc (input_location, COND_EXPR,
10034 : pchar_type_node, asis_se.expr,
10035 : tstr, estr);
10036 2 : se->string_length
10037 2 : = fold_build3_loc (input_location, COND_EXPR,
10038 : gfc_charlen_type_node, asis_se.expr,
10039 : tlen, elen);
10040 2 : return;
10041 : }
10042 : else
10043 : /* We have to generate code to do the string transformation(s) at
10044 : runtime. */
10045 : {
10046 42 : tree tmp;
10047 :
10048 : /* Convert input string. */
10049 42 : gfc_se sse;
10050 42 : gfc_init_se (&sse, se);
10051 42 : gfc_conv_expr (&sse, string);
10052 42 : gfc_conv_string_parameter (&sse);
10053 42 : gfc_make_safe_expr (&sse);
10054 42 : gfc_add_block_to_block (&se->pre, &sse.pre);
10055 :
10056 : /* Use a temporary for the (possibly trimmed) string length. */
10057 42 : tree lenvar = gfc_create_var (gfc_charlen_type_node, NULL);
10058 42 : gfc_add_modify (&se->pre, lenvar, sse.string_length);
10059 :
10060 : /* Build the expression for a call to LEN_TRIM if we may need
10061 : to trim the string. If it's conditional, handle that too. */
10062 42 : if (need_trim)
10063 : {
10064 36 : tree trimlen
10065 36 : = build_call_expr_loc (input_location,
10066 : gfor_fndecl_string_len_trim, 2,
10067 : lenvar, sse.expr);
10068 36 : if (need_asis)
10069 : {
10070 18 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10071 18 : tmp = fold_build3_loc (input_location, COND_EXPR,
10072 : gfc_charlen_type_node, asis_se.expr,
10073 : lenvar, trimlen);
10074 18 : gfc_add_modify (&se->pre, lenvar, tmp);
10075 : }
10076 : else
10077 18 : gfc_add_modify (&se->pre, lenvar, trimlen);
10078 : }
10079 :
10080 : /* Allocate a new string newvar that is lenvar+1 bytes long.
10081 : memcpy the first lenvar bytes from the input string, and
10082 : add a null character. Note that lenvar, the length of
10083 : the (trimmed) original string, has type gfc_charlen_type_node,
10084 : but newlen is size_type_node. */
10085 42 : tree string_type_node = build_pointer_type (char_type_node);
10086 42 : tree newvar = gfc_create_var (string_type_node, NULL);
10087 42 : tree newlen = fold_build2_loc (input_location, PLUS_EXPR,
10088 : size_type_node,
10089 : fold_convert (size_type_node,
10090 : lenvar),
10091 : size_one_node);
10092 42 : gfc_add_modify (&se->pre, newvar,
10093 : gfc_call_malloc (&se->pre, string_type_node,
10094 : newlen));
10095 42 : tmp = build_call_expr_loc (input_location,
10096 : builtin_decl_explicit (BUILT_IN_MEMCPY),
10097 : 3,
10098 : fold_convert (pvoid_type_node, newvar),
10099 : fold_convert (pvoid_type_node, sse.expr),
10100 : fold_convert (size_type_node, lenvar));
10101 42 : gfc_add_expr_to_block (&se->pre, tmp);
10102 42 : tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
10103 : string_type_node, newvar,
10104 : fold_convert (size_type_node, lenvar));
10105 42 : tmp = fold_build1_loc (input_location, INDIRECT_REF,
10106 : char_type_node, tmp);
10107 42 : gfc_add_modify (&se->pre, tmp,
10108 : fold_convert (char_type_node, integer_zero_node));
10109 :
10110 : /* Remember to free the string later. */
10111 42 : tmp = gfc_call_free (newvar);
10112 42 : gfc_add_expr_to_block (&se->post, tmp);
10113 :
10114 : /* Return the result. */
10115 42 : se->expr = newvar;
10116 42 : se->string_length = fold_convert (gfc_charlen_type_node, newlen);
10117 42 : return;
10118 : }
10119 : }
10120 : else
10121 0 : gcc_unreachable ();
10122 : }
10123 :
10124 :
10125 : /* The following routine generates code for the intrinsic
10126 : subroutines from the ISO_C_BINDING module:
10127 : * C_F_POINTER
10128 : * C_F_PROCPOINTER. */
10129 :
10130 : static tree
10131 3197 : conv_isocbinding_subroutine (gfc_code *code)
10132 : {
10133 3197 : gfc_expr *cptr, *fptr, *shape, *lower;
10134 3197 : gfc_se se, cptrse, fptrse, shapese, lowerse;
10135 3197 : gfc_ss *shape_ss, *lower_ss;
10136 3197 : tree desc, dim, tmp, stride, offset, lbound, ubound;
10137 3197 : stmtblock_t body, block;
10138 3197 : gfc_loopinfo loop;
10139 3197 : gfc_actual_arglist *arg;
10140 :
10141 3197 : arg = code->ext.actual;
10142 3197 : cptr = arg->expr;
10143 3197 : fptr = arg->next->expr;
10144 3197 : shape = arg->next->next ? arg->next->next->expr : NULL;
10145 3115 : lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
10146 :
10147 3197 : gfc_init_se (&se, NULL);
10148 3197 : gfc_init_se (&cptrse, NULL);
10149 3197 : gfc_conv_expr (&cptrse, cptr);
10150 3197 : gfc_add_block_to_block (&se.pre, &cptrse.pre);
10151 3197 : gfc_add_block_to_block (&se.post, &cptrse.post);
10152 :
10153 3197 : gfc_init_se (&fptrse, NULL);
10154 3197 : if (fptr->rank == 0)
10155 : {
10156 2712 : fptrse.want_pointer = 1;
10157 2712 : gfc_conv_expr (&fptrse, fptr);
10158 2712 : gfc_add_block_to_block (&se.pre, &fptrse.pre);
10159 2712 : gfc_add_block_to_block (&se.post, &fptrse.post);
10160 2712 : if (fptr->symtree->n.sym->attr.proc_pointer
10161 81 : && fptr->symtree->n.sym->attr.dummy)
10162 19 : fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
10163 2712 : se.expr
10164 2712 : = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
10165 : fptrse.expr,
10166 2712 : fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
10167 2712 : gfc_add_expr_to_block (&se.pre, se.expr);
10168 2712 : gfc_add_block_to_block (&se.pre, &se.post);
10169 2712 : return gfc_finish_block (&se.pre);
10170 : }
10171 :
10172 485 : gfc_start_block (&block);
10173 :
10174 : /* Get the descriptor of the Fortran pointer. */
10175 485 : fptrse.descriptor_only = 1;
10176 485 : gfc_conv_expr_descriptor (&fptrse, fptr);
10177 485 : gfc_add_block_to_block (&block, &fptrse.pre);
10178 485 : desc = fptrse.expr;
10179 :
10180 : /* Set the span field. */
10181 485 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
10182 485 : tmp = fold_convert (gfc_array_index_type, tmp);
10183 485 : gfc_conv_descriptor_span_set (&block, desc, tmp);
10184 :
10185 : /* Set data value, dtype, and offset. */
10186 485 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
10187 485 : gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
10188 485 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
10189 485 : gfc_get_dtype (TREE_TYPE (desc)));
10190 :
10191 : /* Start scalarization of the bounds, using the shape argument. */
10192 :
10193 485 : shape_ss = gfc_walk_expr (shape);
10194 485 : gcc_assert (shape_ss != gfc_ss_terminator);
10195 485 : gfc_init_se (&shapese, NULL);
10196 485 : if (lower)
10197 : {
10198 12 : lower_ss = gfc_walk_expr (lower);
10199 12 : gcc_assert (lower_ss != gfc_ss_terminator);
10200 12 : gfc_init_se (&lowerse, NULL);
10201 : }
10202 :
10203 485 : gfc_init_loopinfo (&loop);
10204 485 : gfc_add_ss_to_loop (&loop, shape_ss);
10205 485 : if (lower)
10206 12 : gfc_add_ss_to_loop (&loop, lower_ss);
10207 485 : gfc_conv_ss_startstride (&loop);
10208 485 : gfc_conv_loop_setup (&loop, &fptr->where);
10209 485 : gfc_mark_ss_chain_used (shape_ss, 1);
10210 485 : if (lower)
10211 12 : gfc_mark_ss_chain_used (lower_ss, 1);
10212 :
10213 485 : gfc_copy_loopinfo_to_se (&shapese, &loop);
10214 485 : shapese.ss = shape_ss;
10215 485 : if (lower)
10216 : {
10217 12 : gfc_copy_loopinfo_to_se (&lowerse, &loop);
10218 12 : lowerse.ss = lower_ss;
10219 : }
10220 :
10221 485 : stride = gfc_create_var (gfc_array_index_type, "stride");
10222 485 : offset = gfc_create_var (gfc_array_index_type, "offset");
10223 485 : gfc_add_modify (&block, stride, gfc_index_one_node);
10224 485 : gfc_add_modify (&block, offset, gfc_index_zero_node);
10225 :
10226 : /* Loop body. */
10227 485 : gfc_start_scalarized_body (&loop, &body);
10228 :
10229 485 : dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10230 : loop.loopvar[0], loop.from[0]);
10231 :
10232 485 : if (lower)
10233 : {
10234 12 : gfc_conv_expr (&lowerse, lower);
10235 12 : gfc_add_block_to_block (&body, &lowerse.pre);
10236 12 : lbound = fold_convert (gfc_array_index_type, lowerse.expr);
10237 12 : gfc_add_block_to_block (&body, &lowerse.post);
10238 : }
10239 : else
10240 473 : lbound = gfc_index_one_node;
10241 :
10242 : /* Set bounds and stride. */
10243 485 : gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
10244 485 : gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
10245 :
10246 485 : gfc_conv_expr (&shapese, shape);
10247 485 : gfc_add_block_to_block (&body, &shapese.pre);
10248 485 : ubound = fold_build2_loc (
10249 : input_location, MINUS_EXPR, gfc_array_index_type,
10250 : fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
10251 : fold_convert (gfc_array_index_type, shapese.expr)),
10252 : gfc_index_one_node);
10253 485 : gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
10254 485 : gfc_add_block_to_block (&body, &shapese.post);
10255 :
10256 : /* Calculate offset. */
10257 485 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10258 : stride, lbound);
10259 485 : gfc_add_modify (&body, offset,
10260 : fold_build2_loc (input_location, PLUS_EXPR,
10261 : gfc_array_index_type, offset, tmp));
10262 :
10263 : /* Update stride. */
10264 485 : gfc_add_modify (
10265 : &body, stride,
10266 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
10267 : fold_convert (gfc_array_index_type, shapese.expr)));
10268 : /* Finish scalarization loop. */
10269 485 : gfc_trans_scalarizing_loops (&loop, &body);
10270 485 : gfc_add_block_to_block (&block, &loop.pre);
10271 485 : gfc_add_block_to_block (&block, &loop.post);
10272 485 : gfc_add_block_to_block (&block, &fptrse.post);
10273 485 : gfc_cleanup_loop (&loop);
10274 :
10275 485 : gfc_add_modify (&block, offset,
10276 : fold_build1_loc (input_location, NEGATE_EXPR,
10277 : gfc_array_index_type, offset));
10278 485 : gfc_conv_descriptor_offset_set (&block, desc, offset);
10279 :
10280 485 : gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
10281 485 : gfc_add_block_to_block (&se.pre, &se.post);
10282 485 : return gfc_finish_block (&se.pre);
10283 : }
10284 :
10285 :
10286 : /* The following routine generates code for both forms of the intrinsic
10287 : subroutine C_F_STRPOINTER from the ISO_C_BINDING module. */
10288 : static tree
10289 60 : conv_isocbinding_subroutine_strpointer (gfc_code *code)
10290 : {
10291 60 : gfc_actual_arglist *arg = code->ext.actual;
10292 60 : gfc_expr *arg0 = arg->expr;
10293 60 : gfc_expr *fstrptr = arg->next->expr;
10294 60 : gfc_expr *nchars = arg->next->next->expr;
10295 60 : tree ptr;
10296 60 : tree size = NULL_TREE;
10297 60 : tree nc = NULL_TREE;
10298 60 : tree fstrptr_ptr, fstrptr_len;
10299 60 : stmtblock_t block;
10300 60 : gfc_init_block (&block);
10301 60 : gfc_se se0, se1, se2;
10302 60 : gfc_init_se (&se0, NULL);
10303 60 : gfc_init_se (&se1, NULL);
10304 60 : gfc_init_se (&se2, NULL);
10305 :
10306 : /* arg0 can either be a simply contiguous rank-one character array,
10307 : or a scalar of type c_ptr that points to a contiguous array.
10308 : In the first case nchars may be omitted and defaults to the size
10309 : of the array. */
10310 60 : if (arg0->rank == 1)
10311 : {
10312 42 : gfc_array_ref *ar = gfc_find_array_ref (arg0);
10313 42 : if (ar->as && ar->as->type == AS_ASSUMED_SIZE
10314 12 : && (ar->type == AR_FULL || ar->end[0] == nullptr))
10315 : /* No size available. */
10316 12 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, NULL);
10317 : else
10318 : {
10319 30 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, &size);
10320 30 : gcc_assert (size);
10321 : }
10322 42 : ptr = se0.expr;
10323 : }
10324 18 : else if (arg0->rank == 0)
10325 : {
10326 : /* Scalar case. arg0 is a C pointer to the string, and the
10327 : nchars argument is required. */
10328 18 : gfc_conv_expr (&se0, arg0);
10329 18 : ptr = se0.expr;
10330 : /* We already issued a diagnostic for this in parsing. */
10331 18 : gcc_assert (nchars);
10332 : }
10333 : else
10334 0 : gcc_unreachable ();
10335 :
10336 : /* Translate the fortran array pointer argument. AFAICT the
10337 : representation here is that this returns the pointer location in
10338 : se1.expr and there is a separate decl for the length.
10339 : Of course none of this is properly documented.... :-( */
10340 60 : gfc_conv_expr (&se1, fstrptr);
10341 60 : fstrptr_ptr = se1.expr;
10342 60 : gcc_assert (fstrptr->ts.u.cl && fstrptr->ts.u.cl->backend_decl);
10343 60 : fstrptr_len = fstrptr->ts.u.cl->backend_decl;
10344 :
10345 : /* Translate nchars, if provided. If we have both the array size
10346 : and nchars, take the minimum value. NC is the tree expr to hold
10347 : the value. */
10348 60 : if (nchars)
10349 : {
10350 30 : gfc_conv_expr (&se2, nchars);
10351 30 : nc = se2.expr;
10352 30 : if (size)
10353 0 : nc = fold_build2_loc (input_location, MIN_EXPR,
10354 0 : TREE_TYPE (nc), nc, size);
10355 : /* Check for the case where an optional dummy parameter is
10356 : passed as the optional nchars argument. It's not supposed to
10357 : be omitted if we don't also have an array size; rather than
10358 : produce a run-time error, assume size 0. */
10359 30 : if (nchars->expr_type == EXPR_VARIABLE
10360 18 : && nchars->symtree->n.sym->attr.dummy
10361 18 : && nchars->symtree->n.sym->attr.optional)
10362 : {
10363 12 : tree present = gfc_conv_expr_present (nchars->symtree->n.sym);
10364 12 : nc = build3_loc (input_location, COND_EXPR,
10365 12 : TREE_TYPE (nc), present, nc,
10366 24 : size ? size : build_int_cst (TREE_TYPE (nc), 0));
10367 : }
10368 : }
10369 : else
10370 : {
10371 30 : gcc_assert (size);
10372 : nc = size;
10373 : }
10374 :
10375 : /* Collect argument side-effect statements. */
10376 60 : gfc_add_block_to_block (&block, &se0.pre);
10377 60 : gfc_add_block_to_block (&block, &se1.pre);
10378 60 : gfc_add_block_to_block (&block, &se2.pre);
10379 :
10380 : /* Generate a call to builtin_strnlen to get the C string length
10381 : for the output fstrptr. */
10382 60 : ptr = gfc_evaluate_now (ptr, &block);
10383 60 : size = build_call_expr_loc (input_location,
10384 : builtin_decl_explicit (BUILT_IN_STRNLEN), 2,
10385 : fold_convert (const_ptr_type_node, ptr),
10386 : fold_convert (size_type_node, nc));
10387 :
10388 : /* Stuff the raw C char pointer PTR and actual length SIZE into fstrptr. */
10389 60 : gfc_add_modify (&block, fstrptr_ptr,
10390 60 : fold_convert (TREE_TYPE (fstrptr_ptr), ptr));
10391 60 : gfc_add_modify (&block, fstrptr_len,
10392 : fold_convert (gfc_charlen_type_node, size));
10393 :
10394 : /* Collect argument cleanups. */
10395 60 : gfc_add_block_to_block (&block, &se2.post);
10396 60 : gfc_add_block_to_block (&block, &se1.post);
10397 60 : gfc_add_block_to_block (&block, &se0.post);
10398 :
10399 60 : return gfc_finish_block (&block);
10400 : }
10401 :
10402 : /* Save and restore floating-point state. */
10403 :
10404 : tree
10405 942 : gfc_save_fp_state (stmtblock_t *block)
10406 : {
10407 942 : tree type, fpstate, tmp;
10408 :
10409 942 : type = build_array_type (char_type_node,
10410 : build_range_type (size_type_node, size_zero_node,
10411 : size_int (GFC_FPE_STATE_BUFFER_SIZE)));
10412 942 : fpstate = gfc_create_var (type, "fpstate");
10413 942 : fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
10414 :
10415 942 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
10416 : 1, fpstate);
10417 942 : gfc_add_expr_to_block (block, tmp);
10418 :
10419 942 : return fpstate;
10420 : }
10421 :
10422 :
10423 : void
10424 942 : gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
10425 : {
10426 942 : tree tmp;
10427 :
10428 942 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
10429 : 1, fpstate);
10430 942 : gfc_add_expr_to_block (block, tmp);
10431 942 : }
10432 :
10433 :
10434 : /* Generate code for arguments of IEEE functions. */
10435 :
10436 : static void
10437 12457 : conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
10438 : int nargs)
10439 : {
10440 12457 : gfc_actual_arglist *actual;
10441 12457 : gfc_expr *e;
10442 12457 : gfc_se argse;
10443 12457 : int arg;
10444 :
10445 12457 : actual = expr->value.function.actual;
10446 34461 : for (arg = 0; arg < nargs; arg++, actual = actual->next)
10447 : {
10448 22004 : gcc_assert (actual);
10449 22004 : e = actual->expr;
10450 :
10451 22004 : gfc_init_se (&argse, se);
10452 22004 : gfc_conv_expr_val (&argse, e);
10453 :
10454 22004 : gfc_add_block_to_block (&se->pre, &argse.pre);
10455 22004 : gfc_add_block_to_block (&se->post, &argse.post);
10456 22004 : argarray[arg] = argse.expr;
10457 : }
10458 12457 : }
10459 :
10460 :
10461 : /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
10462 : and IEEE_UNORDERED, which translate directly to GCC type-generic
10463 : built-ins. */
10464 :
10465 : static void
10466 1062 : conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
10467 : enum built_in_function code, int nargs)
10468 : {
10469 1062 : tree args[2];
10470 1062 : gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
10471 :
10472 1062 : conv_ieee_function_args (se, expr, args, nargs);
10473 1062 : se->expr = build_call_expr_loc_array (input_location,
10474 : builtin_decl_explicit (code),
10475 : nargs, args);
10476 2388 : STRIP_TYPE_NOPS (se->expr);
10477 1062 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10478 1062 : }
10479 :
10480 :
10481 : /* Generate code for intrinsics IEEE_SIGNBIT. */
10482 :
10483 : static void
10484 624 : conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
10485 : {
10486 624 : tree arg, signbit;
10487 :
10488 624 : conv_ieee_function_args (se, expr, &arg, 1);
10489 624 : signbit = build_call_expr_loc (input_location,
10490 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10491 : 1, arg);
10492 624 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10493 : signbit, integer_zero_node);
10494 624 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
10495 624 : }
10496 :
10497 :
10498 : /* Generate code for IEEE_IS_NORMAL intrinsic:
10499 : IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
10500 :
10501 : static void
10502 312 : conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
10503 : {
10504 312 : tree arg, isnormal, iszero;
10505 :
10506 : /* Convert arg, evaluate it only once. */
10507 312 : conv_ieee_function_args (se, expr, &arg, 1);
10508 312 : arg = gfc_evaluate_now (arg, &se->pre);
10509 :
10510 312 : isnormal = build_call_expr_loc (input_location,
10511 : builtin_decl_explicit (BUILT_IN_ISNORMAL),
10512 : 1, arg);
10513 312 : iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
10514 312 : build_real_from_int_cst (TREE_TYPE (arg),
10515 312 : integer_zero_node));
10516 312 : se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10517 : logical_type_node, isnormal, iszero);
10518 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10519 312 : }
10520 :
10521 :
10522 : /* Generate code for IEEE_IS_NEGATIVE intrinsic:
10523 : IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10524 :
10525 : static void
10526 312 : conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
10527 : {
10528 312 : tree arg, signbit, isnan;
10529 :
10530 : /* Convert arg, evaluate it only once. */
10531 312 : conv_ieee_function_args (se, expr, &arg, 1);
10532 312 : arg = gfc_evaluate_now (arg, &se->pre);
10533 :
10534 312 : isnan = build_call_expr_loc (input_location,
10535 : builtin_decl_explicit (BUILT_IN_ISNAN),
10536 : 1, arg);
10537 936 : STRIP_TYPE_NOPS (isnan);
10538 :
10539 312 : signbit = build_call_expr_loc (input_location,
10540 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10541 : 1, arg);
10542 312 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10543 : signbit, integer_zero_node);
10544 :
10545 312 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10546 : logical_type_node, signbit,
10547 : fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10548 312 : TREE_TYPE(isnan), isnan));
10549 :
10550 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10551 312 : }
10552 :
10553 :
10554 : /* Generate code for IEEE_LOGB and IEEE_RINT. */
10555 :
10556 : static void
10557 240 : conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
10558 : enum built_in_function code)
10559 : {
10560 240 : tree arg, decl, call, fpstate;
10561 240 : int argprec;
10562 :
10563 240 : conv_ieee_function_args (se, expr, &arg, 1);
10564 240 : argprec = TYPE_PRECISION (TREE_TYPE (arg));
10565 240 : decl = builtin_decl_for_precision (code, argprec);
10566 :
10567 : /* Save floating-point state. */
10568 240 : fpstate = gfc_save_fp_state (&se->pre);
10569 :
10570 : /* Make the function call. */
10571 240 : call = build_call_expr_loc (input_location, decl, 1, arg);
10572 240 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
10573 :
10574 : /* Restore floating-point state. */
10575 240 : gfc_restore_fp_state (&se->post, fpstate);
10576 240 : }
10577 :
10578 :
10579 : /* Generate code for IEEE_REM. */
10580 :
10581 : static void
10582 84 : conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
10583 : {
10584 84 : tree args[2], decl, call, fpstate;
10585 84 : int argprec;
10586 :
10587 84 : conv_ieee_function_args (se, expr, args, 2);
10588 :
10589 : /* If arguments have unequal size, convert them to the larger. */
10590 84 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
10591 84 : > TYPE_PRECISION (TREE_TYPE (args[1])))
10592 6 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10593 78 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
10594 78 : > TYPE_PRECISION (TREE_TYPE (args[0])))
10595 24 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
10596 :
10597 84 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10598 84 : decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
10599 :
10600 : /* Save floating-point state. */
10601 84 : fpstate = gfc_save_fp_state (&se->pre);
10602 :
10603 : /* Make the function call. */
10604 84 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10605 84 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10606 :
10607 : /* Restore floating-point state. */
10608 84 : gfc_restore_fp_state (&se->post, fpstate);
10609 84 : }
10610 :
10611 :
10612 : /* Generate code for IEEE_NEXT_AFTER. */
10613 :
10614 : static void
10615 180 : conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
10616 : {
10617 180 : tree args[2], decl, call, fpstate;
10618 180 : int argprec;
10619 :
10620 180 : conv_ieee_function_args (se, expr, args, 2);
10621 :
10622 : /* Result has the characteristics of first argument. */
10623 180 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10624 180 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10625 180 : decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
10626 :
10627 : /* Save floating-point state. */
10628 180 : fpstate = gfc_save_fp_state (&se->pre);
10629 :
10630 : /* Make the function call. */
10631 180 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10632 180 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10633 :
10634 : /* Restore floating-point state. */
10635 180 : gfc_restore_fp_state (&se->post, fpstate);
10636 180 : }
10637 :
10638 :
10639 : /* Generate code for IEEE_SCALB. */
10640 :
10641 : static void
10642 228 : conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10643 : {
10644 228 : tree args[2], decl, call, huge, type;
10645 228 : int argprec, n;
10646 :
10647 228 : conv_ieee_function_args (se, expr, args, 2);
10648 :
10649 : /* Result has the characteristics of first argument. */
10650 228 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10651 228 : decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10652 :
10653 228 : if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10654 : {
10655 : /* We need to fold the integer into the range of a C int. */
10656 18 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10657 18 : type = TREE_TYPE (args[1]);
10658 :
10659 18 : n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10660 18 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10661 : gfc_c_int_kind);
10662 18 : huge = fold_convert (type, huge);
10663 18 : args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10664 : huge);
10665 18 : args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10666 : fold_build1_loc (input_location, NEGATE_EXPR,
10667 : type, huge));
10668 : }
10669 :
10670 228 : args[1] = fold_convert (integer_type_node, args[1]);
10671 :
10672 : /* Make the function call. */
10673 228 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10674 228 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10675 228 : }
10676 :
10677 :
10678 : /* Generate code for IEEE_COPY_SIGN. */
10679 :
10680 : static void
10681 576 : conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10682 : {
10683 576 : tree args[2], decl, sign;
10684 576 : int argprec;
10685 :
10686 576 : conv_ieee_function_args (se, expr, args, 2);
10687 :
10688 : /* Get the sign of the second argument. */
10689 576 : sign = build_call_expr_loc (input_location,
10690 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10691 : 1, args[1]);
10692 576 : sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10693 : sign, integer_zero_node);
10694 :
10695 : /* Create a value of one, with the right sign. */
10696 576 : sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10697 : sign,
10698 : fold_build1_loc (input_location, NEGATE_EXPR,
10699 : integer_type_node,
10700 : integer_one_node),
10701 : integer_one_node);
10702 576 : args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10703 :
10704 576 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10705 576 : decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10706 :
10707 576 : se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10708 576 : }
10709 :
10710 :
10711 : /* Generate code for IEEE_CLASS. */
10712 :
10713 : static void
10714 648 : conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10715 : {
10716 648 : tree arg, c, t1, t2, t3, t4;
10717 :
10718 : /* Convert arg, evaluate it only once. */
10719 648 : conv_ieee_function_args (se, expr, &arg, 1);
10720 648 : arg = gfc_evaluate_now (arg, &se->pre);
10721 :
10722 648 : c = build_call_expr_loc (input_location,
10723 : builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
10724 : build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10725 : build_int_cst (integer_type_node,
10726 : IEEE_POSITIVE_INF),
10727 : build_int_cst (integer_type_node,
10728 : IEEE_POSITIVE_NORMAL),
10729 : build_int_cst (integer_type_node,
10730 : IEEE_POSITIVE_DENORMAL),
10731 : build_int_cst (integer_type_node,
10732 : IEEE_POSITIVE_ZERO),
10733 : arg);
10734 648 : c = gfc_evaluate_now (c, &se->pre);
10735 648 : t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10736 : c, build_int_cst (integer_type_node,
10737 : IEEE_QUIET_NAN));
10738 648 : t2 = build_call_expr_loc (input_location,
10739 : builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
10740 : arg);
10741 648 : t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10742 648 : t2, build_zero_cst (TREE_TYPE (t2)));
10743 648 : t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10744 : logical_type_node, t1, t2);
10745 648 : t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10746 : c, build_int_cst (integer_type_node,
10747 : IEEE_POSITIVE_ZERO));
10748 648 : t4 = build_call_expr_loc (input_location,
10749 : builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
10750 : arg);
10751 648 : t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10752 648 : t4, build_zero_cst (TREE_TYPE (t4)));
10753 648 : t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10754 : logical_type_node, t3, t4);
10755 648 : int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10756 648 : gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10757 648 : gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10758 648 : gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10759 648 : gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10760 648 : gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10761 648 : t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10762 648 : build_int_cst (TREE_TYPE (c), s), c);
10763 648 : t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10764 : t3, t4, c);
10765 648 : t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10766 648 : build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10767 : t3);
10768 648 : tree type = gfc_typenode_for_spec (&expr->ts);
10769 : /* Perform a quick sanity check that the return type is
10770 : IEEE_CLASS_TYPE derived type defined in
10771 : libgfortran/ieee/ieee_arithmetic.F90
10772 : Primarily check that it is a derived type with a single
10773 : member in it. */
10774 648 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10775 648 : tree field = NULL_TREE;
10776 1296 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10777 648 : if (TREE_CODE (f) == FIELD_DECL)
10778 : {
10779 648 : gcc_assert (field == NULL_TREE);
10780 : field = f;
10781 : }
10782 648 : gcc_assert (field);
10783 648 : t1 = fold_convert (TREE_TYPE (field), t1);
10784 648 : se->expr = build_constructor_single (type, field, t1);
10785 648 : }
10786 :
10787 :
10788 : /* Generate code for IEEE_VALUE. */
10789 :
10790 : static void
10791 1111 : conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10792 : {
10793 1111 : tree args[2], arg, ret, tmp;
10794 1111 : stmtblock_t body;
10795 :
10796 : /* Convert args, evaluate the second one only once. */
10797 1111 : conv_ieee_function_args (se, expr, args, 2);
10798 1111 : arg = gfc_evaluate_now (args[1], &se->pre);
10799 :
10800 1111 : tree type = TREE_TYPE (arg);
10801 : /* Perform a quick sanity check that the second argument's type is
10802 : IEEE_CLASS_TYPE derived type defined in
10803 : libgfortran/ieee/ieee_arithmetic.F90
10804 : Primarily check that it is a derived type with a single
10805 : member in it. */
10806 1111 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10807 1111 : tree field = NULL_TREE;
10808 2222 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10809 1111 : if (TREE_CODE (f) == FIELD_DECL)
10810 : {
10811 1111 : gcc_assert (field == NULL_TREE);
10812 : field = f;
10813 : }
10814 1111 : gcc_assert (field);
10815 1111 : arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10816 : arg, field, NULL_TREE);
10817 1111 : arg = gfc_evaluate_now (arg, &se->pre);
10818 :
10819 1111 : type = gfc_typenode_for_spec (&expr->ts);
10820 1111 : gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10821 1111 : ret = gfc_create_var (type, NULL);
10822 :
10823 1111 : gfc_init_block (&body);
10824 :
10825 1111 : tree end_label = gfc_build_label_decl (NULL_TREE);
10826 12221 : for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10827 : {
10828 11110 : tree label = gfc_build_label_decl (NULL_TREE);
10829 11110 : tree low = build_int_cst (TREE_TYPE (arg), c);
10830 11110 : tmp = build_case_label (low, low, label);
10831 11110 : gfc_add_expr_to_block (&body, tmp);
10832 :
10833 11110 : REAL_VALUE_TYPE real;
10834 11110 : int k;
10835 11110 : switch (c)
10836 : {
10837 1111 : case IEEE_SIGNALING_NAN:
10838 1111 : real_nan (&real, "", 0, TYPE_MODE (type));
10839 1111 : break;
10840 1111 : case IEEE_QUIET_NAN:
10841 1111 : real_nan (&real, "", 1, TYPE_MODE (type));
10842 1111 : break;
10843 1111 : case IEEE_NEGATIVE_INF:
10844 1111 : real_inf (&real);
10845 1111 : real = real_value_negate (&real);
10846 1111 : break;
10847 1111 : case IEEE_NEGATIVE_NORMAL:
10848 1111 : real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10849 1111 : break;
10850 1111 : case IEEE_NEGATIVE_DENORMAL:
10851 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10852 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10853 : type, GFC_RND_MODE);
10854 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10855 1111 : real = real_value_negate (&real);
10856 1111 : break;
10857 1111 : case IEEE_NEGATIVE_ZERO:
10858 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10859 1111 : real = real_value_negate (&real);
10860 1111 : break;
10861 1111 : case IEEE_POSITIVE_ZERO:
10862 : /* Make this also the default: label. The other possibility
10863 : would be to add a separate default: label followed by
10864 : __builtin_unreachable (). */
10865 1111 : label = gfc_build_label_decl (NULL_TREE);
10866 1111 : tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10867 1111 : gfc_add_expr_to_block (&body, tmp);
10868 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10869 1111 : break;
10870 1111 : case IEEE_POSITIVE_DENORMAL:
10871 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10872 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10873 : type, GFC_RND_MODE);
10874 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10875 1111 : break;
10876 1111 : case IEEE_POSITIVE_NORMAL:
10877 1111 : real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10878 1111 : break;
10879 1111 : case IEEE_POSITIVE_INF:
10880 1111 : real_inf (&real);
10881 1111 : break;
10882 : default:
10883 : gcc_unreachable ();
10884 : }
10885 :
10886 11110 : tree val = build_real (type, real);
10887 11110 : gfc_add_modify (&body, ret, val);
10888 :
10889 11110 : tmp = build1_v (GOTO_EXPR, end_label);
10890 11110 : gfc_add_expr_to_block (&body, tmp);
10891 : }
10892 :
10893 1111 : tmp = gfc_finish_block (&body);
10894 1111 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10895 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10896 :
10897 1111 : tmp = build1_v (LABEL_EXPR, end_label);
10898 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10899 :
10900 1111 : se->expr = ret;
10901 1111 : }
10902 :
10903 :
10904 : /* Generate code for IEEE_FMA. */
10905 :
10906 : static void
10907 120 : conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10908 : {
10909 120 : tree args[3], decl, call;
10910 120 : int argprec;
10911 :
10912 120 : conv_ieee_function_args (se, expr, args, 3);
10913 :
10914 : /* All three arguments should have the same type. */
10915 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10916 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10917 :
10918 : /* Call the type-generic FMA built-in. */
10919 120 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10920 120 : decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
10921 120 : call = build_call_expr_loc_array (input_location, decl, 3, args);
10922 :
10923 : /* Convert to the final type. */
10924 120 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10925 120 : }
10926 :
10927 :
10928 : /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10929 :
10930 : static void
10931 3072 : conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10932 : const char *name)
10933 : {
10934 3072 : tree args[2], func;
10935 3072 : built_in_function fn;
10936 :
10937 3072 : conv_ieee_function_args (se, expr, args, 2);
10938 3072 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10939 3072 : args[0] = gfc_evaluate_now (args[0], &se->pre);
10940 3072 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10941 :
10942 3072 : if (startswith (name, "mag"))
10943 : {
10944 : /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10945 : fminmag() and fmaxmag(), which do not exist as built-ins.
10946 :
10947 : Following glibc, we emit this:
10948 :
10949 : fminmag (x, y) {
10950 : ax = ABS (x);
10951 : ay = ABS (y);
10952 : if (isless (ax, ay))
10953 : return x;
10954 : else if (isgreater (ax, ay))
10955 : return y;
10956 : else if (ax == ay)
10957 : return x < y ? x : y;
10958 : else if (issignaling (x) || issignaling (y))
10959 : return x + y;
10960 : else
10961 : return isnan (y) ? x : y;
10962 : }
10963 :
10964 : fmaxmag (x, y) {
10965 : ax = ABS (x);
10966 : ay = ABS (y);
10967 : if (isgreater (ax, ay))
10968 : return x;
10969 : else if (isless (ax, ay))
10970 : return y;
10971 : else if (ax == ay)
10972 : return x > y ? x : y;
10973 : else if (issignaling (x) || issignaling (y))
10974 : return x + y;
10975 : else
10976 : return isnan (y) ? x : y;
10977 : }
10978 :
10979 : */
10980 :
10981 1536 : tree abs0, abs1, sig0, sig1;
10982 1536 : tree cond1, cond2, cond3, cond4, cond5;
10983 1536 : tree res;
10984 1536 : tree type = TREE_TYPE (args[0]);
10985 :
10986 1536 : func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
10987 1536 : abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
10988 1536 : abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
10989 1536 : abs0 = gfc_evaluate_now (abs0, &se->pre);
10990 1536 : abs1 = gfc_evaluate_now (abs1, &se->pre);
10991 :
10992 1536 : cond5 = build_call_expr_loc (input_location,
10993 : builtin_decl_explicit (BUILT_IN_ISNAN),
10994 : 1, args[1]);
10995 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
10996 : args[0], args[1]);
10997 :
10998 1536 : sig0 = build_call_expr_loc (input_location,
10999 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11000 : 1, args[0]);
11001 1536 : sig1 = build_call_expr_loc (input_location,
11002 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11003 : 1, args[1]);
11004 1536 : cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
11005 : logical_type_node, sig0, sig1);
11006 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
11007 : fold_build2_loc (input_location, PLUS_EXPR,
11008 : type, args[0], args[1]),
11009 : res);
11010 :
11011 1536 : cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11012 : abs0, abs1);
11013 2304 : res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
11014 : fold_build2_loc (input_location,
11015 : max ? MAX_EXPR : MIN_EXPR,
11016 : type, args[0], args[1]),
11017 : res);
11018 :
11019 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
11020 1536 : cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11021 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
11022 : args[1], res);
11023 :
11024 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
11025 1536 : cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11026 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
11027 : args[0], res);
11028 :
11029 1536 : se->expr = res;
11030 : }
11031 : else
11032 : {
11033 : /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
11034 1536 : fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
11035 1536 : func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind);
11036 1536 : se->expr = build_call_expr_loc_array (input_location, func, 2, args);
11037 : }
11038 3072 : }
11039 :
11040 :
11041 : /* Generate code for comparison functions IEEE_QUIET_* and
11042 : IEEE_SIGNALING_*. */
11043 :
11044 : static void
11045 3888 : conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
11046 : const char *name)
11047 : {
11048 3888 : tree args[2];
11049 3888 : tree arg1, arg2, res;
11050 :
11051 : /* Evaluate arguments only once. */
11052 3888 : conv_ieee_function_args (se, expr, args, 2);
11053 3888 : arg1 = gfc_evaluate_now (args[0], &se->pre);
11054 3888 : arg2 = gfc_evaluate_now (args[1], &se->pre);
11055 :
11056 3888 : if (startswith (name, "eq"))
11057 : {
11058 648 : if (signaling)
11059 324 : res = build_call_expr_loc (input_location,
11060 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11061 : 2, arg1, arg2);
11062 : else
11063 324 : res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11064 : arg1, arg2);
11065 : }
11066 3240 : else if (startswith (name, "ne"))
11067 : {
11068 648 : if (signaling)
11069 : {
11070 324 : res = build_call_expr_loc (input_location,
11071 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11072 : 2, arg1, arg2);
11073 324 : res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
11074 : logical_type_node, res);
11075 : }
11076 : else
11077 324 : res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
11078 : arg1, arg2);
11079 : }
11080 2592 : else if (startswith (name, "ge"))
11081 : {
11082 648 : if (signaling)
11083 324 : res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11084 : arg1, arg2);
11085 : else
11086 324 : res = build_call_expr_loc (input_location,
11087 : builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
11088 : 2, arg1, arg2);
11089 : }
11090 1944 : else if (startswith (name, "gt"))
11091 : {
11092 648 : if (signaling)
11093 324 : res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
11094 : arg1, arg2);
11095 : else
11096 324 : res = build_call_expr_loc (input_location,
11097 : builtin_decl_explicit (BUILT_IN_ISGREATER),
11098 : 2, arg1, arg2);
11099 : }
11100 1296 : else if (startswith (name, "le"))
11101 : {
11102 648 : if (signaling)
11103 324 : res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
11104 : arg1, arg2);
11105 : else
11106 324 : res = build_call_expr_loc (input_location,
11107 : builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
11108 : 2, arg1, arg2);
11109 : }
11110 648 : else if (startswith (name, "lt"))
11111 : {
11112 648 : if (signaling)
11113 324 : res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11114 : arg1, arg2);
11115 : else
11116 324 : res = build_call_expr_loc (input_location,
11117 : builtin_decl_explicit (BUILT_IN_ISLESS),
11118 : 2, arg1, arg2);
11119 : }
11120 : else
11121 0 : gcc_unreachable ();
11122 :
11123 3888 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
11124 3888 : }
11125 :
11126 :
11127 : /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
11128 : module. */
11129 :
11130 : bool
11131 13939 : gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
11132 : {
11133 13939 : const char *name = expr->value.function.name;
11134 :
11135 13939 : if (startswith (name, "_gfortran_ieee_is_nan"))
11136 522 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
11137 13417 : else if (startswith (name, "_gfortran_ieee_is_finite"))
11138 372 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
11139 13045 : else if (startswith (name, "_gfortran_ieee_unordered"))
11140 168 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
11141 12877 : else if (startswith (name, "_gfortran_ieee_signbit"))
11142 624 : conv_intrinsic_ieee_signbit (se, expr);
11143 12253 : else if (startswith (name, "_gfortran_ieee_is_normal"))
11144 312 : conv_intrinsic_ieee_is_normal (se, expr);
11145 11941 : else if (startswith (name, "_gfortran_ieee_is_negative"))
11146 312 : conv_intrinsic_ieee_is_negative (se, expr);
11147 11629 : else if (startswith (name, "_gfortran_ieee_copy_sign"))
11148 576 : conv_intrinsic_ieee_copy_sign (se, expr);
11149 11053 : else if (startswith (name, "_gfortran_ieee_scalb"))
11150 228 : conv_intrinsic_ieee_scalb (se, expr);
11151 10825 : else if (startswith (name, "_gfortran_ieee_next_after"))
11152 180 : conv_intrinsic_ieee_next_after (se, expr);
11153 10645 : else if (startswith (name, "_gfortran_ieee_rem"))
11154 84 : conv_intrinsic_ieee_rem (se, expr);
11155 10561 : else if (startswith (name, "_gfortran_ieee_logb"))
11156 144 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
11157 10417 : else if (startswith (name, "_gfortran_ieee_rint"))
11158 96 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
11159 10321 : else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
11160 648 : conv_intrinsic_ieee_class (se, expr);
11161 9673 : else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
11162 1111 : conv_intrinsic_ieee_value (se, expr);
11163 8562 : else if (startswith (name, "_gfortran_ieee_fma"))
11164 120 : conv_intrinsic_ieee_fma (se, expr);
11165 8442 : else if (startswith (name, "_gfortran_ieee_min_num_"))
11166 1536 : conv_intrinsic_ieee_minmax (se, expr, 0, name + 23);
11167 6906 : else if (startswith (name, "_gfortran_ieee_max_num_"))
11168 1536 : conv_intrinsic_ieee_minmax (se, expr, 1, name + 23);
11169 5370 : else if (startswith (name, "_gfortran_ieee_quiet_"))
11170 1944 : conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
11171 3426 : else if (startswith (name, "_gfortran_ieee_signaling_"))
11172 1944 : conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
11173 : else
11174 : /* It is not among the functions we translate directly. We return
11175 : false, so a library function call is emitted. */
11176 : return false;
11177 :
11178 : return true;
11179 : }
11180 :
11181 :
11182 : /* Generate a direct call to malloc() for the MALLOC intrinsic. */
11183 :
11184 : static void
11185 16 : gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
11186 : {
11187 16 : tree arg, res, restype;
11188 :
11189 16 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
11190 16 : arg = fold_convert (size_type_node, arg);
11191 16 : res = build_call_expr_loc (input_location,
11192 : builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
11193 16 : restype = gfc_typenode_for_spec (&expr->ts);
11194 16 : se->expr = fold_convert (restype, res);
11195 16 : }
11196 :
11197 :
11198 : /* Generate code for an intrinsic function. Some map directly to library
11199 : calls, others get special handling. In some cases the name of the function
11200 : used depends on the type specifiers. */
11201 :
11202 : void
11203 263933 : gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
11204 : {
11205 263933 : const char *name;
11206 263933 : int lib, kind;
11207 263933 : tree fndecl;
11208 :
11209 263933 : name = &expr->value.function.name[2];
11210 :
11211 263933 : if (expr->rank > 0)
11212 : {
11213 50363 : lib = gfc_is_intrinsic_libcall (expr);
11214 50363 : if (lib != 0)
11215 : {
11216 19187 : if (lib == 1)
11217 11797 : se->ignore_optional = 1;
11218 :
11219 19187 : switch (expr->value.function.isym->id)
11220 : {
11221 5831 : case GFC_ISYM_EOSHIFT:
11222 5831 : case GFC_ISYM_PACK:
11223 5831 : case GFC_ISYM_RESHAPE:
11224 5831 : case GFC_ISYM_REDUCE:
11225 : /* For all of those the first argument specifies the type and the
11226 : third is optional. */
11227 5831 : conv_generic_with_optional_char_arg (se, expr, 1, 3);
11228 5831 : break;
11229 :
11230 1116 : case GFC_ISYM_FINDLOC:
11231 1116 : gfc_conv_intrinsic_findloc (se, expr);
11232 1116 : break;
11233 :
11234 2935 : case GFC_ISYM_MINLOC:
11235 2935 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11236 2935 : break;
11237 :
11238 2439 : case GFC_ISYM_MAXLOC:
11239 2439 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11240 2439 : break;
11241 :
11242 6866 : default:
11243 6866 : gfc_conv_intrinsic_funcall (se, expr);
11244 6866 : break;
11245 : }
11246 :
11247 19187 : return;
11248 : }
11249 : }
11250 :
11251 244746 : switch (expr->value.function.isym->id)
11252 : {
11253 0 : case GFC_ISYM_NONE:
11254 0 : gcc_unreachable ();
11255 :
11256 529 : case GFC_ISYM_REPEAT:
11257 529 : gfc_conv_intrinsic_repeat (se, expr);
11258 529 : break;
11259 :
11260 578 : case GFC_ISYM_TRIM:
11261 578 : gfc_conv_intrinsic_trim (se, expr);
11262 578 : break;
11263 :
11264 42 : case GFC_ISYM_SC_KIND:
11265 42 : gfc_conv_intrinsic_sc_kind (se, expr);
11266 42 : break;
11267 :
11268 45 : case GFC_ISYM_SI_KIND:
11269 45 : gfc_conv_intrinsic_si_kind (se, expr);
11270 45 : break;
11271 :
11272 6 : case GFC_ISYM_SL_KIND:
11273 6 : gfc_conv_intrinsic_sl_kind (se, expr);
11274 6 : break;
11275 :
11276 82 : case GFC_ISYM_SR_KIND:
11277 82 : gfc_conv_intrinsic_sr_kind (se, expr);
11278 82 : break;
11279 :
11280 228 : case GFC_ISYM_EXPONENT:
11281 228 : gfc_conv_intrinsic_exponent (se, expr);
11282 228 : break;
11283 :
11284 316 : case GFC_ISYM_SCAN:
11285 316 : kind = expr->value.function.actual->expr->ts.kind;
11286 316 : if (kind == 1)
11287 250 : fndecl = gfor_fndecl_string_scan;
11288 66 : else if (kind == 4)
11289 66 : fndecl = gfor_fndecl_string_scan_char4;
11290 : else
11291 0 : gcc_unreachable ();
11292 :
11293 316 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11294 316 : break;
11295 :
11296 94 : case GFC_ISYM_VERIFY:
11297 94 : kind = expr->value.function.actual->expr->ts.kind;
11298 94 : if (kind == 1)
11299 70 : fndecl = gfor_fndecl_string_verify;
11300 24 : else if (kind == 4)
11301 24 : fndecl = gfor_fndecl_string_verify_char4;
11302 : else
11303 0 : gcc_unreachable ();
11304 :
11305 94 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11306 94 : break;
11307 :
11308 7381 : case GFC_ISYM_ALLOCATED:
11309 7381 : gfc_conv_allocated (se, expr);
11310 7381 : break;
11311 :
11312 9491 : case GFC_ISYM_ASSOCIATED:
11313 9491 : gfc_conv_associated(se, expr);
11314 9491 : break;
11315 :
11316 409 : case GFC_ISYM_SAME_TYPE_AS:
11317 409 : gfc_conv_same_type_as (se, expr);
11318 409 : break;
11319 :
11320 7872 : case GFC_ISYM_ABS:
11321 7872 : gfc_conv_intrinsic_abs (se, expr);
11322 7872 : break;
11323 :
11324 351 : case GFC_ISYM_ADJUSTL:
11325 351 : if (expr->ts.kind == 1)
11326 297 : fndecl = gfor_fndecl_adjustl;
11327 54 : else if (expr->ts.kind == 4)
11328 54 : fndecl = gfor_fndecl_adjustl_char4;
11329 : else
11330 0 : gcc_unreachable ();
11331 :
11332 351 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11333 351 : break;
11334 :
11335 123 : case GFC_ISYM_ADJUSTR:
11336 123 : if (expr->ts.kind == 1)
11337 68 : fndecl = gfor_fndecl_adjustr;
11338 55 : else if (expr->ts.kind == 4)
11339 55 : fndecl = gfor_fndecl_adjustr_char4;
11340 : else
11341 0 : gcc_unreachable ();
11342 :
11343 123 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11344 123 : break;
11345 :
11346 440 : case GFC_ISYM_AIMAG:
11347 440 : gfc_conv_intrinsic_imagpart (se, expr);
11348 440 : break;
11349 :
11350 146 : case GFC_ISYM_AINT:
11351 146 : gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
11352 146 : break;
11353 :
11354 420 : case GFC_ISYM_ALL:
11355 420 : gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
11356 420 : break;
11357 :
11358 74 : case GFC_ISYM_ANINT:
11359 74 : gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
11360 74 : break;
11361 :
11362 90 : case GFC_ISYM_AND:
11363 90 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11364 90 : break;
11365 :
11366 37909 : case GFC_ISYM_ANY:
11367 37909 : gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
11368 37909 : break;
11369 :
11370 216 : case GFC_ISYM_ACOSD:
11371 216 : case GFC_ISYM_ASIND:
11372 216 : case GFC_ISYM_ATAND:
11373 216 : gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
11374 216 : break;
11375 :
11376 102 : case GFC_ISYM_COTAN:
11377 102 : gfc_conv_intrinsic_cotan (se, expr);
11378 102 : break;
11379 :
11380 108 : case GFC_ISYM_COTAND:
11381 108 : gfc_conv_intrinsic_cotand (se, expr);
11382 108 : break;
11383 :
11384 120 : case GFC_ISYM_ATAN2D:
11385 120 : gfc_conv_intrinsic_atan2d (se, expr);
11386 120 : break;
11387 :
11388 145 : case GFC_ISYM_BTEST:
11389 145 : gfc_conv_intrinsic_btest (se, expr);
11390 145 : break;
11391 :
11392 54 : case GFC_ISYM_BGE:
11393 54 : gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
11394 54 : break;
11395 :
11396 54 : case GFC_ISYM_BGT:
11397 54 : gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
11398 54 : break;
11399 :
11400 54 : case GFC_ISYM_BLE:
11401 54 : gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
11402 54 : break;
11403 :
11404 54 : case GFC_ISYM_BLT:
11405 54 : gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
11406 54 : break;
11407 :
11408 9773 : case GFC_ISYM_C_ASSOCIATED:
11409 9773 : case GFC_ISYM_C_FUNLOC:
11410 9773 : case GFC_ISYM_C_LOC:
11411 9773 : case GFC_ISYM_F_C_STRING:
11412 9773 : conv_isocbinding_function (se, expr);
11413 9773 : break;
11414 :
11415 2020 : case GFC_ISYM_ACHAR:
11416 2020 : case GFC_ISYM_CHAR:
11417 2020 : gfc_conv_intrinsic_char (se, expr);
11418 2020 : break;
11419 :
11420 39933 : case GFC_ISYM_CONVERSION:
11421 39933 : case GFC_ISYM_DBLE:
11422 39933 : case GFC_ISYM_DFLOAT:
11423 39933 : case GFC_ISYM_FLOAT:
11424 39933 : case GFC_ISYM_LOGICAL:
11425 39933 : case GFC_ISYM_REAL:
11426 39933 : case GFC_ISYM_REALPART:
11427 39933 : case GFC_ISYM_SNGL:
11428 39933 : gfc_conv_intrinsic_conversion (se, expr);
11429 39933 : break;
11430 :
11431 : /* Integer conversions are handled separately to make sure we get the
11432 : correct rounding mode. */
11433 2836 : case GFC_ISYM_INT:
11434 2836 : case GFC_ISYM_INT2:
11435 2836 : case GFC_ISYM_INT8:
11436 2836 : case GFC_ISYM_LONG:
11437 2836 : case GFC_ISYM_UINT:
11438 2836 : gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
11439 2836 : break;
11440 :
11441 162 : case GFC_ISYM_NINT:
11442 162 : gfc_conv_intrinsic_int (se, expr, RND_ROUND);
11443 162 : break;
11444 :
11445 16 : case GFC_ISYM_CEILING:
11446 16 : gfc_conv_intrinsic_int (se, expr, RND_CEIL);
11447 16 : break;
11448 :
11449 116 : case GFC_ISYM_FLOOR:
11450 116 : gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
11451 116 : break;
11452 :
11453 3221 : case GFC_ISYM_MOD:
11454 3221 : gfc_conv_intrinsic_mod (se, expr, 0);
11455 3221 : break;
11456 :
11457 442 : case GFC_ISYM_MODULO:
11458 442 : gfc_conv_intrinsic_mod (se, expr, 1);
11459 442 : break;
11460 :
11461 1006 : case GFC_ISYM_CAF_GET:
11462 1006 : gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL);
11463 1006 : break;
11464 :
11465 167 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
11466 167 : gfc_conv_intrinsic_caf_is_present_remote (se, expr);
11467 167 : break;
11468 :
11469 485 : case GFC_ISYM_CMPLX:
11470 485 : gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
11471 485 : break;
11472 :
11473 10 : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
11474 10 : gfc_conv_intrinsic_iargc (se, expr);
11475 10 : break;
11476 :
11477 6 : case GFC_ISYM_COMPLEX:
11478 6 : gfc_conv_intrinsic_cmplx (se, expr, 1);
11479 6 : break;
11480 :
11481 257 : case GFC_ISYM_CONJG:
11482 257 : gfc_conv_intrinsic_conjg (se, expr);
11483 257 : break;
11484 :
11485 4 : case GFC_ISYM_COSHAPE:
11486 4 : conv_intrinsic_cobound (se, expr);
11487 4 : break;
11488 :
11489 143 : case GFC_ISYM_COUNT:
11490 143 : gfc_conv_intrinsic_count (se, expr);
11491 143 : break;
11492 :
11493 0 : case GFC_ISYM_CTIME:
11494 0 : gfc_conv_intrinsic_ctime (se, expr);
11495 0 : break;
11496 :
11497 96 : case GFC_ISYM_DIM:
11498 96 : gfc_conv_intrinsic_dim (se, expr);
11499 96 : break;
11500 :
11501 113 : case GFC_ISYM_DOT_PRODUCT:
11502 113 : gfc_conv_intrinsic_dot_product (se, expr);
11503 113 : break;
11504 :
11505 13 : case GFC_ISYM_DPROD:
11506 13 : gfc_conv_intrinsic_dprod (se, expr);
11507 13 : break;
11508 :
11509 66 : case GFC_ISYM_DSHIFTL:
11510 66 : gfc_conv_intrinsic_dshift (se, expr, true);
11511 66 : break;
11512 :
11513 66 : case GFC_ISYM_DSHIFTR:
11514 66 : gfc_conv_intrinsic_dshift (se, expr, false);
11515 66 : break;
11516 :
11517 0 : case GFC_ISYM_FDATE:
11518 0 : gfc_conv_intrinsic_fdate (se, expr);
11519 0 : break;
11520 :
11521 60 : case GFC_ISYM_FRACTION:
11522 60 : gfc_conv_intrinsic_fraction (se, expr);
11523 60 : break;
11524 :
11525 24 : case GFC_ISYM_IALL:
11526 24 : gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
11527 24 : break;
11528 :
11529 606 : case GFC_ISYM_IAND:
11530 606 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11531 606 : break;
11532 :
11533 12 : case GFC_ISYM_IANY:
11534 12 : gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
11535 12 : break;
11536 :
11537 168 : case GFC_ISYM_IBCLR:
11538 168 : gfc_conv_intrinsic_singlebitop (se, expr, 0);
11539 168 : break;
11540 :
11541 27 : case GFC_ISYM_IBITS:
11542 27 : gfc_conv_intrinsic_ibits (se, expr);
11543 27 : break;
11544 :
11545 138 : case GFC_ISYM_IBSET:
11546 138 : gfc_conv_intrinsic_singlebitop (se, expr, 1);
11547 138 : break;
11548 :
11549 2033 : case GFC_ISYM_IACHAR:
11550 2033 : case GFC_ISYM_ICHAR:
11551 : /* We assume ASCII character sequence. */
11552 2033 : gfc_conv_intrinsic_ichar (se, expr);
11553 2033 : break;
11554 :
11555 2 : case GFC_ISYM_IARGC:
11556 2 : gfc_conv_intrinsic_iargc (se, expr);
11557 2 : break;
11558 :
11559 694 : case GFC_ISYM_IEOR:
11560 694 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11561 694 : break;
11562 :
11563 341 : case GFC_ISYM_INDEX:
11564 341 : kind = expr->value.function.actual->expr->ts.kind;
11565 341 : if (kind == 1)
11566 275 : fndecl = gfor_fndecl_string_index;
11567 66 : else if (kind == 4)
11568 66 : fndecl = gfor_fndecl_string_index_char4;
11569 : else
11570 0 : gcc_unreachable ();
11571 :
11572 341 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11573 341 : break;
11574 :
11575 495 : case GFC_ISYM_IOR:
11576 495 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11577 495 : break;
11578 :
11579 12 : case GFC_ISYM_IPARITY:
11580 12 : gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
11581 12 : break;
11582 :
11583 6 : case GFC_ISYM_IS_IOSTAT_END:
11584 6 : gfc_conv_has_intvalue (se, expr, LIBERROR_END);
11585 6 : break;
11586 :
11587 18 : case GFC_ISYM_IS_IOSTAT_EOR:
11588 18 : gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
11589 18 : break;
11590 :
11591 735 : case GFC_ISYM_IS_CONTIGUOUS:
11592 735 : gfc_conv_intrinsic_is_contiguous (se, expr);
11593 735 : break;
11594 :
11595 432 : case GFC_ISYM_ISNAN:
11596 432 : gfc_conv_intrinsic_isnan (se, expr);
11597 432 : break;
11598 :
11599 8 : case GFC_ISYM_KILL:
11600 8 : conv_intrinsic_kill (se, expr);
11601 8 : break;
11602 :
11603 90 : case GFC_ISYM_LSHIFT:
11604 90 : gfc_conv_intrinsic_shift (se, expr, false, false);
11605 90 : break;
11606 :
11607 24 : case GFC_ISYM_RSHIFT:
11608 24 : gfc_conv_intrinsic_shift (se, expr, true, true);
11609 24 : break;
11610 :
11611 78 : case GFC_ISYM_SHIFTA:
11612 78 : gfc_conv_intrinsic_shift (se, expr, true, true);
11613 78 : break;
11614 :
11615 234 : case GFC_ISYM_SHIFTL:
11616 234 : gfc_conv_intrinsic_shift (se, expr, false, false);
11617 234 : break;
11618 :
11619 66 : case GFC_ISYM_SHIFTR:
11620 66 : gfc_conv_intrinsic_shift (se, expr, true, false);
11621 66 : break;
11622 :
11623 318 : case GFC_ISYM_ISHFT:
11624 318 : gfc_conv_intrinsic_ishft (se, expr);
11625 318 : break;
11626 :
11627 658 : case GFC_ISYM_ISHFTC:
11628 658 : gfc_conv_intrinsic_ishftc (se, expr);
11629 658 : break;
11630 :
11631 270 : case GFC_ISYM_LEADZ:
11632 270 : gfc_conv_intrinsic_leadz (se, expr);
11633 270 : break;
11634 :
11635 282 : case GFC_ISYM_TRAILZ:
11636 282 : gfc_conv_intrinsic_trailz (se, expr);
11637 282 : break;
11638 :
11639 103 : case GFC_ISYM_POPCNT:
11640 103 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
11641 103 : break;
11642 :
11643 31 : case GFC_ISYM_POPPAR:
11644 31 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
11645 31 : break;
11646 :
11647 5536 : case GFC_ISYM_LBOUND:
11648 5536 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
11649 5536 : break;
11650 :
11651 210 : case GFC_ISYM_LCOBOUND:
11652 210 : conv_intrinsic_cobound (se, expr);
11653 210 : break;
11654 :
11655 744 : case GFC_ISYM_TRANSPOSE:
11656 : /* The scalarizer has already been set up for reversed dimension access
11657 : order ; now we just get the argument value normally. */
11658 744 : gfc_conv_expr (se, expr->value.function.actual->expr);
11659 744 : break;
11660 :
11661 5855 : case GFC_ISYM_LEN:
11662 5855 : gfc_conv_intrinsic_len (se, expr);
11663 5855 : break;
11664 :
11665 2335 : case GFC_ISYM_LEN_TRIM:
11666 2335 : gfc_conv_intrinsic_len_trim (se, expr);
11667 2335 : break;
11668 :
11669 18 : case GFC_ISYM_LGE:
11670 18 : gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
11671 18 : break;
11672 :
11673 36 : case GFC_ISYM_LGT:
11674 36 : gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
11675 36 : break;
11676 :
11677 18 : case GFC_ISYM_LLE:
11678 18 : gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
11679 18 : break;
11680 :
11681 27 : case GFC_ISYM_LLT:
11682 27 : gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
11683 27 : break;
11684 :
11685 16 : case GFC_ISYM_MALLOC:
11686 16 : gfc_conv_intrinsic_malloc (se, expr);
11687 16 : break;
11688 :
11689 32 : case GFC_ISYM_MASKL:
11690 32 : gfc_conv_intrinsic_mask (se, expr, 1);
11691 32 : break;
11692 :
11693 32 : case GFC_ISYM_MASKR:
11694 32 : gfc_conv_intrinsic_mask (se, expr, 0);
11695 32 : break;
11696 :
11697 1049 : case GFC_ISYM_MAX:
11698 1049 : if (expr->ts.type == BT_CHARACTER)
11699 138 : gfc_conv_intrinsic_minmax_char (se, expr, 1);
11700 : else
11701 911 : gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
11702 : break;
11703 :
11704 6348 : case GFC_ISYM_MAXLOC:
11705 6348 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11706 6348 : break;
11707 :
11708 216 : case GFC_ISYM_FINDLOC:
11709 216 : gfc_conv_intrinsic_findloc (se, expr);
11710 216 : break;
11711 :
11712 1101 : case GFC_ISYM_MAXVAL:
11713 1101 : gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
11714 1101 : break;
11715 :
11716 949 : case GFC_ISYM_MERGE:
11717 949 : gfc_conv_intrinsic_merge (se, expr);
11718 949 : break;
11719 :
11720 42 : case GFC_ISYM_MERGE_BITS:
11721 42 : gfc_conv_intrinsic_merge_bits (se, expr);
11722 42 : break;
11723 :
11724 598 : case GFC_ISYM_MIN:
11725 598 : if (expr->ts.type == BT_CHARACTER)
11726 144 : gfc_conv_intrinsic_minmax_char (se, expr, -1);
11727 : else
11728 454 : gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
11729 : break;
11730 :
11731 7176 : case GFC_ISYM_MINLOC:
11732 7176 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11733 7176 : break;
11734 :
11735 1316 : case GFC_ISYM_MINVAL:
11736 1316 : gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
11737 1316 : break;
11738 :
11739 1595 : case GFC_ISYM_NEAREST:
11740 1595 : gfc_conv_intrinsic_nearest (se, expr);
11741 1595 : break;
11742 :
11743 68 : case GFC_ISYM_NORM2:
11744 68 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
11745 68 : break;
11746 :
11747 230 : case GFC_ISYM_NOT:
11748 230 : gfc_conv_intrinsic_not (se, expr);
11749 230 : break;
11750 :
11751 12 : case GFC_ISYM_OR:
11752 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11753 12 : break;
11754 :
11755 468 : case GFC_ISYM_OUT_OF_RANGE:
11756 468 : gfc_conv_intrinsic_out_of_range (se, expr);
11757 468 : break;
11758 :
11759 36 : case GFC_ISYM_PARITY:
11760 36 : gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
11761 36 : break;
11762 :
11763 5070 : case GFC_ISYM_PRESENT:
11764 5070 : gfc_conv_intrinsic_present (se, expr);
11765 5070 : break;
11766 :
11767 358 : case GFC_ISYM_PRODUCT:
11768 358 : gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
11769 358 : break;
11770 :
11771 12588 : case GFC_ISYM_RANK:
11772 12588 : gfc_conv_intrinsic_rank (se, expr);
11773 12588 : break;
11774 :
11775 48 : case GFC_ISYM_RRSPACING:
11776 48 : gfc_conv_intrinsic_rrspacing (se, expr);
11777 48 : break;
11778 :
11779 262 : case GFC_ISYM_SET_EXPONENT:
11780 262 : gfc_conv_intrinsic_set_exponent (se, expr);
11781 262 : break;
11782 :
11783 72 : case GFC_ISYM_SCALE:
11784 72 : gfc_conv_intrinsic_scale (se, expr);
11785 72 : break;
11786 :
11787 4940 : case GFC_ISYM_SHAPE:
11788 4940 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
11789 4940 : break;
11790 :
11791 423 : case GFC_ISYM_SIGN:
11792 423 : gfc_conv_intrinsic_sign (se, expr);
11793 423 : break;
11794 :
11795 15242 : case GFC_ISYM_SIZE:
11796 15242 : gfc_conv_intrinsic_size (se, expr);
11797 15242 : break;
11798 :
11799 1309 : case GFC_ISYM_SIZEOF:
11800 1309 : case GFC_ISYM_C_SIZEOF:
11801 1309 : gfc_conv_intrinsic_sizeof (se, expr);
11802 1309 : break;
11803 :
11804 840 : case GFC_ISYM_STORAGE_SIZE:
11805 840 : gfc_conv_intrinsic_storage_size (se, expr);
11806 840 : break;
11807 :
11808 70 : case GFC_ISYM_SPACING:
11809 70 : gfc_conv_intrinsic_spacing (se, expr);
11810 70 : break;
11811 :
11812 2281 : case GFC_ISYM_STRIDE:
11813 2281 : conv_intrinsic_stride (se, expr);
11814 2281 : break;
11815 :
11816 2003 : case GFC_ISYM_SUM:
11817 2003 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
11818 2003 : break;
11819 :
11820 21 : case GFC_ISYM_TEAM_NUMBER:
11821 21 : conv_intrinsic_team_number (se, expr);
11822 21 : break;
11823 :
11824 4084 : case GFC_ISYM_TRANSFER:
11825 4084 : if (se->ss && se->ss->info->useflags)
11826 : /* Access the previously obtained result. */
11827 281 : gfc_conv_tmp_array_ref (se);
11828 : else
11829 3803 : gfc_conv_intrinsic_transfer (se, expr);
11830 : break;
11831 :
11832 0 : case GFC_ISYM_TTYNAM:
11833 0 : gfc_conv_intrinsic_ttynam (se, expr);
11834 0 : break;
11835 :
11836 5711 : case GFC_ISYM_UBOUND:
11837 5711 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
11838 5711 : break;
11839 :
11840 244 : case GFC_ISYM_UCOBOUND:
11841 244 : conv_intrinsic_cobound (se, expr);
11842 244 : break;
11843 :
11844 18 : case GFC_ISYM_XOR:
11845 18 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11846 18 : break;
11847 :
11848 8852 : case GFC_ISYM_LOC:
11849 8852 : gfc_conv_intrinsic_loc (se, expr);
11850 8852 : break;
11851 :
11852 1506 : case GFC_ISYM_THIS_IMAGE:
11853 : /* For num_images() == 1, handle as LCOBOUND. */
11854 1506 : if (expr->value.function.actual->expr
11855 526 : && flag_coarray == GFC_FCOARRAY_SINGLE)
11856 208 : conv_intrinsic_cobound (se, expr);
11857 : else
11858 1298 : trans_this_image (se, expr);
11859 : break;
11860 :
11861 193 : case GFC_ISYM_IMAGE_INDEX:
11862 193 : trans_image_index (se, expr);
11863 193 : break;
11864 :
11865 25 : case GFC_ISYM_IMAGE_STATUS:
11866 25 : conv_intrinsic_image_status (se, expr);
11867 25 : break;
11868 :
11869 810 : case GFC_ISYM_NUM_IMAGES:
11870 810 : trans_num_images (se, expr);
11871 810 : break;
11872 :
11873 1392 : case GFC_ISYM_ACCESS:
11874 1392 : case GFC_ISYM_CHDIR:
11875 1392 : case GFC_ISYM_CHMOD:
11876 1392 : case GFC_ISYM_DTIME:
11877 1392 : case GFC_ISYM_ETIME:
11878 1392 : case GFC_ISYM_EXTENDS_TYPE_OF:
11879 1392 : case GFC_ISYM_FGET:
11880 1392 : case GFC_ISYM_FGETC:
11881 1392 : case GFC_ISYM_FNUM:
11882 1392 : case GFC_ISYM_FPUT:
11883 1392 : case GFC_ISYM_FPUTC:
11884 1392 : case GFC_ISYM_FSTAT:
11885 1392 : case GFC_ISYM_FTELL:
11886 1392 : case GFC_ISYM_GETCWD:
11887 1392 : case GFC_ISYM_GETGID:
11888 1392 : case GFC_ISYM_GETPID:
11889 1392 : case GFC_ISYM_GETUID:
11890 1392 : case GFC_ISYM_GET_TEAM:
11891 1392 : case GFC_ISYM_HOSTNM:
11892 1392 : case GFC_ISYM_IERRNO:
11893 1392 : case GFC_ISYM_IRAND:
11894 1392 : case GFC_ISYM_ISATTY:
11895 1392 : case GFC_ISYM_JN2:
11896 1392 : case GFC_ISYM_LINK:
11897 1392 : case GFC_ISYM_LSTAT:
11898 1392 : case GFC_ISYM_MATMUL:
11899 1392 : case GFC_ISYM_MCLOCK:
11900 1392 : case GFC_ISYM_MCLOCK8:
11901 1392 : case GFC_ISYM_RAND:
11902 1392 : case GFC_ISYM_REDUCE:
11903 1392 : case GFC_ISYM_RENAME:
11904 1392 : case GFC_ISYM_SECOND:
11905 1392 : case GFC_ISYM_SECNDS:
11906 1392 : case GFC_ISYM_SIGNAL:
11907 1392 : case GFC_ISYM_STAT:
11908 1392 : case GFC_ISYM_SYMLNK:
11909 1392 : case GFC_ISYM_SYSTEM:
11910 1392 : case GFC_ISYM_TIME:
11911 1392 : case GFC_ISYM_TIME8:
11912 1392 : case GFC_ISYM_UMASK:
11913 1392 : case GFC_ISYM_UNLINK:
11914 1392 : case GFC_ISYM_YN2:
11915 1392 : gfc_conv_intrinsic_funcall (se, expr);
11916 1392 : break;
11917 :
11918 0 : case GFC_ISYM_EOSHIFT:
11919 0 : case GFC_ISYM_PACK:
11920 0 : case GFC_ISYM_RESHAPE:
11921 : /* For those, expr->rank should always be >0 and thus the if above the
11922 : switch should have matched. */
11923 0 : gcc_unreachable ();
11924 3872 : break;
11925 :
11926 3872 : default:
11927 3872 : gfc_conv_intrinsic_lib_function (se, expr);
11928 3872 : break;
11929 : }
11930 : }
11931 :
11932 :
11933 : static gfc_ss *
11934 1560 : walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11935 : {
11936 1560 : gfc_ss *arg_ss, *tmp_ss;
11937 1560 : gfc_actual_arglist *arg;
11938 :
11939 1560 : arg = expr->value.function.actual;
11940 :
11941 1560 : gcc_assert (arg->expr);
11942 :
11943 1560 : arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11944 1560 : gcc_assert (arg_ss != gfc_ss_terminator);
11945 :
11946 : for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11947 : {
11948 1665 : if (tmp_ss->info->type != GFC_SS_SCALAR
11949 : && tmp_ss->info->type != GFC_SS_REFERENCE)
11950 : {
11951 1628 : gcc_assert (tmp_ss->dimen == 2);
11952 :
11953 : /* We just invert dimensions. */
11954 1628 : std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
11955 : }
11956 :
11957 : /* Stop when tmp_ss points to the last valid element of the chain... */
11958 1665 : if (tmp_ss->next == gfc_ss_terminator)
11959 : break;
11960 : }
11961 :
11962 : /* ... so that we can attach the rest of the chain to it. */
11963 1560 : tmp_ss->next = ss;
11964 :
11965 1560 : return arg_ss;
11966 : }
11967 :
11968 :
11969 : /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11970 : This has the side effect of reversing the nested list, so there is no
11971 : need to call gfc_reverse_ss on it (the given list is assumed not to be
11972 : reversed yet). */
11973 :
11974 : static gfc_ss *
11975 3371 : nest_loop_dimension (gfc_ss *ss, int dim)
11976 : {
11977 3371 : int ss_dim, i;
11978 3371 : gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11979 3371 : gfc_loopinfo *new_loop;
11980 :
11981 3371 : gcc_assert (ss != gfc_ss_terminator);
11982 :
11983 8118 : for (; ss != gfc_ss_terminator; ss = ss->next)
11984 : {
11985 4747 : new_ss = gfc_get_ss ();
11986 4747 : new_ss->next = prev_ss;
11987 4747 : new_ss->parent = ss;
11988 4747 : new_ss->info = ss->info;
11989 4747 : new_ss->info->refcount++;
11990 4747 : if (ss->dimen != 0)
11991 : {
11992 4684 : gcc_assert (ss->info->type != GFC_SS_SCALAR
11993 : && ss->info->type != GFC_SS_REFERENCE);
11994 :
11995 4684 : new_ss->dimen = 1;
11996 4684 : new_ss->dim[0] = ss->dim[dim];
11997 :
11998 4684 : gcc_assert (dim < ss->dimen);
11999 :
12000 4684 : ss_dim = --ss->dimen;
12001 10430 : for (i = dim; i < ss_dim; i++)
12002 5746 : ss->dim[i] = ss->dim[i + 1];
12003 :
12004 4684 : ss->dim[ss_dim] = 0;
12005 : }
12006 4747 : prev_ss = new_ss;
12007 :
12008 4747 : if (ss->nested_ss)
12009 : {
12010 81 : ss->nested_ss->parent = new_ss;
12011 81 : new_ss->nested_ss = ss->nested_ss;
12012 : }
12013 4747 : ss->nested_ss = new_ss;
12014 : }
12015 :
12016 3371 : new_loop = gfc_get_loopinfo ();
12017 3371 : gfc_init_loopinfo (new_loop);
12018 :
12019 3371 : gcc_assert (prev_ss != NULL);
12020 3371 : gcc_assert (prev_ss != gfc_ss_terminator);
12021 3371 : gfc_add_ss_to_loop (new_loop, prev_ss);
12022 3371 : return new_ss->parent;
12023 : }
12024 :
12025 :
12026 : /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
12027 : is to be inlined. */
12028 :
12029 : static gfc_ss *
12030 575 : walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
12031 : {
12032 575 : gfc_ss *tmp_ss, *tail, *array_ss;
12033 575 : gfc_actual_arglist *arg1, *arg2, *arg3;
12034 575 : int sum_dim;
12035 575 : bool scalar_mask = false;
12036 :
12037 : /* The rank of the result will be determined later. */
12038 575 : arg1 = expr->value.function.actual;
12039 575 : arg2 = arg1->next;
12040 575 : arg3 = arg2->next;
12041 575 : gcc_assert (arg3 != NULL);
12042 :
12043 575 : if (expr->rank == 0)
12044 : return ss;
12045 :
12046 575 : tmp_ss = gfc_ss_terminator;
12047 :
12048 575 : if (arg3->expr)
12049 : {
12050 118 : gfc_ss *mask_ss;
12051 :
12052 118 : mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
12053 118 : if (mask_ss == tmp_ss)
12054 34 : scalar_mask = 1;
12055 :
12056 : tmp_ss = mask_ss;
12057 : }
12058 :
12059 575 : array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
12060 575 : gcc_assert (array_ss != tmp_ss);
12061 :
12062 : /* Odd thing: If the mask is scalar, it is used by the frontend after
12063 : the array (to make an if around the nested loop). Thus it shall
12064 : be after array_ss once the gfc_ss list is reversed. */
12065 575 : if (scalar_mask)
12066 34 : tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
12067 : else
12068 : tmp_ss = array_ss;
12069 :
12070 : /* "Hide" the dimension on which we will sum in the first arg's scalarization
12071 : chain. */
12072 575 : sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
12073 575 : tail = nest_loop_dimension (tmp_ss, sum_dim);
12074 575 : tail->next = ss;
12075 :
12076 575 : return tmp_ss;
12077 : }
12078 :
12079 :
12080 : /* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the
12081 : function is to be inlined. */
12082 :
12083 : static gfc_ss *
12084 6085 : walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
12085 : {
12086 6085 : if (expr->rank == 0)
12087 : return ss;
12088 :
12089 6085 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12090 6085 : gfc_actual_arglist *dim_arg = array_arg->next;
12091 6085 : gfc_actual_arglist *mask_arg = dim_arg->next;
12092 6085 : gfc_actual_arglist *kind_arg = mask_arg->next;
12093 6085 : gfc_actual_arglist *back_arg = kind_arg->next;
12094 :
12095 6085 : gfc_expr *array = array_arg->expr;
12096 6085 : gfc_expr *dim = dim_arg->expr;
12097 6085 : gfc_expr *mask = mask_arg->expr;
12098 6085 : gfc_expr *back = back_arg->expr;
12099 :
12100 6085 : if (dim == nullptr)
12101 3289 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12102 :
12103 2796 : gfc_ss *tmp_ss = gfc_ss_terminator;
12104 :
12105 2796 : bool scalar_mask = false;
12106 2796 : if (mask)
12107 : {
12108 1866 : gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
12109 1866 : if (mask_ss == tmp_ss)
12110 : scalar_mask = true;
12111 1174 : else if (maybe_absent_optional_variable (mask))
12112 20 : mask_ss->info->can_be_null_ref = true;
12113 :
12114 : tmp_ss = mask_ss;
12115 : }
12116 :
12117 2796 : gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
12118 2796 : gcc_assert (array_ss != tmp_ss);
12119 :
12120 2796 : tmp_ss = array_ss;
12121 :
12122 : /* Move the dimension on which we will sum to a separate nested scalarization
12123 : chain, "hiding" that dimension from the outer scalarization. */
12124 2796 : int dim_val = mpz_get_si (dim->value.integer);
12125 2796 : gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
12126 :
12127 2796 : if (back && array->rank > 1)
12128 : {
12129 : /* If there are nested scalarization loops, include BACK in the
12130 : scalarization chains to avoid evaluating it multiple times in a loop.
12131 : Otherwise, prefer to handle it outside of scalarization. */
12132 2796 : gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
12133 2796 : back_ss->info->type = GFC_SS_REFERENCE;
12134 2796 : if (maybe_absent_optional_variable (back))
12135 16 : back_ss->info->can_be_null_ref = true;
12136 :
12137 2796 : tail->next = back_ss;
12138 2796 : }
12139 : else
12140 0 : tail->next = ss;
12141 :
12142 2796 : if (scalar_mask)
12143 : {
12144 692 : tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
12145 : /* MASK can be a forwarded optional argument, so make the necessary setup
12146 : to avoid the scalarizer generating any unguarded pointer dereference in
12147 : that case. */
12148 692 : tmp_ss->info->type = GFC_SS_REFERENCE;
12149 692 : if (maybe_absent_optional_variable (mask))
12150 4 : tmp_ss->info->can_be_null_ref = true;
12151 : }
12152 :
12153 : return tmp_ss;
12154 : }
12155 :
12156 :
12157 : static gfc_ss *
12158 8220 : walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
12159 : {
12160 :
12161 8220 : switch (expr->value.function.isym->id)
12162 : {
12163 575 : case GFC_ISYM_PRODUCT:
12164 575 : case GFC_ISYM_SUM:
12165 575 : return walk_inline_intrinsic_arith (ss, expr);
12166 :
12167 1560 : case GFC_ISYM_TRANSPOSE:
12168 1560 : return walk_inline_intrinsic_transpose (ss, expr);
12169 :
12170 6085 : case GFC_ISYM_MAXLOC:
12171 6085 : case GFC_ISYM_MINLOC:
12172 6085 : return walk_inline_intrinsic_minmaxloc (ss, expr);
12173 :
12174 0 : default:
12175 0 : gcc_unreachable ();
12176 : }
12177 : gcc_unreachable ();
12178 : }
12179 :
12180 :
12181 : /* This generates code to execute before entering the scalarization loop.
12182 : Currently does nothing. */
12183 :
12184 : void
12185 11533 : gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
12186 : {
12187 11533 : switch (ss->info->expr->value.function.isym->id)
12188 : {
12189 11533 : case GFC_ISYM_UBOUND:
12190 11533 : case GFC_ISYM_LBOUND:
12191 11533 : case GFC_ISYM_COSHAPE:
12192 11533 : case GFC_ISYM_UCOBOUND:
12193 11533 : case GFC_ISYM_LCOBOUND:
12194 11533 : case GFC_ISYM_MAXLOC:
12195 11533 : case GFC_ISYM_MINLOC:
12196 11533 : case GFC_ISYM_THIS_IMAGE:
12197 11533 : case GFC_ISYM_SHAPE:
12198 11533 : break;
12199 :
12200 0 : default:
12201 0 : gcc_unreachable ();
12202 : }
12203 11533 : }
12204 :
12205 :
12206 : /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
12207 : one parameter are expanded into code inside the scalarization loop. */
12208 :
12209 : static gfc_ss *
12210 10089 : gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
12211 : {
12212 10089 : if (expr->value.function.actual->expr->ts.type == BT_CLASS)
12213 438 : gfc_add_class_array_ref (expr->value.function.actual->expr);
12214 :
12215 : /* The two argument version returns a scalar. */
12216 10089 : if (expr->value.function.isym->id != GFC_ISYM_SHAPE
12217 3522 : && expr->value.function.isym->id != GFC_ISYM_COSHAPE
12218 3518 : && expr->value.function.actual->next->expr)
12219 : return ss;
12220 :
12221 10089 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12222 : }
12223 :
12224 :
12225 : /* Walk an intrinsic array libcall. */
12226 :
12227 : static gfc_ss *
12228 14481 : gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
12229 : {
12230 14481 : gcc_assert (expr->rank > 0);
12231 14481 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12232 : }
12233 :
12234 :
12235 : /* Return whether the function call expression EXPR will be expanded
12236 : inline by gfc_conv_intrinsic_function. */
12237 :
12238 : bool
12239 301006 : gfc_inline_intrinsic_function_p (gfc_expr *expr)
12240 : {
12241 301006 : gfc_actual_arglist *args, *dim_arg, *mask_arg;
12242 301006 : gfc_expr *maskexpr;
12243 :
12244 301006 : gfc_intrinsic_sym *isym = expr->value.function.isym;
12245 301006 : if (!isym)
12246 : return false;
12247 :
12248 300964 : switch (isym->id)
12249 : {
12250 5104 : case GFC_ISYM_PRODUCT:
12251 5104 : case GFC_ISYM_SUM:
12252 : /* Disable inline expansion if code size matters. */
12253 5104 : if (optimize_size)
12254 : return false;
12255 :
12256 4249 : args = expr->value.function.actual;
12257 4249 : dim_arg = args->next;
12258 :
12259 : /* We need to be able to subset the SUM argument at compile-time. */
12260 4249 : if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
12261 : return false;
12262 :
12263 : /* FIXME: If MASK is optional for a more than two-dimensional
12264 : argument, the scalarizer gets confused if the mask is
12265 : absent. See PR 82995. For now, fall back to the library
12266 : function. */
12267 :
12268 3637 : mask_arg = dim_arg->next;
12269 3637 : maskexpr = mask_arg->expr;
12270 :
12271 3637 : if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
12272 276 : && maskexpr->symtree->n.sym->attr.dummy
12273 48 : && maskexpr->symtree->n.sym->attr.optional)
12274 : return false;
12275 :
12276 : return true;
12277 :
12278 : case GFC_ISYM_TRANSPOSE:
12279 : return true;
12280 :
12281 57188 : case GFC_ISYM_MINLOC:
12282 57188 : case GFC_ISYM_MAXLOC:
12283 57188 : {
12284 57188 : if ((isym->id == GFC_ISYM_MINLOC
12285 30521 : && (flag_inline_intrinsics
12286 30521 : & GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0)
12287 46611 : || (isym->id == GFC_ISYM_MAXLOC
12288 26667 : && (flag_inline_intrinsics
12289 26667 : & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0))
12290 : return false;
12291 :
12292 37638 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12293 37638 : gfc_actual_arglist *dim_arg = array_arg->next;
12294 :
12295 37638 : gfc_expr *array = array_arg->expr;
12296 37638 : gfc_expr *dim = dim_arg->expr;
12297 :
12298 37638 : if (!(array->ts.type == BT_INTEGER
12299 : || array->ts.type == BT_REAL))
12300 : return false;
12301 :
12302 34658 : if (array->rank == 1)
12303 : return true;
12304 :
12305 20711 : if (dim != nullptr
12306 13372 : && dim->expr_type != EXPR_CONSTANT)
12307 : return false;
12308 :
12309 : return true;
12310 : }
12311 :
12312 : default:
12313 : return false;
12314 : }
12315 : }
12316 :
12317 :
12318 : /* Returns nonzero if the specified intrinsic function call maps directly to
12319 : an external library call. Should only be used for functions that return
12320 : arrays. */
12321 :
12322 : int
12323 87716 : gfc_is_intrinsic_libcall (gfc_expr * expr)
12324 : {
12325 87716 : gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
12326 87716 : gcc_assert (expr->rank > 0);
12327 :
12328 87716 : if (gfc_inline_intrinsic_function_p (expr))
12329 : return 0;
12330 :
12331 73135 : switch (expr->value.function.isym->id)
12332 : {
12333 : case GFC_ISYM_ALL:
12334 : case GFC_ISYM_ANY:
12335 : case GFC_ISYM_COUNT:
12336 : case GFC_ISYM_FINDLOC:
12337 : case GFC_ISYM_JN2:
12338 : case GFC_ISYM_IANY:
12339 : case GFC_ISYM_IALL:
12340 : case GFC_ISYM_IPARITY:
12341 : case GFC_ISYM_MATMUL:
12342 : case GFC_ISYM_MAXLOC:
12343 : case GFC_ISYM_MAXVAL:
12344 : case GFC_ISYM_MINLOC:
12345 : case GFC_ISYM_MINVAL:
12346 : case GFC_ISYM_NORM2:
12347 : case GFC_ISYM_PARITY:
12348 : case GFC_ISYM_PRODUCT:
12349 : case GFC_ISYM_SUM:
12350 : case GFC_ISYM_SPREAD:
12351 : case GFC_ISYM_YN2:
12352 : /* Ignore absent optional parameters. */
12353 : return 1;
12354 :
12355 15765 : case GFC_ISYM_CSHIFT:
12356 15765 : case GFC_ISYM_EOSHIFT:
12357 15765 : case GFC_ISYM_GET_TEAM:
12358 15765 : case GFC_ISYM_FAILED_IMAGES:
12359 15765 : case GFC_ISYM_STOPPED_IMAGES:
12360 15765 : case GFC_ISYM_PACK:
12361 15765 : case GFC_ISYM_REDUCE:
12362 15765 : case GFC_ISYM_RESHAPE:
12363 15765 : case GFC_ISYM_UNPACK:
12364 : /* Pass absent optional parameters. */
12365 15765 : return 2;
12366 :
12367 : default:
12368 : return 0;
12369 : }
12370 : }
12371 :
12372 : /* Walk an intrinsic function. */
12373 : gfc_ss *
12374 55626 : gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
12375 : gfc_intrinsic_sym * isym)
12376 : {
12377 55626 : gcc_assert (isym);
12378 :
12379 55626 : if (isym->elemental)
12380 18345 : return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
12381 : expr->value.function.isym,
12382 18345 : GFC_SS_SCALAR);
12383 :
12384 37281 : if (expr->rank == 0 && expr->corank == 0)
12385 : return ss;
12386 :
12387 32790 : if (gfc_inline_intrinsic_function_p (expr))
12388 8220 : return walk_inline_intrinsic_function (ss, expr);
12389 :
12390 24570 : if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
12391 13498 : return gfc_walk_intrinsic_libfunc (ss, expr);
12392 :
12393 : /* Special cases. */
12394 11072 : switch (isym->id)
12395 : {
12396 10089 : case GFC_ISYM_COSHAPE:
12397 10089 : case GFC_ISYM_LBOUND:
12398 10089 : case GFC_ISYM_LCOBOUND:
12399 10089 : case GFC_ISYM_UBOUND:
12400 10089 : case GFC_ISYM_UCOBOUND:
12401 10089 : case GFC_ISYM_THIS_IMAGE:
12402 10089 : case GFC_ISYM_SHAPE:
12403 10089 : return gfc_walk_intrinsic_bound (ss, expr);
12404 :
12405 983 : case GFC_ISYM_TRANSFER:
12406 983 : case GFC_ISYM_CAF_GET:
12407 983 : return gfc_walk_intrinsic_libfunc (ss, expr);
12408 :
12409 0 : default:
12410 : /* This probably meant someone forgot to add an intrinsic to the above
12411 : list(s) when they implemented it, or something's gone horribly
12412 : wrong. */
12413 0 : gcc_unreachable ();
12414 : }
12415 : }
12416 :
12417 : static tree
12418 88 : conv_co_collective (gfc_code *code)
12419 : {
12420 88 : gfc_se argse;
12421 88 : stmtblock_t block, post_block;
12422 88 : tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
12423 88 : gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
12424 :
12425 88 : gfc_start_block (&block);
12426 88 : gfc_init_block (&post_block);
12427 :
12428 88 : if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
12429 : {
12430 17 : opr_expr = code->ext.actual->next->expr;
12431 17 : image_idx_expr = code->ext.actual->next->next->expr;
12432 17 : stat_expr = code->ext.actual->next->next->next->expr;
12433 17 : errmsg_expr = code->ext.actual->next->next->next->next->expr;
12434 : }
12435 : else
12436 : {
12437 71 : opr_expr = NULL;
12438 71 : image_idx_expr = code->ext.actual->next->expr;
12439 71 : stat_expr = code->ext.actual->next->next->expr;
12440 71 : errmsg_expr = code->ext.actual->next->next->next->expr;
12441 : }
12442 :
12443 : /* stat. */
12444 88 : if (stat_expr)
12445 : {
12446 59 : gfc_init_se (&argse, NULL);
12447 59 : gfc_conv_expr (&argse, stat_expr);
12448 59 : gfc_add_block_to_block (&block, &argse.pre);
12449 59 : gfc_add_block_to_block (&post_block, &argse.post);
12450 59 : stat = argse.expr;
12451 59 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
12452 32 : stat = gfc_build_addr_expr (NULL_TREE, stat);
12453 : }
12454 29 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
12455 : stat = NULL_TREE;
12456 : else
12457 20 : stat = null_pointer_node;
12458 :
12459 : /* Early exit for GFC_FCOARRAY_SINGLE. */
12460 88 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
12461 : {
12462 36 : if (stat != NULL_TREE)
12463 : {
12464 : /* For optional stats, check the pointer is valid before zero'ing. */
12465 27 : if (gfc_expr_attr (stat_expr).optional)
12466 : {
12467 12 : tree tmp;
12468 12 : stmtblock_t ass_block;
12469 12 : gfc_start_block (&ass_block);
12470 12 : gfc_add_modify (&ass_block, stat,
12471 12 : fold_convert (TREE_TYPE (stat),
12472 : integer_zero_node));
12473 12 : tmp = fold_build2 (NE_EXPR, logical_type_node,
12474 : gfc_build_addr_expr (NULL_TREE, stat),
12475 : null_pointer_node);
12476 12 : tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
12477 : gfc_finish_block (&ass_block),
12478 : build_empty_stmt (input_location));
12479 12 : gfc_add_expr_to_block (&block, tmp);
12480 : }
12481 : else
12482 15 : gfc_add_modify (&block, stat,
12483 15 : fold_convert (TREE_TYPE (stat), integer_zero_node));
12484 : }
12485 36 : return gfc_finish_block (&block);
12486 : }
12487 :
12488 5 : gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
12489 52 : ? code->ext.actual->expr->ts.u.derived : NULL;
12490 :
12491 : /* Handle the array. */
12492 52 : gfc_init_se (&argse, NULL);
12493 52 : if (!derived || !derived->attr.alloc_comp
12494 1 : || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
12495 : {
12496 51 : if (code->ext.actual->expr->rank == 0)
12497 : {
12498 22 : symbol_attribute attr;
12499 22 : gfc_clear_attr (&attr);
12500 22 : gfc_init_se (&argse, NULL);
12501 22 : gfc_conv_expr (&argse, code->ext.actual->expr);
12502 22 : gfc_add_block_to_block (&block, &argse.pre);
12503 22 : gfc_add_block_to_block (&post_block, &argse.post);
12504 22 : array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
12505 22 : array = gfc_build_addr_expr (NULL_TREE, array);
12506 : }
12507 : else
12508 : {
12509 29 : argse.want_pointer = 1;
12510 29 : gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
12511 29 : array = argse.expr;
12512 : }
12513 : }
12514 :
12515 52 : gfc_add_block_to_block (&block, &argse.pre);
12516 52 : gfc_add_block_to_block (&post_block, &argse.post);
12517 :
12518 52 : if (code->ext.actual->expr->ts.type == BT_CHARACTER)
12519 15 : strlen = argse.string_length;
12520 : else
12521 37 : strlen = integer_zero_node;
12522 :
12523 : /* image_index. */
12524 52 : if (image_idx_expr)
12525 : {
12526 35 : gfc_init_se (&argse, NULL);
12527 35 : gfc_conv_expr (&argse, image_idx_expr);
12528 35 : gfc_add_block_to_block (&block, &argse.pre);
12529 35 : gfc_add_block_to_block (&post_block, &argse.post);
12530 35 : image_index = fold_convert (integer_type_node, argse.expr);
12531 : }
12532 : else
12533 17 : image_index = integer_zero_node;
12534 :
12535 : /* errmsg. */
12536 52 : if (errmsg_expr)
12537 : {
12538 25 : gfc_init_se (&argse, NULL);
12539 25 : gfc_conv_expr (&argse, errmsg_expr);
12540 25 : gfc_add_block_to_block (&block, &argse.pre);
12541 25 : gfc_add_block_to_block (&post_block, &argse.post);
12542 25 : errmsg = argse.expr;
12543 25 : errmsg_len = fold_convert (size_type_node, argse.string_length);
12544 : }
12545 : else
12546 : {
12547 27 : errmsg = null_pointer_node;
12548 27 : errmsg_len = build_zero_cst (size_type_node);
12549 : }
12550 :
12551 : /* Generate the function call. */
12552 52 : switch (code->resolved_isym->id)
12553 : {
12554 20 : case GFC_ISYM_CO_BROADCAST:
12555 20 : fndecl = gfor_fndecl_co_broadcast;
12556 20 : break;
12557 8 : case GFC_ISYM_CO_MAX:
12558 8 : fndecl = gfor_fndecl_co_max;
12559 8 : break;
12560 6 : case GFC_ISYM_CO_MIN:
12561 6 : fndecl = gfor_fndecl_co_min;
12562 6 : break;
12563 12 : case GFC_ISYM_CO_REDUCE:
12564 12 : fndecl = gfor_fndecl_co_reduce;
12565 12 : break;
12566 6 : case GFC_ISYM_CO_SUM:
12567 6 : fndecl = gfor_fndecl_co_sum;
12568 6 : break;
12569 0 : default:
12570 0 : gcc_unreachable ();
12571 : }
12572 :
12573 52 : if (derived && derived->attr.alloc_comp
12574 1 : && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12575 : /* The derived type has the attribute 'alloc_comp'. */
12576 : {
12577 2 : tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
12578 1 : code->ext.actual->expr->rank,
12579 : image_index, stat, errmsg, errmsg_len);
12580 1 : gfc_add_expr_to_block (&block, tmp);
12581 1 : }
12582 : else
12583 : {
12584 51 : if (code->resolved_isym->id == GFC_ISYM_CO_SUM
12585 45 : || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12586 25 : fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
12587 : image_index, stat, errmsg, errmsg_len);
12588 26 : else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
12589 14 : fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
12590 : image_index, stat, errmsg,
12591 : strlen, errmsg_len);
12592 : else
12593 : {
12594 12 : tree opr, opr_flags;
12595 :
12596 : // FIXME: Handle TS29113's bind(C) strings with descriptor.
12597 12 : int opr_flag_int;
12598 12 : if (gfc_is_proc_ptr_comp (opr_expr))
12599 : {
12600 0 : gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
12601 0 : opr_flag_int = sym->attr.dimension
12602 0 : || (sym->ts.type == BT_CHARACTER
12603 0 : && !sym->attr.is_bind_c)
12604 0 : ? GFC_CAF_BYREF : 0;
12605 0 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12606 0 : && !sym->attr.is_bind_c
12607 0 : ? GFC_CAF_HIDDENLEN : 0;
12608 0 : opr_flag_int |= sym->formal->sym->attr.value
12609 0 : ? GFC_CAF_ARG_VALUE : 0;
12610 : }
12611 : else
12612 : {
12613 12 : opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
12614 12 : ? GFC_CAF_BYREF : 0;
12615 24 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12616 0 : && !opr_expr->symtree->n.sym->attr.is_bind_c
12617 12 : ? GFC_CAF_HIDDENLEN : 0;
12618 12 : opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
12619 12 : ? GFC_CAF_ARG_VALUE : 0;
12620 : }
12621 12 : opr_flags = build_int_cst (integer_type_node, opr_flag_int);
12622 12 : gfc_conv_expr (&argse, opr_expr);
12623 12 : opr = argse.expr;
12624 12 : fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
12625 : opr_flags, image_index, stat, errmsg,
12626 : strlen, errmsg_len);
12627 : }
12628 : }
12629 :
12630 52 : gfc_add_expr_to_block (&block, fndecl);
12631 52 : gfc_add_block_to_block (&block, &post_block);
12632 :
12633 52 : return gfc_finish_block (&block);
12634 : }
12635 :
12636 :
12637 : static tree
12638 95 : conv_intrinsic_atomic_op (gfc_code *code)
12639 : {
12640 95 : gfc_se argse;
12641 95 : tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
12642 95 : stmtblock_t block, post_block;
12643 95 : gfc_expr *atom_expr = code->ext.actual->expr;
12644 95 : gfc_expr *stat_expr;
12645 95 : built_in_function fn;
12646 :
12647 95 : if (atom_expr->expr_type == EXPR_FUNCTION
12648 0 : && atom_expr->value.function.isym
12649 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12650 0 : atom_expr = atom_expr->value.function.actual->expr;
12651 :
12652 95 : gfc_start_block (&block);
12653 95 : gfc_init_block (&post_block);
12654 :
12655 95 : gfc_init_se (&argse, NULL);
12656 95 : argse.want_pointer = 1;
12657 95 : gfc_conv_expr (&argse, atom_expr);
12658 95 : gfc_add_block_to_block (&block, &argse.pre);
12659 95 : gfc_add_block_to_block (&post_block, &argse.post);
12660 95 : atom = argse.expr;
12661 :
12662 95 : gfc_init_se (&argse, NULL);
12663 95 : if (flag_coarray == GFC_FCOARRAY_LIB
12664 56 : && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
12665 54 : argse.want_pointer = 1;
12666 95 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12667 95 : gfc_add_block_to_block (&block, &argse.pre);
12668 95 : gfc_add_block_to_block (&post_block, &argse.post);
12669 95 : value = argse.expr;
12670 :
12671 95 : switch (code->resolved_isym->id)
12672 : {
12673 58 : case GFC_ISYM_ATOMIC_ADD:
12674 58 : case GFC_ISYM_ATOMIC_AND:
12675 58 : case GFC_ISYM_ATOMIC_DEF:
12676 58 : case GFC_ISYM_ATOMIC_OR:
12677 58 : case GFC_ISYM_ATOMIC_XOR:
12678 58 : stat_expr = code->ext.actual->next->next->expr;
12679 58 : if (flag_coarray == GFC_FCOARRAY_LIB)
12680 34 : old = null_pointer_node;
12681 : break;
12682 37 : default:
12683 37 : gfc_init_se (&argse, NULL);
12684 37 : if (flag_coarray == GFC_FCOARRAY_LIB)
12685 22 : argse.want_pointer = 1;
12686 37 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12687 37 : gfc_add_block_to_block (&block, &argse.pre);
12688 37 : gfc_add_block_to_block (&post_block, &argse.post);
12689 37 : old = argse.expr;
12690 37 : stat_expr = code->ext.actual->next->next->next->expr;
12691 : }
12692 :
12693 : /* STAT= */
12694 95 : if (stat_expr != NULL)
12695 : {
12696 82 : gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
12697 82 : gfc_init_se (&argse, NULL);
12698 82 : if (flag_coarray == GFC_FCOARRAY_LIB)
12699 48 : argse.want_pointer = 1;
12700 82 : gfc_conv_expr_val (&argse, stat_expr);
12701 82 : gfc_add_block_to_block (&block, &argse.pre);
12702 82 : gfc_add_block_to_block (&post_block, &argse.post);
12703 82 : stat = argse.expr;
12704 : }
12705 13 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12706 8 : stat = null_pointer_node;
12707 :
12708 95 : if (flag_coarray == GFC_FCOARRAY_LIB)
12709 : {
12710 56 : tree image_index, caf_decl, offset, token;
12711 56 : int op;
12712 :
12713 56 : switch (code->resolved_isym->id)
12714 : {
12715 : case GFC_ISYM_ATOMIC_ADD:
12716 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12717 : op = (int) GFC_CAF_ATOMIC_ADD;
12718 : break;
12719 12 : case GFC_ISYM_ATOMIC_AND:
12720 12 : case GFC_ISYM_ATOMIC_FETCH_AND:
12721 12 : op = (int) GFC_CAF_ATOMIC_AND;
12722 12 : break;
12723 12 : case GFC_ISYM_ATOMIC_OR:
12724 12 : case GFC_ISYM_ATOMIC_FETCH_OR:
12725 12 : op = (int) GFC_CAF_ATOMIC_OR;
12726 12 : break;
12727 12 : case GFC_ISYM_ATOMIC_XOR:
12728 12 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12729 12 : op = (int) GFC_CAF_ATOMIC_XOR;
12730 12 : break;
12731 11 : case GFC_ISYM_ATOMIC_DEF:
12732 11 : op = 0; /* Unused. */
12733 11 : break;
12734 0 : default:
12735 0 : gcc_unreachable ();
12736 : }
12737 :
12738 56 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12739 56 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12740 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12741 :
12742 56 : if (gfc_is_coindexed (atom_expr))
12743 48 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12744 : else
12745 8 : image_index = integer_zero_node;
12746 :
12747 : /* Ensure VALUE names addressable storage: taking the address of a
12748 : constant is invalid in C, and scalars need a temporary as well. */
12749 56 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12750 : {
12751 42 : tree elem
12752 42 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value);
12753 42 : elem = gfc_trans_force_lval (&block, elem);
12754 42 : value = gfc_build_addr_expr (NULL_TREE, elem);
12755 : }
12756 14 : else if (TREE_CODE (value) == ADDR_EXPR
12757 14 : && TREE_CONSTANT (TREE_OPERAND (value, 0)))
12758 : {
12759 0 : tree elem
12760 0 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)),
12761 : build_fold_indirect_ref (value));
12762 0 : elem = gfc_trans_force_lval (&block, elem);
12763 0 : value = gfc_build_addr_expr (NULL_TREE, elem);
12764 : }
12765 :
12766 56 : gfc_init_se (&argse, NULL);
12767 56 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12768 : atom_expr);
12769 :
12770 56 : gfc_add_block_to_block (&block, &argse.pre);
12771 56 : if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
12772 11 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
12773 : token, offset, image_index, value, stat,
12774 : build_int_cst (integer_type_node,
12775 11 : (int) atom_expr->ts.type),
12776 : build_int_cst (integer_type_node,
12777 11 : (int) atom_expr->ts.kind));
12778 : else
12779 45 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
12780 45 : build_int_cst (integer_type_node, op),
12781 : token, offset, image_index, value, old, stat,
12782 : build_int_cst (integer_type_node,
12783 45 : (int) atom_expr->ts.type),
12784 : build_int_cst (integer_type_node,
12785 45 : (int) atom_expr->ts.kind));
12786 :
12787 56 : gfc_add_expr_to_block (&block, tmp);
12788 56 : gfc_add_block_to_block (&block, &argse.post);
12789 56 : gfc_add_block_to_block (&block, &post_block);
12790 56 : return gfc_finish_block (&block);
12791 : }
12792 :
12793 :
12794 39 : switch (code->resolved_isym->id)
12795 : {
12796 : case GFC_ISYM_ATOMIC_ADD:
12797 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12798 : fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
12799 : break;
12800 8 : case GFC_ISYM_ATOMIC_AND:
12801 8 : case GFC_ISYM_ATOMIC_FETCH_AND:
12802 8 : fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12803 8 : break;
12804 9 : case GFC_ISYM_ATOMIC_DEF:
12805 9 : fn = BUILT_IN_ATOMIC_STORE_N;
12806 9 : break;
12807 8 : case GFC_ISYM_ATOMIC_OR:
12808 8 : case GFC_ISYM_ATOMIC_FETCH_OR:
12809 8 : fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12810 8 : break;
12811 8 : case GFC_ISYM_ATOMIC_XOR:
12812 8 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12813 8 : fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12814 8 : break;
12815 0 : default:
12816 0 : gcc_unreachable ();
12817 : }
12818 :
12819 39 : tmp = TREE_TYPE (TREE_TYPE (atom));
12820 78 : fn = (built_in_function) ((int) fn
12821 39 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12822 39 : + 1);
12823 39 : tree itype = TREE_TYPE (TREE_TYPE (atom));
12824 39 : tmp = builtin_decl_explicit (fn);
12825 :
12826 39 : switch (code->resolved_isym->id)
12827 : {
12828 24 : case GFC_ISYM_ATOMIC_ADD:
12829 24 : case GFC_ISYM_ATOMIC_AND:
12830 24 : case GFC_ISYM_ATOMIC_DEF:
12831 24 : case GFC_ISYM_ATOMIC_OR:
12832 24 : case GFC_ISYM_ATOMIC_XOR:
12833 24 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12834 : fold_convert (itype, value),
12835 : build_int_cst (NULL, MEMMODEL_RELAXED));
12836 24 : gfc_add_expr_to_block (&block, tmp);
12837 24 : break;
12838 15 : default:
12839 15 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12840 : fold_convert (itype, value),
12841 : build_int_cst (NULL, MEMMODEL_RELAXED));
12842 15 : gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12843 15 : break;
12844 : }
12845 :
12846 39 : if (stat != NULL_TREE)
12847 34 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12848 39 : gfc_add_block_to_block (&block, &post_block);
12849 39 : return gfc_finish_block (&block);
12850 : }
12851 :
12852 :
12853 : static tree
12854 176 : conv_intrinsic_atomic_ref (gfc_code *code)
12855 : {
12856 176 : gfc_se argse;
12857 176 : tree tmp, atom, value, stat = NULL_TREE;
12858 176 : stmtblock_t block, post_block;
12859 176 : built_in_function fn;
12860 176 : gfc_expr *atom_expr = code->ext.actual->next->expr;
12861 :
12862 176 : if (atom_expr->expr_type == EXPR_FUNCTION
12863 0 : && atom_expr->value.function.isym
12864 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12865 0 : atom_expr = atom_expr->value.function.actual->expr;
12866 :
12867 176 : gfc_start_block (&block);
12868 176 : gfc_init_block (&post_block);
12869 176 : gfc_init_se (&argse, NULL);
12870 176 : argse.want_pointer = 1;
12871 176 : gfc_conv_expr (&argse, atom_expr);
12872 176 : gfc_add_block_to_block (&block, &argse.pre);
12873 176 : gfc_add_block_to_block (&post_block, &argse.post);
12874 176 : atom = argse.expr;
12875 :
12876 176 : gfc_init_se (&argse, NULL);
12877 176 : if (flag_coarray == GFC_FCOARRAY_LIB
12878 115 : && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12879 109 : argse.want_pointer = 1;
12880 176 : gfc_conv_expr (&argse, code->ext.actual->expr);
12881 176 : gfc_add_block_to_block (&block, &argse.pre);
12882 176 : gfc_add_block_to_block (&post_block, &argse.post);
12883 176 : value = argse.expr;
12884 :
12885 : /* STAT= */
12886 176 : if (code->ext.actual->next->next->expr != NULL)
12887 : {
12888 164 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12889 : == EXPR_VARIABLE);
12890 164 : gfc_init_se (&argse, NULL);
12891 164 : if (flag_coarray == GFC_FCOARRAY_LIB)
12892 108 : argse.want_pointer = 1;
12893 164 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12894 164 : gfc_add_block_to_block (&block, &argse.pre);
12895 164 : gfc_add_block_to_block (&post_block, &argse.post);
12896 164 : stat = argse.expr;
12897 : }
12898 12 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12899 7 : stat = null_pointer_node;
12900 :
12901 176 : if (flag_coarray == GFC_FCOARRAY_LIB)
12902 : {
12903 115 : tree image_index, caf_decl, offset, token;
12904 115 : tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12905 :
12906 115 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12907 115 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12908 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12909 :
12910 115 : if (gfc_is_coindexed (atom_expr))
12911 103 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12912 : else
12913 12 : image_index = integer_zero_node;
12914 :
12915 115 : gfc_init_se (&argse, NULL);
12916 115 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12917 : atom_expr);
12918 115 : gfc_add_block_to_block (&block, &argse.pre);
12919 :
12920 : /* Different type, need type conversion. */
12921 115 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12922 : {
12923 6 : vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12924 6 : orig_value = value;
12925 6 : value = gfc_build_addr_expr (NULL_TREE, vardecl);
12926 : }
12927 :
12928 115 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12929 : token, offset, image_index, value, stat,
12930 : build_int_cst (integer_type_node,
12931 115 : (int) atom_expr->ts.type),
12932 : build_int_cst (integer_type_node,
12933 115 : (int) atom_expr->ts.kind));
12934 115 : gfc_add_expr_to_block (&block, tmp);
12935 115 : if (vardecl != NULL_TREE)
12936 6 : gfc_add_modify (&block, orig_value,
12937 6 : fold_convert (TREE_TYPE (orig_value), vardecl));
12938 115 : gfc_add_block_to_block (&block, &argse.post);
12939 115 : gfc_add_block_to_block (&block, &post_block);
12940 115 : return gfc_finish_block (&block);
12941 : }
12942 :
12943 61 : tmp = TREE_TYPE (TREE_TYPE (atom));
12944 122 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12945 61 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12946 61 : + 1);
12947 61 : tmp = builtin_decl_explicit (fn);
12948 61 : tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12949 : build_int_cst (integer_type_node,
12950 : MEMMODEL_RELAXED));
12951 61 : gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12952 :
12953 61 : if (stat != NULL_TREE)
12954 56 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12955 61 : gfc_add_block_to_block (&block, &post_block);
12956 61 : return gfc_finish_block (&block);
12957 : }
12958 :
12959 :
12960 : static tree
12961 14 : conv_intrinsic_atomic_cas (gfc_code *code)
12962 : {
12963 14 : gfc_se argse;
12964 14 : tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12965 14 : stmtblock_t block, post_block;
12966 14 : built_in_function fn;
12967 14 : gfc_expr *atom_expr = code->ext.actual->expr;
12968 :
12969 14 : if (atom_expr->expr_type == EXPR_FUNCTION
12970 0 : && atom_expr->value.function.isym
12971 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12972 0 : atom_expr = atom_expr->value.function.actual->expr;
12973 :
12974 14 : gfc_init_block (&block);
12975 14 : gfc_init_block (&post_block);
12976 14 : gfc_init_se (&argse, NULL);
12977 14 : argse.want_pointer = 1;
12978 14 : gfc_conv_expr (&argse, atom_expr);
12979 14 : atom = argse.expr;
12980 :
12981 14 : gfc_init_se (&argse, NULL);
12982 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12983 8 : argse.want_pointer = 1;
12984 14 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12985 14 : gfc_add_block_to_block (&block, &argse.pre);
12986 14 : gfc_add_block_to_block (&post_block, &argse.post);
12987 14 : old = argse.expr;
12988 :
12989 14 : gfc_init_se (&argse, NULL);
12990 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12991 8 : argse.want_pointer = 1;
12992 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12993 14 : gfc_add_block_to_block (&block, &argse.pre);
12994 14 : gfc_add_block_to_block (&post_block, &argse.post);
12995 14 : comp = argse.expr;
12996 :
12997 14 : gfc_init_se (&argse, NULL);
12998 14 : if (flag_coarray == GFC_FCOARRAY_LIB
12999 8 : && code->ext.actual->next->next->next->expr->ts.kind
13000 8 : == atom_expr->ts.kind)
13001 8 : argse.want_pointer = 1;
13002 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
13003 14 : gfc_add_block_to_block (&block, &argse.pre);
13004 14 : gfc_add_block_to_block (&post_block, &argse.post);
13005 14 : new_val = argse.expr;
13006 :
13007 : /* STAT= */
13008 14 : if (code->ext.actual->next->next->next->next->expr != NULL)
13009 : {
13010 14 : gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
13011 : == EXPR_VARIABLE);
13012 14 : gfc_init_se (&argse, NULL);
13013 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13014 8 : argse.want_pointer = 1;
13015 14 : gfc_conv_expr_val (&argse,
13016 14 : code->ext.actual->next->next->next->next->expr);
13017 14 : gfc_add_block_to_block (&block, &argse.pre);
13018 14 : gfc_add_block_to_block (&post_block, &argse.post);
13019 14 : stat = argse.expr;
13020 : }
13021 0 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13022 0 : stat = null_pointer_node;
13023 :
13024 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13025 : {
13026 8 : tree image_index, caf_decl, offset, token;
13027 :
13028 8 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
13029 8 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
13030 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
13031 :
13032 8 : if (gfc_is_coindexed (atom_expr))
13033 8 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
13034 : else
13035 0 : image_index = integer_zero_node;
13036 :
13037 8 : if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
13038 : {
13039 0 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
13040 0 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
13041 0 : new_val = gfc_build_addr_expr (NULL_TREE, tmp);
13042 : }
13043 :
13044 8 : gfc_init_se (&argse, NULL);
13045 8 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
13046 : atom_expr);
13047 8 : gfc_add_block_to_block (&block, &argse.pre);
13048 :
13049 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
13050 : token, offset, image_index, old, comp, new_val,
13051 : stat, build_int_cst (integer_type_node,
13052 8 : (int) atom_expr->ts.type),
13053 : build_int_cst (integer_type_node,
13054 8 : (int) atom_expr->ts.kind));
13055 8 : gfc_add_expr_to_block (&block, tmp);
13056 8 : gfc_add_block_to_block (&block, &argse.post);
13057 8 : gfc_add_block_to_block (&block, &post_block);
13058 8 : return gfc_finish_block (&block);
13059 : }
13060 :
13061 6 : tmp = TREE_TYPE (TREE_TYPE (atom));
13062 12 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
13063 6 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
13064 6 : + 1);
13065 6 : tmp = builtin_decl_explicit (fn);
13066 :
13067 6 : gfc_add_modify (&block, old, comp);
13068 12 : tmp = build_call_expr_loc (input_location, tmp, 6, atom,
13069 : gfc_build_addr_expr (NULL, old),
13070 6 : fold_convert (TREE_TYPE (old), new_val),
13071 : boolean_false_node,
13072 : build_int_cst (NULL, MEMMODEL_RELAXED),
13073 : build_int_cst (NULL, MEMMODEL_RELAXED));
13074 6 : gfc_add_expr_to_block (&block, tmp);
13075 :
13076 6 : if (stat != NULL_TREE)
13077 6 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
13078 6 : gfc_add_block_to_block (&block, &post_block);
13079 6 : return gfc_finish_block (&block);
13080 : }
13081 :
13082 : static tree
13083 105 : conv_intrinsic_event_query (gfc_code *code)
13084 : {
13085 105 : gfc_se se, argse;
13086 105 : tree stat = NULL_TREE, stat2 = NULL_TREE;
13087 105 : tree count = NULL_TREE, count2 = NULL_TREE;
13088 :
13089 105 : gfc_expr *event_expr = code->ext.actual->expr;
13090 :
13091 105 : if (code->ext.actual->next->next->expr)
13092 : {
13093 18 : gcc_assert (code->ext.actual->next->next->expr->expr_type
13094 : == EXPR_VARIABLE);
13095 18 : gfc_init_se (&argse, NULL);
13096 18 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
13097 18 : stat = argse.expr;
13098 : }
13099 87 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13100 58 : stat = null_pointer_node;
13101 :
13102 105 : if (code->ext.actual->next->expr)
13103 : {
13104 105 : gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
13105 105 : gfc_init_se (&argse, NULL);
13106 105 : gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
13107 105 : count = argse.expr;
13108 : }
13109 :
13110 105 : gfc_start_block (&se.pre);
13111 105 : if (flag_coarray == GFC_FCOARRAY_LIB)
13112 : {
13113 70 : tree tmp, token, image_index;
13114 70 : tree index = build_zero_cst (gfc_array_index_type);
13115 :
13116 70 : if (event_expr->expr_type == EXPR_FUNCTION
13117 0 : && event_expr->value.function.isym
13118 0 : && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
13119 0 : event_expr = event_expr->value.function.actual->expr;
13120 :
13121 70 : tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
13122 :
13123 70 : if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
13124 70 : || event_expr->symtree->n.sym->ts.u.derived->from_intmod
13125 : != INTMOD_ISO_FORTRAN_ENV
13126 70 : || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
13127 : != ISOFORTRAN_EVENT_TYPE)
13128 : {
13129 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
13130 : "yet supported", &event_expr->where);
13131 0 : return NULL_TREE;
13132 : }
13133 :
13134 70 : if (gfc_is_coindexed (event_expr))
13135 : {
13136 0 : gfc_error ("The event variable at %L shall not be coindexed",
13137 : &event_expr->where);
13138 0 : return NULL_TREE;
13139 : }
13140 :
13141 70 : image_index = integer_zero_node;
13142 :
13143 70 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
13144 : event_expr);
13145 :
13146 : /* For arrays, obtain the array index. */
13147 70 : if (gfc_expr_attr (event_expr).dimension)
13148 : {
13149 52 : tree desc, tmp, extent, lbound, ubound;
13150 52 : gfc_array_ref *ar, ar2;
13151 52 : int i;
13152 :
13153 : /* TODO: Extend this, once DT components are supported. */
13154 52 : ar = &event_expr->ref->u.ar;
13155 52 : ar2 = *ar;
13156 52 : memset (ar, '\0', sizeof (*ar));
13157 52 : ar->as = ar2.as;
13158 52 : ar->type = AR_FULL;
13159 :
13160 52 : gfc_init_se (&argse, NULL);
13161 52 : argse.descriptor_only = 1;
13162 52 : gfc_conv_expr_descriptor (&argse, event_expr);
13163 52 : gfc_add_block_to_block (&se.pre, &argse.pre);
13164 52 : desc = argse.expr;
13165 52 : *ar = ar2;
13166 :
13167 52 : extent = build_one_cst (gfc_array_index_type);
13168 156 : for (i = 0; i < ar->dimen; i++)
13169 : {
13170 52 : gfc_init_se (&argse, NULL);
13171 52 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
13172 52 : gfc_add_block_to_block (&argse.pre, &argse.pre);
13173 52 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
13174 52 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
13175 52 : TREE_TYPE (lbound), argse.expr, lbound);
13176 52 : tmp = fold_build2_loc (input_location, MULT_EXPR,
13177 52 : TREE_TYPE (tmp), extent, tmp);
13178 52 : index = fold_build2_loc (input_location, PLUS_EXPR,
13179 52 : TREE_TYPE (tmp), index, tmp);
13180 52 : if (i < ar->dimen - 1)
13181 : {
13182 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
13183 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
13184 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
13185 0 : TREE_TYPE (tmp), extent, tmp);
13186 : }
13187 : }
13188 : }
13189 :
13190 70 : if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
13191 : {
13192 0 : count2 = count;
13193 0 : count = gfc_create_var (integer_type_node, "count");
13194 : }
13195 :
13196 70 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
13197 : {
13198 0 : stat2 = stat;
13199 0 : stat = gfc_create_var (integer_type_node, "stat");
13200 : }
13201 :
13202 70 : index = fold_convert (size_type_node, index);
13203 140 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
13204 : token, index, image_index, count
13205 70 : ? gfc_build_addr_expr (NULL, count) : count,
13206 70 : stat != null_pointer_node
13207 12 : ? gfc_build_addr_expr (NULL, stat) : stat);
13208 70 : gfc_add_expr_to_block (&se.pre, tmp);
13209 :
13210 70 : if (count2 != NULL_TREE)
13211 0 : gfc_add_modify (&se.pre, count2,
13212 0 : fold_convert (TREE_TYPE (count2), count));
13213 :
13214 70 : if (stat2 != NULL_TREE)
13215 0 : gfc_add_modify (&se.pre, stat2,
13216 0 : fold_convert (TREE_TYPE (stat2), stat));
13217 :
13218 70 : return gfc_finish_block (&se.pre);
13219 : }
13220 :
13221 35 : gfc_init_se (&argse, NULL);
13222 35 : gfc_conv_expr_val (&argse, code->ext.actual->expr);
13223 35 : gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
13224 :
13225 35 : if (stat != NULL_TREE)
13226 6 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
13227 :
13228 35 : return gfc_finish_block (&se.pre);
13229 : }
13230 :
13231 :
13232 : /* This is a peculiar case because of the need to do dependency checking.
13233 : It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
13234 : a special case and this function called instead of
13235 : gfc_conv_procedure_call. */
13236 : void
13237 197 : gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
13238 : gfc_loopinfo *loop)
13239 : {
13240 197 : gfc_actual_arglist *actual;
13241 197 : gfc_se argse[5];
13242 197 : gfc_expr *arg[5];
13243 197 : gfc_ss *lss;
13244 197 : int n;
13245 :
13246 197 : tree from, frompos, len, to, topos;
13247 197 : tree lenmask, oldbits, newbits, bitsize;
13248 197 : tree type, utype, above, mask1, mask2;
13249 :
13250 197 : if (loop)
13251 67 : lss = loop->ss;
13252 : else
13253 130 : lss = gfc_ss_terminator;
13254 :
13255 : actual = actual_args;
13256 1182 : for (n = 0; n < 5; n++, actual = actual->next)
13257 : {
13258 985 : arg[n] = actual->expr;
13259 985 : gfc_init_se (&argse[n], NULL);
13260 :
13261 985 : if (lss != gfc_ss_terminator)
13262 : {
13263 335 : gfc_copy_loopinfo_to_se (&argse[n], loop);
13264 : /* Find the ss for the expression if it is there. */
13265 335 : argse[n].ss = lss;
13266 335 : gfc_mark_ss_chain_used (lss, 1);
13267 : }
13268 :
13269 985 : gfc_conv_expr (&argse[n], arg[n]);
13270 :
13271 985 : if (loop)
13272 335 : lss = argse[n].ss;
13273 : }
13274 :
13275 197 : from = argse[0].expr;
13276 197 : frompos = argse[1].expr;
13277 197 : len = argse[2].expr;
13278 197 : to = argse[3].expr;
13279 197 : topos = argse[4].expr;
13280 :
13281 : /* The type of the result (TO). */
13282 197 : type = TREE_TYPE (to);
13283 197 : bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
13284 :
13285 : /* Optionally generate code for runtime argument check. */
13286 197 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
13287 : {
13288 18 : tree nbits, below, ccond;
13289 18 : tree fp = fold_convert (long_integer_type_node, frompos);
13290 18 : tree ln = fold_convert (long_integer_type_node, len);
13291 18 : tree tp = fold_convert (long_integer_type_node, topos);
13292 18 : below = fold_build2_loc (input_location, LT_EXPR,
13293 : logical_type_node, frompos,
13294 18 : build_int_cst (TREE_TYPE (frompos), 0));
13295 18 : above = fold_build2_loc (input_location, GT_EXPR,
13296 : logical_type_node, frompos,
13297 18 : fold_convert (TREE_TYPE (frompos), bitsize));
13298 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13299 : logical_type_node, below, above);
13300 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13301 18 : &arg[1]->where,
13302 : "FROMPOS argument (%ld) out of range 0:%d "
13303 : "in intrinsic MVBITS", fp, bitsize);
13304 18 : below = fold_build2_loc (input_location, LT_EXPR,
13305 : logical_type_node, len,
13306 18 : build_int_cst (TREE_TYPE (len), 0));
13307 18 : above = fold_build2_loc (input_location, GT_EXPR,
13308 : logical_type_node, len,
13309 18 : fold_convert (TREE_TYPE (len), bitsize));
13310 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13311 : logical_type_node, below, above);
13312 18 : gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
13313 18 : &arg[2]->where,
13314 : "LEN argument (%ld) out of range 0:%d "
13315 : "in intrinsic MVBITS", ln, bitsize);
13316 18 : below = fold_build2_loc (input_location, LT_EXPR,
13317 : logical_type_node, topos,
13318 18 : build_int_cst (TREE_TYPE (topos), 0));
13319 18 : above = fold_build2_loc (input_location, GT_EXPR,
13320 : logical_type_node, topos,
13321 18 : fold_convert (TREE_TYPE (topos), bitsize));
13322 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13323 : logical_type_node, below, above);
13324 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13325 18 : &arg[4]->where,
13326 : "TOPOS argument (%ld) out of range 0:%d "
13327 : "in intrinsic MVBITS", tp, bitsize);
13328 :
13329 : /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
13330 : integers. Additions below cannot overflow. */
13331 18 : nbits = fold_convert (long_integer_type_node, bitsize);
13332 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13333 : long_integer_type_node, fp, ln);
13334 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13335 : logical_type_node, above, nbits);
13336 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13337 : &arg[1]->where,
13338 : "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13339 : "in intrinsic MVBITS", fp, ln, bitsize);
13340 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13341 : long_integer_type_node, tp, ln);
13342 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13343 : logical_type_node, above, nbits);
13344 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13345 : &arg[4]->where,
13346 : "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13347 : "in intrinsic MVBITS", tp, ln, bitsize);
13348 : }
13349 :
13350 1182 : for (n = 0; n < 5; n++)
13351 : {
13352 985 : gfc_add_block_to_block (&se->pre, &argse[n].pre);
13353 985 : gfc_add_block_to_block (&se->post, &argse[n].post);
13354 : }
13355 :
13356 : /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
13357 197 : above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
13358 197 : len, fold_convert (TREE_TYPE (len), bitsize));
13359 197 : mask1 = build_int_cst (type, -1);
13360 197 : mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13361 : build_int_cst (type, 1), len);
13362 197 : mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
13363 : mask2, build_int_cst (type, 1));
13364 197 : lenmask = fold_build3_loc (input_location, COND_EXPR, type,
13365 : above, mask1, mask2);
13366 :
13367 : /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
13368 : * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
13369 : * not strictly necessary; artificial bits from rshift will be masked. */
13370 197 : utype = unsigned_type_for (type);
13371 197 : newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
13372 : fold_convert (utype, from), frompos);
13373 197 : newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
13374 : fold_convert (type, newbits), lenmask);
13375 197 : newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13376 : newbits, topos);
13377 :
13378 : /* oldbits = TO & (~(lenmask << TOPOS)). */
13379 197 : oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13380 : lenmask, topos);
13381 197 : oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
13382 197 : oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
13383 :
13384 : /* TO = newbits | oldbits. */
13385 197 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
13386 : oldbits, newbits);
13387 :
13388 : /* Return the assignment. */
13389 197 : se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
13390 : void_type_node, to, se->expr);
13391 197 : }
13392 :
13393 : /* Comes from trans-stmt.cc, but we don't want the whole header included. */
13394 : extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
13395 : tree *stat, tree *errmsg, tree *errmsg_len);
13396 :
13397 : static tree
13398 263 : conv_intrinsic_move_alloc (gfc_code *code)
13399 : {
13400 263 : stmtblock_t block;
13401 263 : gfc_expr *from_expr, *to_expr;
13402 263 : gfc_se from_se, to_se;
13403 263 : tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE;
13404 263 : bool coarray, from_is_class, from_is_scalar;
13405 263 : gfc_actual_arglist *arg = code->ext.actual;
13406 263 : sync_stat tmp_sync_stat = {nullptr, nullptr};
13407 :
13408 263 : gfc_start_block (&block);
13409 :
13410 263 : from_expr = arg->expr;
13411 263 : arg = arg->next;
13412 263 : to_expr = arg->expr;
13413 263 : arg = arg->next;
13414 :
13415 789 : while (arg)
13416 : {
13417 526 : if (arg->expr)
13418 : {
13419 0 : if (!strcmp ("stat", arg->name))
13420 0 : tmp_sync_stat.stat = arg->expr;
13421 0 : else if (!strcmp ("errmsg", arg->name))
13422 0 : tmp_sync_stat.errmsg = arg->expr;
13423 : }
13424 526 : arg = arg->next;
13425 : }
13426 :
13427 263 : gfc_init_se (&from_se, NULL);
13428 263 : gfc_init_se (&to_se, NULL);
13429 :
13430 263 : gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len);
13431 263 : if (stat != null_pointer_node)
13432 0 : fin_label = gfc_build_label_decl (NULL_TREE);
13433 :
13434 263 : gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
13435 263 : coarray = from_expr->corank != 0;
13436 :
13437 263 : from_is_class = from_expr->ts.type == BT_CLASS;
13438 263 : from_is_scalar = from_expr->rank == 0 && !coarray;
13439 263 : if (to_expr->ts.type == BT_CLASS || from_is_scalar)
13440 : {
13441 163 : from_se.want_pointer = 1;
13442 163 : if (from_is_scalar)
13443 115 : gfc_conv_expr (&from_se, from_expr);
13444 : else
13445 48 : gfc_conv_expr_descriptor (&from_se, from_expr);
13446 163 : if (from_is_class)
13447 64 : from_tree = gfc_class_data_get (from_se.expr);
13448 : else
13449 : {
13450 99 : gfc_symbol *vtab;
13451 99 : from_tree = from_se.expr;
13452 :
13453 99 : if (to_expr->ts.type == BT_CLASS)
13454 : {
13455 36 : vtab = gfc_find_vtab (&from_expr->ts);
13456 36 : gcc_assert (vtab);
13457 36 : from_se.expr = gfc_get_symbol_decl (vtab);
13458 : }
13459 : }
13460 163 : gfc_add_block_to_block (&block, &from_se.pre);
13461 :
13462 163 : to_se.want_pointer = 1;
13463 163 : if (to_expr->rank == 0)
13464 115 : gfc_conv_expr (&to_se, to_expr);
13465 : else
13466 48 : gfc_conv_expr_descriptor (&to_se, to_expr);
13467 163 : if (to_expr->ts.type == BT_CLASS)
13468 100 : to_tree = gfc_class_data_get (to_se.expr);
13469 : else
13470 63 : to_tree = to_se.expr;
13471 163 : gfc_add_block_to_block (&block, &to_se.pre);
13472 :
13473 : /* Deallocate "to". */
13474 163 : if (to_expr->rank == 0)
13475 : {
13476 115 : tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
13477 : true, to_expr, to_expr->ts,
13478 : NULL_TREE, false, true,
13479 : errmsg, errmsg_len);
13480 115 : gfc_add_expr_to_block (&block, tmp);
13481 : }
13482 :
13483 163 : if (from_is_scalar)
13484 : {
13485 : /* Assign (_data) pointers. */
13486 115 : gfc_add_modify_loc (input_location, &block, to_tree,
13487 115 : fold_convert (TREE_TYPE (to_tree), from_tree));
13488 :
13489 : /* Set "from" to NULL. */
13490 115 : gfc_add_modify_loc (input_location, &block, from_tree,
13491 115 : fold_convert (TREE_TYPE (from_tree),
13492 : null_pointer_node));
13493 :
13494 115 : gfc_add_block_to_block (&block, &from_se.post);
13495 : }
13496 163 : gfc_add_block_to_block (&block, &to_se.post);
13497 :
13498 : /* Set _vptr. */
13499 163 : if (to_expr->ts.type == BT_CLASS)
13500 : {
13501 100 : gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
13502 100 : if (from_is_class)
13503 64 : gfc_reset_vptr (&block, from_expr);
13504 100 : if (UNLIMITED_POLY (to_expr))
13505 : {
13506 20 : tree to_len = gfc_class_len_get (to_se.class_container);
13507 20 : tmp = from_expr->ts.type == BT_CHARACTER && from_se.string_length
13508 20 : ? from_se.string_length
13509 : : size_zero_node;
13510 20 : gfc_add_modify_loc (input_location, &block, to_len,
13511 20 : fold_convert (TREE_TYPE (to_len), tmp));
13512 : }
13513 : }
13514 :
13515 163 : if (from_is_scalar)
13516 : {
13517 115 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13518 : {
13519 6 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13520 6 : fold_convert (TREE_TYPE (to_se.string_length),
13521 : from_se.string_length));
13522 6 : if (from_expr->ts.deferred)
13523 6 : gfc_add_modify_loc (
13524 : input_location, &block, from_se.string_length,
13525 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13526 : }
13527 115 : if (UNLIMITED_POLY (from_expr))
13528 2 : gfc_reset_len (&block, from_expr);
13529 :
13530 115 : return gfc_finish_block (&block);
13531 : }
13532 :
13533 48 : gfc_init_se (&to_se, NULL);
13534 48 : gfc_init_se (&from_se, NULL);
13535 : }
13536 :
13537 : /* Deallocate "to". */
13538 148 : if (from_expr->rank == 0)
13539 : {
13540 4 : to_se.want_coarray = 1;
13541 4 : from_se.want_coarray = 1;
13542 : }
13543 148 : gfc_conv_expr_descriptor (&to_se, to_expr);
13544 148 : gfc_conv_expr_descriptor (&from_se, from_expr);
13545 148 : gfc_add_block_to_block (&block, &to_se.pre);
13546 148 : gfc_add_block_to_block (&block, &from_se.pre);
13547 :
13548 : /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
13549 : is an image control "statement", cf. IR F08/0040 in 12-006A. */
13550 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13551 : {
13552 6 : tree cond;
13553 :
13554 6 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13555 : fin_label, true, to_expr,
13556 : GFC_CAF_COARRAY_DEALLOCATE_ONLY,
13557 : NULL_TREE, NULL_TREE,
13558 : gfc_conv_descriptor_token (to_se.expr),
13559 : true);
13560 6 : gfc_add_expr_to_block (&block, tmp);
13561 :
13562 6 : tmp = gfc_conv_descriptor_data_get (to_se.expr);
13563 6 : cond = fold_build2_loc (input_location, EQ_EXPR,
13564 : logical_type_node, tmp,
13565 6 : fold_convert (TREE_TYPE (tmp),
13566 : null_pointer_node));
13567 6 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
13568 : 3, null_pointer_node, null_pointer_node,
13569 : integer_zero_node);
13570 :
13571 6 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
13572 : tmp, build_empty_stmt (input_location));
13573 6 : gfc_add_expr_to_block (&block, tmp);
13574 6 : }
13575 : else
13576 : {
13577 142 : if (to_expr->ts.type == BT_DERIVED
13578 25 : && to_expr->ts.u.derived->attr.alloc_comp)
13579 : {
13580 19 : tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
13581 : to_se.expr, to_expr->rank);
13582 19 : gfc_add_expr_to_block (&block, tmp);
13583 : }
13584 :
13585 142 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13586 : fin_label, true, to_expr,
13587 : GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
13588 : NULL_TREE, NULL_TREE, true);
13589 142 : gfc_add_expr_to_block (&block, tmp);
13590 : }
13591 :
13592 : /* Copy the array descriptor data. */
13593 148 : gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
13594 :
13595 : /* Set "from" to NULL. */
13596 148 : tmp = gfc_conv_descriptor_data_get (from_se.expr);
13597 148 : gfc_add_modify_loc (input_location, &block, tmp,
13598 148 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
13599 :
13600 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13601 : {
13602 : /* Copy the array descriptor data has overwritten the to-token and cleared
13603 : from.data. Now also clear the from.token. */
13604 6 : gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr),
13605 : null_pointer_node);
13606 : }
13607 :
13608 148 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13609 : {
13610 7 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13611 7 : fold_convert (TREE_TYPE (to_se.string_length),
13612 : from_se.string_length));
13613 7 : if (from_expr->ts.deferred)
13614 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
13615 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13616 : }
13617 148 : if (fin_label)
13618 0 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
13619 :
13620 148 : gfc_add_block_to_block (&block, &to_se.post);
13621 148 : gfc_add_block_to_block (&block, &from_se.post);
13622 :
13623 148 : return gfc_finish_block (&block);
13624 : }
13625 :
13626 :
13627 : tree
13628 6810 : gfc_conv_intrinsic_subroutine (gfc_code *code)
13629 : {
13630 6810 : tree res;
13631 :
13632 6810 : gcc_assert (code->resolved_isym);
13633 :
13634 6810 : switch (code->resolved_isym->id)
13635 : {
13636 263 : case GFC_ISYM_MOVE_ALLOC:
13637 263 : res = conv_intrinsic_move_alloc (code);
13638 263 : break;
13639 :
13640 14 : case GFC_ISYM_ATOMIC_CAS:
13641 14 : res = conv_intrinsic_atomic_cas (code);
13642 14 : break;
13643 :
13644 95 : case GFC_ISYM_ATOMIC_ADD:
13645 95 : case GFC_ISYM_ATOMIC_AND:
13646 95 : case GFC_ISYM_ATOMIC_DEF:
13647 95 : case GFC_ISYM_ATOMIC_OR:
13648 95 : case GFC_ISYM_ATOMIC_XOR:
13649 95 : case GFC_ISYM_ATOMIC_FETCH_ADD:
13650 95 : case GFC_ISYM_ATOMIC_FETCH_AND:
13651 95 : case GFC_ISYM_ATOMIC_FETCH_OR:
13652 95 : case GFC_ISYM_ATOMIC_FETCH_XOR:
13653 95 : res = conv_intrinsic_atomic_op (code);
13654 95 : break;
13655 :
13656 176 : case GFC_ISYM_ATOMIC_REF:
13657 176 : res = conv_intrinsic_atomic_ref (code);
13658 176 : break;
13659 :
13660 105 : case GFC_ISYM_EVENT_QUERY:
13661 105 : res = conv_intrinsic_event_query (code);
13662 105 : break;
13663 :
13664 3197 : case GFC_ISYM_C_F_POINTER:
13665 3197 : case GFC_ISYM_C_F_PROCPOINTER:
13666 3197 : res = conv_isocbinding_subroutine (code);
13667 3197 : break;
13668 :
13669 60 : case GFC_ISYM_C_F_STRPOINTER:
13670 60 : res = conv_isocbinding_subroutine_strpointer (code);
13671 60 : break;
13672 :
13673 360 : case GFC_ISYM_CAF_SEND:
13674 360 : res = conv_caf_send_to_remote (code);
13675 360 : break;
13676 :
13677 140 : case GFC_ISYM_CAF_SENDGET:
13678 140 : res = conv_caf_sendget (code);
13679 140 : break;
13680 :
13681 88 : case GFC_ISYM_CO_BROADCAST:
13682 88 : case GFC_ISYM_CO_MIN:
13683 88 : case GFC_ISYM_CO_MAX:
13684 88 : case GFC_ISYM_CO_REDUCE:
13685 88 : case GFC_ISYM_CO_SUM:
13686 88 : res = conv_co_collective (code);
13687 88 : break;
13688 :
13689 10 : case GFC_ISYM_FREE:
13690 10 : res = conv_intrinsic_free (code);
13691 10 : break;
13692 :
13693 55 : case GFC_ISYM_FSTAT:
13694 55 : case GFC_ISYM_LSTAT:
13695 55 : case GFC_ISYM_STAT:
13696 55 : res = conv_intrinsic_fstat_lstat_stat_sub (code);
13697 55 : break;
13698 :
13699 90 : case GFC_ISYM_RANDOM_INIT:
13700 90 : res = conv_intrinsic_random_init (code);
13701 90 : break;
13702 :
13703 15 : case GFC_ISYM_KILL:
13704 15 : res = conv_intrinsic_kill_sub (code);
13705 15 : break;
13706 :
13707 : case GFC_ISYM_MVBITS:
13708 : res = NULL_TREE;
13709 : break;
13710 :
13711 194 : case GFC_ISYM_SYSTEM_CLOCK:
13712 194 : res = conv_intrinsic_system_clock (code);
13713 194 : break;
13714 :
13715 102 : case GFC_ISYM_SPLIT:
13716 102 : res = conv_intrinsic_split (code);
13717 102 : break;
13718 :
13719 : default:
13720 : res = NULL_TREE;
13721 : break;
13722 : }
13723 :
13724 6810 : return res;
13725 : }
13726 :
13727 : #include "gt-fortran-trans-intrinsic.h"
|
