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 80158 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
203 : tree *argarray, int nargs)
204 : {
205 80158 : gfc_actual_arglist *actual;
206 80158 : gfc_expr *e;
207 80158 : gfc_intrinsic_arg *formal;
208 80158 : gfc_se argse;
209 80158 : int curr_arg;
210 :
211 80158 : formal = expr->value.function.isym->formal;
212 80158 : actual = expr->value.function.actual;
213 :
214 180830 : for (curr_arg = 0; curr_arg < nargs; curr_arg++,
215 62768 : actual = actual->next,
216 100672 : formal = formal ? formal->next : NULL)
217 : {
218 100672 : gcc_assert (actual);
219 100672 : e = actual->expr;
220 : /* Skip omitted optional arguments. */
221 100672 : if (!e)
222 : {
223 31 : --curr_arg;
224 31 : continue;
225 : }
226 :
227 : /* Evaluate the parameter. This will substitute scalarized
228 : references automatically. */
229 100641 : gfc_init_se (&argse, se);
230 :
231 100641 : if (e->ts.type == BT_CHARACTER)
232 : {
233 9623 : gfc_conv_expr (&argse, e);
234 9623 : gfc_conv_string_parameter (&argse);
235 9623 : argarray[curr_arg++] = argse.string_length;
236 9623 : gcc_assert (curr_arg < nargs);
237 : }
238 : else
239 91018 : 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 100641 : if (e->expr_type == EXPR_VARIABLE
244 51459 : && 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 100641 : gfc_add_block_to_block (&se->pre, &argse.pre);
250 100641 : gfc_add_block_to_block (&se->post, &argse.post);
251 100641 : argarray[curr_arg] = argse.expr;
252 : }
253 80158 : }
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 55345 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
260 : {
261 55345 : int n = 0;
262 55345 : gfc_actual_arglist *actual;
263 :
264 125870 : for (actual = expr->value.function.actual; actual; actual = actual->next)
265 : {
266 70525 : if (!actual->expr)
267 6328 : continue;
268 :
269 64197 : if (actual->expr->ts.type == BT_CHARACTER)
270 4545 : n += 2;
271 : else
272 59652 : n++;
273 : }
274 :
275 55345 : 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 39278 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
284 : {
285 39278 : tree type;
286 39278 : tree *args;
287 39278 : int nargs;
288 :
289 39278 : nargs = gfc_intrinsic_argument_list_length (expr);
290 39278 : 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 39278 : type = gfc_typenode_for_spec (&expr->ts);
296 39278 : gcc_assert (expr->value.function.actual->expr);
297 39278 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
298 :
299 : /* Conversion between character kinds involves a call to a library
300 : function. */
301 39278 : 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 39030 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
338 39030 : && expr->ts.type != BT_COMPLEX)
339 : {
340 577 : tree artype;
341 :
342 577 : artype = TREE_TYPE (TREE_TYPE (args[0]));
343 577 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
344 : args[0]);
345 : }
346 :
347 39030 : 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 1573 : build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
422 : enum rounding_mode op)
423 : {
424 1573 : 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 1279 : case RND_TRUNC:
436 1279 : 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 3100 : gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
530 : {
531 3100 : tree type;
532 3100 : tree *args;
533 3100 : int nargs;
534 :
535 3100 : nargs = gfc_intrinsic_argument_list_length (expr);
536 3100 : 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 3100 : type = gfc_typenode_for_spec (&expr->ts);
541 3100 : gcc_assert (expr->value.function.actual->expr);
542 3100 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
543 :
544 3100 : 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 1573 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
554 1573 : && 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 1573 : se->expr = build_fix_expr (&se->pre, args[0], type, op);
564 : }
565 3100 : }
566 :
567 :
568 : /* Get the imaginary component of a value. */
569 :
570 : static void
571 428 : gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
572 : {
573 428 : tree arg;
574 :
575 428 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
576 428 : se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
577 428 : TREE_TYPE (TREE_TYPE (arg)), arg);
578 428 : }
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 657069 : define_quad_builtin (const char *name, tree type, bool is_const)
596 : {
597 657069 : tree fndecl;
598 657069 : fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
599 : type);
600 :
601 : /* Mark the decl as external. */
602 657069 : DECL_EXTERNAL (fndecl) = 1;
603 657069 : TREE_PUBLIC (fndecl) = 1;
604 :
605 : /* Mark it __attribute__((const)). */
606 657069 : TREE_READONLY (fndecl) = is_const;
607 :
608 657069 : rest_of_decl_compilation (fndecl, 1, 0);
609 :
610 657069 : 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 44881890 : add_simd_flag_for_built_in (tree fndecl)
618 : {
619 44881890 : if (gfc_vectorized_builtins == NULL
620 18043380 : || fndecl == NULL_TREE)
621 37083480 : return;
622 :
623 7798410 : const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
624 7798410 : int *clauses = gfc_vectorized_builtins->get (name);
625 7798410 : if (clauses)
626 : {
627 4892508 : for (unsigned i = 0; i < 3; i++)
628 3669381 : if (*clauses & (1 << i))
629 : {
630 1223132 : gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
631 1223132 : tree omp_clause = NULL_TREE;
632 1223132 : if (simd_type == SIMD_NONE)
633 : ; /* No SIMD clause. */
634 : else
635 : {
636 1223132 : omp_clause_code code
637 : = (simd_type == SIMD_INBRANCH
638 1223132 : ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
639 1223132 : omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
640 1223132 : omp_clause = build_tree_list (NULL_TREE, omp_clause);
641 : }
642 :
643 1223132 : DECL_ATTRIBUTES (fndecl)
644 2446264 : = tree_cons (get_identifier ("omp declare simd"), omp_clause,
645 1223132 : 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 76071 : gfc_adjust_builtins (void)
655 : {
656 76071 : gfc_intrinsic_map_t *m;
657 4564260 : for (m = gfc_intrinsic_map;
658 4564260 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
659 : {
660 4488189 : add_simd_flag_for_built_in (m->real4_decl);
661 4488189 : add_simd_flag_for_built_in (m->complex4_decl);
662 4488189 : add_simd_flag_for_built_in (m->real8_decl);
663 4488189 : add_simd_flag_for_built_in (m->complex8_decl);
664 4488189 : add_simd_flag_for_built_in (m->real10_decl);
665 4488189 : add_simd_flag_for_built_in (m->complex10_decl);
666 4488189 : add_simd_flag_for_built_in (m->real16_decl);
667 4488189 : add_simd_flag_for_built_in (m->complex16_decl);
668 4488189 : add_simd_flag_for_built_in (m->real16_decl);
669 4488189 : add_simd_flag_for_built_in (m->complex16_decl);
670 : }
671 :
672 : /* Release all strings. */
673 76071 : if (gfc_vectorized_builtins != NULL)
674 : {
675 1681801 : for (hash_map<nofree_string_hash, int>::iterator it
676 30582 : = gfc_vectorized_builtins->begin ();
677 1681801 : it != gfc_vectorized_builtins->end (); ++it)
678 1651219 : free (const_cast<char *> ((*it).first));
679 :
680 61164 : delete gfc_vectorized_builtins;
681 30582 : gfc_vectorized_builtins = NULL;
682 : }
683 76071 : }
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 31289 : gfc_build_intrinsic_lib_fndecls (void)
690 : {
691 31289 : gfc_intrinsic_map_t *m;
692 31289 : tree quad_decls[END_BUILTINS + 1];
693 :
694 31289 : 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 31289 : tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
701 31289 : tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
702 :
703 31289 : memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
704 :
705 31289 : type = gfc_float128_type_node;
706 31289 : complex_type = gfc_complex_float128_type_node;
707 : /* type (*) (type) */
708 31289 : func_1 = build_function_type_list (type, type, NULL_TREE);
709 : /* int (*) (type) */
710 31289 : func_iround = build_function_type_list (integer_type_node,
711 : type, NULL_TREE);
712 : /* long (*) (type) */
713 31289 : func_lround = build_function_type_list (long_integer_type_node,
714 : type, NULL_TREE);
715 : /* long long (*) (type) */
716 31289 : func_llround = build_function_type_list (long_long_integer_type_node,
717 : type, NULL_TREE);
718 : /* type (*) (type, type) */
719 31289 : func_2 = build_function_type_list (type, type, type, NULL_TREE);
720 : /* type (*) (type, type, type) */
721 31289 : func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
722 : /* type (*) (type, &int) */
723 31289 : func_frexp
724 31289 : = build_function_type_list (type,
725 : type,
726 : build_pointer_type (integer_type_node),
727 : NULL_TREE);
728 : /* type (*) (type, int) */
729 31289 : func_scalbn = build_function_type_list (type,
730 : type, integer_type_node, NULL_TREE);
731 : /* type (*) (complex type) */
732 31289 : func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
733 : /* complex type (*) (complex type, complex type) */
734 31289 : func_cpow
735 31289 : = 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 31289 : quad_decls[BUILT_IN_SQRT]
763 31289 : = define_quad_builtin (gfc_real16_use_iec_60559
764 : ? "sqrtf128" : "sqrtq", func_1, true);
765 : }
766 :
767 : /* Add GCC builtin functions. */
768 1846051 : for (m = gfc_intrinsic_map;
769 1877340 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
770 : {
771 1846051 : if (m->float_built_in != END_BUILTINS)
772 1720895 : m->real4_decl = builtin_decl_explicit (m->float_built_in);
773 1846051 : if (m->complex_float_built_in != END_BUILTINS)
774 500624 : m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
775 1846051 : if (m->double_built_in != END_BUILTINS)
776 1720895 : m->real8_decl = builtin_decl_explicit (m->double_built_in);
777 1846051 : if (m->complex_double_built_in != END_BUILTINS)
778 500624 : m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
779 :
780 : /* If real(kind=10) exists, it is always long double. */
781 1846051 : if (m->long_double_built_in != END_BUILTINS)
782 1720895 : m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
783 1846051 : if (m->complex_long_double_built_in != END_BUILTINS)
784 500624 : m->complex10_decl
785 500624 : = builtin_decl_explicit (m->complex_long_double_built_in);
786 :
787 1846051 : 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 1846051 : 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 657069 : m->real16_decl = quad_decls[m->double_built_in];
801 : }
802 1188982 : 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 31289 : }
809 :
810 :
811 : /* Create a fndecl for a simple intrinsic library function. */
812 :
813 : static tree
814 4400 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
815 : {
816 4400 : tree type;
817 4400 : vec<tree, va_gc> *argtypes;
818 4400 : tree fndecl;
819 4400 : gfc_actual_arglist *actual;
820 4400 : tree *pdecl;
821 4400 : gfc_typespec *ts;
822 4400 : char name[GFC_MAX_SYMBOL_LEN + 3];
823 :
824 4400 : ts = &expr->ts;
825 4400 : if (ts->type == BT_REAL)
826 : {
827 3556 : switch (ts->kind)
828 : {
829 1272 : case 4:
830 1272 : pdecl = &m->real4_decl;
831 1272 : break;
832 1272 : case 8:
833 1272 : pdecl = &m->real8_decl;
834 1272 : break;
835 572 : case 10:
836 572 : pdecl = &m->real10_decl;
837 572 : break;
838 440 : case 16:
839 440 : pdecl = &m->real16_decl;
840 440 : break;
841 0 : default:
842 0 : gcc_unreachable ();
843 : }
844 : }
845 844 : else if (ts->type == BT_COMPLEX)
846 : {
847 844 : gcc_assert (m->complex_available);
848 :
849 844 : switch (ts->kind)
850 : {
851 386 : case 4:
852 386 : pdecl = &m->complex4_decl;
853 386 : break;
854 387 : case 8:
855 387 : pdecl = &m->complex8_decl;
856 387 : 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 4400 : if (*pdecl)
871 4063 : return *pdecl;
872 :
873 337 : if (m->libm_name)
874 : {
875 160 : int n = gfc_validate_kind (BT_REAL, ts->kind, false);
876 160 : 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 160 : 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 160 : 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 160 : else if (gfc_real_kinds[n].c_float128)
886 160 : snprintf (name, sizeof (name), "%s%s%s",
887 160 : ts->type == BT_COMPLEX ? "c" : "", m->name,
888 160 : 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 337 : argtypes = NULL;
900 690 : for (actual = expr->value.function.actual; actual; actual = actual->next)
901 : {
902 353 : type = gfc_typenode_for_spec (&actual->expr->ts);
903 353 : vec_safe_push (argtypes, type);
904 : }
905 1011 : type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
906 337 : fndecl = build_decl (input_location,
907 : FUNCTION_DECL, get_identifier (name), type);
908 :
909 : /* Mark the decl as external. */
910 337 : DECL_EXTERNAL (fndecl) = 1;
911 337 : TREE_PUBLIC (fndecl) = 1;
912 :
913 : /* Mark it __attribute__((const)), if possible. */
914 337 : TREE_READONLY (fndecl) = m->is_constant;
915 :
916 337 : rest_of_decl_compilation (fndecl, 1, 0);
917 :
918 337 : (*pdecl) = fndecl;
919 337 : return fndecl;
920 : }
921 :
922 :
923 : /* Convert an intrinsic function into an external or builtin call. */
924 :
925 : static void
926 3854 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
927 : {
928 3854 : gfc_intrinsic_map_t *m;
929 3854 : tree fndecl;
930 3854 : tree rettype;
931 3854 : tree *args;
932 3854 : unsigned int num_args;
933 3854 : gfc_isym_id id;
934 :
935 3854 : id = expr->value.function.isym->id;
936 : /* Find the entry for this function. */
937 79176 : for (m = gfc_intrinsic_map;
938 79176 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
939 : {
940 79176 : if (id == m->id)
941 : break;
942 : }
943 :
944 3854 : 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 3854 : num_args = gfc_intrinsic_argument_list_length (expr);
952 3854 : args = XALLOCAVEC (tree, num_args);
953 :
954 3854 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
955 3854 : fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
956 3854 : rettype = TREE_TYPE (TREE_TYPE (fndecl));
957 :
958 3854 : fndecl = build_addr (fndecl);
959 3854 : se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
960 3854 : }
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 1427 : conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
1032 : gfc_expr *hash)
1033 : {
1034 1427 : char *name;
1035 1427 : gfc_se argse;
1036 1427 : gfc_expr func_index;
1037 1427 : gfc_symtree *index_st;
1038 1427 : tree func_index_tree;
1039 1427 : stmtblock_t blk;
1040 :
1041 : /* Need to get namespace where static variables are possible. */
1042 1427 : while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
1043 0 : ns = ns->parent;
1044 1427 : gcc_assert (ns);
1045 :
1046 1427 : name = xasprintf (pat, caf_call_cnt);
1047 1427 : gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
1048 1427 : free (name);
1049 :
1050 1427 : index_st->n.sym->attr.flavor = FL_VARIABLE;
1051 1427 : index_st->n.sym->attr.save = SAVE_EXPLICIT;
1052 1427 : index_st->n.sym->value
1053 1427 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1054 : &gfc_current_locus);
1055 1427 : mpz_set_si (index_st->n.sym->value->value.integer, -1);
1056 1427 : index_st->n.sym->ts.type = BT_INTEGER;
1057 1427 : index_st->n.sym->ts.kind = gfc_default_integer_kind;
1058 1427 : gfc_set_sym_referenced (index_st->n.sym);
1059 1427 : memset (&func_index, 0, sizeof (gfc_expr));
1060 1427 : gfc_clear_ts (&func_index.ts);
1061 1427 : func_index.expr_type = EXPR_VARIABLE;
1062 1427 : func_index.symtree = index_st;
1063 1427 : func_index.ts = index_st->n.sym->ts;
1064 1427 : gfc_commit_symbol (index_st->n.sym);
1065 :
1066 1427 : gfc_init_se (&argse, NULL);
1067 1427 : gfc_conv_expr (&argse, &func_index);
1068 1427 : gfc_add_block_to_block (block, &argse.pre);
1069 1427 : func_index_tree = argse.expr;
1070 :
1071 1427 : gfc_init_se (&argse, NULL);
1072 1427 : gfc_conv_expr (&argse, hash);
1073 :
1074 1427 : gfc_init_block (&blk);
1075 1427 : gfc_add_modify (&blk, func_index_tree,
1076 : build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1,
1077 : argse.expr));
1078 1427 : 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 1427 : return func_index_tree;
1087 : }
1088 :
1089 : static tree
1090 1427 : conv_caf_add_call_data (stmtblock_t *blk, gfc_namespace *ns, const char *pat,
1091 : gfc_symbol *data_sym, tree *data_size)
1092 : {
1093 1427 : char *name;
1094 1427 : gfc_symtree *data_st;
1095 1427 : gfc_constructor *con;
1096 1427 : gfc_expr data, data_init;
1097 1427 : gfc_se argse;
1098 1427 : tree data_tree;
1099 :
1100 1427 : memset (&data, 0, sizeof (gfc_expr));
1101 1427 : gfc_clear_ts (&data.ts);
1102 1427 : data.expr_type = EXPR_VARIABLE;
1103 1427 : name = xasprintf (pat, caf_call_cnt);
1104 1427 : gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false));
1105 1427 : free (name);
1106 1427 : data_st->n.sym->attr.flavor = FL_VARIABLE;
1107 1427 : data_st->n.sym->ts = data_sym->ts;
1108 1427 : data.symtree = data_st;
1109 1427 : gfc_set_sym_referenced (data.symtree->n.sym);
1110 1427 : data.ts = data_st->n.sym->ts;
1111 1427 : gfc_commit_symbol (data_st->n.sym);
1112 :
1113 1427 : memset (&data_init, 0, sizeof (gfc_expr));
1114 1427 : gfc_clear_ts (&data_init.ts);
1115 1427 : data_init.expr_type = EXPR_STRUCTURE;
1116 1427 : data_init.ts = data.ts;
1117 1803 : for (gfc_component *comp = data.ts.u.derived->components; comp;
1118 376 : comp = comp->next)
1119 : {
1120 376 : con = gfc_constructor_get ();
1121 376 : con->expr = comp->initializer;
1122 376 : comp->initializer = NULL;
1123 376 : gfc_constructor_append (&data_init.value.constructor, con);
1124 : }
1125 :
1126 1427 : 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 1317 : data_tree = build_zero_cst (pvoid_type_node);
1141 1317 : *data_size = build_zero_cst (size_type_node);
1142 : }
1143 :
1144 1427 : 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 1260 : conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
1164 : tree *team_no)
1165 : {
1166 1260 : gfc_expr *stat_e, *team_e;
1167 :
1168 1260 : stat_e = gfc_find_stat_co (expr);
1169 1260 : 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 1227 : *stat = null_pointer_node;
1180 :
1181 1260 : team_e = gfc_find_team_co (expr, TEAM_TEAM);
1182 1260 : 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 1242 : *team = null_pointer_node;
1195 :
1196 1260 : team_e = gfc_find_team_co (expr, TEAM_NUMBER);
1197 1260 : 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 1230 : *team_no = null_pointer_node;
1211 1260 : }
1212 :
1213 : /* Get data from a remote coarray. */
1214 :
1215 : static void
1216 999 : gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
1217 : bool may_realloc, symbol_attribute *caf_attr)
1218 : {
1219 999 : gfc_expr *array_expr;
1220 999 : 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 999 : symbol_attribute caf_attr_store;
1224 999 : gfc_namespace *ns;
1225 999 : gfc_expr *get_fn_hash = expr->value.function.actual->next->expr,
1226 999 : *get_fn_expr = expr->value.function.actual->next->next->expr;
1227 999 : gfc_symbol *add_data_sym = get_fn_expr->symtree->n.sym->formal->sym;
1228 :
1229 999 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1230 :
1231 999 : 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 620 : array_expr = expr->value.function.actual->expr;
1239 620 : ns = array_expr->expr_type == EXPR_VARIABLE
1240 620 : && !array_expr->symtree->n.sym->attr.associate_var
1241 620 : ? array_expr->symtree->n.sym->ns
1242 : : gfc_current_ns;
1243 620 : type = gfc_typenode_for_spec (&array_expr->ts);
1244 :
1245 620 : if (caf_attr == NULL)
1246 : {
1247 620 : caf_attr_store = gfc_caf_attr (array_expr);
1248 620 : caf_attr = &caf_attr_store;
1249 : }
1250 :
1251 620 : res_var = lhs;
1252 :
1253 620 : conv_stat_and_team (&se->pre, expr, &stat, &team, &team_no);
1254 :
1255 620 : get_fn_index_tree
1256 620 : = conv_caf_func_index (&se->pre, ns, "__caf_get_from_remote_fn_index_%d",
1257 : get_fn_hash);
1258 620 : add_data_tree
1259 620 : = conv_caf_add_call_data (&se->pre, ns, "__caf_get_from_remote_add_data_%d",
1260 : add_data_sym, &add_data_size);
1261 620 : ++caf_call_cnt;
1262 :
1263 620 : if (array_expr->rank == 0)
1264 : {
1265 239 : res_var = gfc_create_var (type, "caf_res");
1266 239 : if (array_expr->ts.type == BT_CHARACTER)
1267 : {
1268 33 : gfc_conv_string_length (array_expr->ts.u.cl, array_expr, &se->pre);
1269 33 : se->string_length = array_expr->ts.u.cl->backend_decl;
1270 33 : opt_src_charlen = gfc_build_addr_expr (
1271 : NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1272 33 : dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1273 : }
1274 : else
1275 : {
1276 206 : dest_size = res_var->typed.type->type_common.size_unit;
1277 206 : opt_src_charlen
1278 206 : = build_zero_cst (build_pointer_type (size_type_node));
1279 : }
1280 239 : dest_data
1281 239 : = gfc_evaluate_now (gfc_build_addr_expr (NULL_TREE, res_var), &se->pre);
1282 239 : res_var = build_fold_indirect_ref (dest_data);
1283 239 : dest_data = gfc_build_addr_expr (pvoid_type_node, dest_data);
1284 239 : opt_dest_desc = build_zero_cst (pvoid_type_node);
1285 : }
1286 : else
1287 : {
1288 : /* Create temporary. */
1289 381 : may_realloc = gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
1290 : type, NULL_TREE, false, false,
1291 : false, &array_expr->where)
1292 : == NULL_TREE;
1293 381 : res_var = se->ss->info->data.array.descriptor;
1294 381 : if (array_expr->ts.type == BT_CHARACTER)
1295 : {
1296 16 : se->string_length = array_expr->ts.u.cl->backend_decl;
1297 16 : opt_src_charlen = gfc_build_addr_expr (
1298 : NULL_TREE, gfc_trans_force_lval (&se->pre, se->string_length));
1299 16 : dest_size = build_int_cstu (size_type_node, array_expr->ts.kind);
1300 : }
1301 : else
1302 : {
1303 365 : opt_src_charlen
1304 365 : = build_zero_cst (build_pointer_type (size_type_node));
1305 365 : dest_size = fold_build2 (
1306 : MULT_EXPR, size_type_node,
1307 : fold_convert (size_type_node,
1308 : array_expr->shape
1309 : ? conv_shape_to_cst (array_expr)
1310 : : gfc_conv_descriptor_size (res_var,
1311 : array_expr->rank)),
1312 : fold_convert (size_type_node,
1313 : gfc_conv_descriptor_span_get (res_var)));
1314 : }
1315 381 : opt_dest_desc = res_var;
1316 381 : dest_data = gfc_conv_descriptor_data_get (res_var);
1317 381 : opt_dest_desc = gfc_build_addr_expr (NULL_TREE, opt_dest_desc);
1318 381 : if (may_realloc)
1319 : {
1320 62 : tmp = gfc_conv_descriptor_data_get (res_var);
1321 62 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
1322 : NULL_TREE, NULL_TREE, true, NULL,
1323 : GFC_CAF_COARRAY_NOCOARRAY);
1324 62 : gfc_add_expr_to_block (&se->post, tmp);
1325 : }
1326 381 : dest_data
1327 381 : = gfc_build_addr_expr (NULL_TREE,
1328 : gfc_trans_force_lval (&se->pre, dest_data));
1329 : }
1330 :
1331 620 : opt_dest_charlen = opt_src_charlen;
1332 620 : caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1333 620 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1334 2 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1335 :
1336 620 : if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank
1337 620 : || GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)))
1338 540 : opt_src_desc = build_zero_cst (pvoid_type_node);
1339 : else
1340 80 : opt_src_desc = gfc_build_addr_expr (pvoid_type_node, caf_decl);
1341 :
1342 620 : image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1343 620 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, array_expr);
1344 :
1345 : /* It guarantees memory consistency within the same segment. */
1346 620 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1347 620 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1348 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1349 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1350 620 : ASM_VOLATILE_P (tmp) = 1;
1351 620 : gfc_add_expr_to_block (&se->pre, tmp);
1352 :
1353 620 : tmp = build_call_expr_loc (
1354 : input_location, gfor_fndecl_caf_get_from_remote, 15, token, opt_src_desc,
1355 : opt_src_charlen, image_index, dest_size, dest_data, opt_dest_charlen,
1356 : opt_dest_desc, constant_boolean_node (may_realloc, boolean_type_node),
1357 : get_fn_index_tree, add_data_tree, add_data_size, stat, team, team_no);
1358 :
1359 620 : gfc_add_expr_to_block (&se->pre, tmp);
1360 :
1361 620 : if (se->ss)
1362 381 : gfc_advance_se_ss_chain (se);
1363 :
1364 620 : se->expr = res_var;
1365 :
1366 620 : return;
1367 : }
1368 :
1369 : /* Generate call to caf_is_present_on_remote for allocated (coarrary[...])
1370 : calls. */
1371 :
1372 : static void
1373 167 : gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
1374 : {
1375 167 : gfc_expr *caf_expr, *hash, *present_fn;
1376 167 : gfc_symbol *add_data_sym;
1377 167 : tree fn_index, add_data_tree, add_data_size, caf_decl, image_index, token;
1378 :
1379 167 : gcc_assert (e->expr_type == EXPR_FUNCTION
1380 : && e->value.function.isym->id
1381 : == GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE);
1382 167 : caf_expr = e->value.function.actual->expr;
1383 167 : hash = e->value.function.actual->next->expr;
1384 167 : present_fn = e->value.function.actual->next->next->expr;
1385 167 : add_data_sym = present_fn->symtree->n.sym->formal->sym;
1386 :
1387 167 : fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns,
1388 : "__caf_present_on_remote_fn_index_%d", hash);
1389 167 : add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns,
1390 : "__caf_present_on_remote_add_data_%d",
1391 : add_data_sym, &add_data_size);
1392 167 : ++caf_call_cnt;
1393 :
1394 167 : caf_decl = gfc_get_tree_for_caf_expr (caf_expr);
1395 167 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1396 4 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1397 :
1398 167 : image_index = gfc_caf_get_image_index (&se->pre, caf_expr, caf_decl);
1399 167 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, caf_expr);
1400 :
1401 167 : se->expr
1402 167 : = fold_convert (logical_type_node,
1403 : build_call_expr_loc (input_location,
1404 : gfor_fndecl_caf_is_present_on_remote,
1405 : 5, token, image_index, fn_index,
1406 : add_data_tree, add_data_size));
1407 167 : }
1408 :
1409 : static tree
1410 360 : conv_caf_send_to_remote (gfc_code *code)
1411 : {
1412 360 : gfc_expr *lhs_expr, *rhs_expr, *lhs_hash, *receiver_fn_expr;
1413 360 : gfc_symbol *add_data_sym;
1414 360 : gfc_se lhs_se, rhs_se;
1415 360 : stmtblock_t block;
1416 360 : gfc_namespace *ns;
1417 360 : tree caf_decl, token, rhs_size, image_index, tmp, rhs_data;
1418 360 : tree lhs_stat, lhs_team, lhs_team_no, opt_lhs_charlen, opt_rhs_charlen;
1419 360 : tree opt_lhs_desc = NULL_TREE, opt_rhs_desc = NULL_TREE;
1420 360 : tree receiver_fn_index_tree, add_data_tree, add_data_size;
1421 :
1422 360 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1423 360 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SEND);
1424 :
1425 360 : lhs_expr = code->ext.actual->expr;
1426 360 : rhs_expr = code->ext.actual->next->expr;
1427 360 : lhs_hash = code->ext.actual->next->next->expr;
1428 360 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1429 360 : add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1430 :
1431 360 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1432 360 : && !lhs_expr->symtree->n.sym->attr.associate_var
1433 360 : ? lhs_expr->symtree->n.sym->ns
1434 : : gfc_current_ns;
1435 :
1436 360 : gfc_init_block (&block);
1437 :
1438 : /* LHS. */
1439 360 : gfc_init_se (&lhs_se, NULL);
1440 360 : caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1441 360 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1442 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1443 360 : if (lhs_expr->rank == 0)
1444 : {
1445 266 : if (lhs_expr->ts.type == BT_CHARACTER)
1446 : {
1447 24 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1448 24 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1449 24 : opt_lhs_charlen = gfc_build_addr_expr (
1450 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1451 : }
1452 : else
1453 242 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1454 266 : opt_lhs_desc = null_pointer_node;
1455 : }
1456 : else
1457 : {
1458 94 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1459 94 : gfc_add_block_to_block (&block, &lhs_se.pre);
1460 94 : opt_lhs_desc = lhs_se.expr;
1461 94 : if (lhs_expr->ts.type == BT_CHARACTER)
1462 44 : opt_lhs_charlen = gfc_build_addr_expr (
1463 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1464 : else
1465 50 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1466 : /* Get the third formal argument of the receiver function. (This is the
1467 : location where to put the data on the remote image.) Need to look at
1468 : the argument in the function decl, because in the gfc_symbol's formal
1469 : argument an array may have no descriptor while in the generated
1470 : function decl it has. */
1471 94 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1472 : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1473 94 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1474 56 : opt_lhs_desc = null_pointer_node;
1475 : else
1476 38 : opt_lhs_desc
1477 38 : = gfc_build_addr_expr (NULL_TREE,
1478 : gfc_trans_force_lval (&block, opt_lhs_desc));
1479 : }
1480 :
1481 : /* Obtain token, offset and image index for the LHS. */
1482 360 : image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
1483 360 : gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL, lhs_expr);
1484 :
1485 : /* RHS. */
1486 360 : gfc_init_se (&rhs_se, NULL);
1487 360 : if (rhs_expr->rank == 0)
1488 : {
1489 436 : rhs_se.want_pointer = rhs_expr->ts.type == BT_CHARACTER
1490 218 : && rhs_expr->expr_type != EXPR_CONSTANT;
1491 218 : gfc_conv_expr (&rhs_se, rhs_expr);
1492 218 : gfc_add_block_to_block (&block, &rhs_se.pre);
1493 218 : opt_rhs_desc = null_pointer_node;
1494 218 : if (rhs_expr->ts.type == BT_CHARACTER)
1495 : {
1496 40 : rhs_data
1497 40 : = rhs_expr->expr_type == EXPR_CONSTANT
1498 40 : ? gfc_build_addr_expr (NULL_TREE,
1499 : gfc_trans_force_lval (&block,
1500 : rhs_se.expr))
1501 : : rhs_se.expr;
1502 40 : opt_rhs_charlen = gfc_build_addr_expr (
1503 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1504 40 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1505 : }
1506 : else
1507 : {
1508 178 : rhs_data
1509 178 : = gfc_build_addr_expr (NULL_TREE,
1510 : gfc_trans_force_lval (&block, rhs_se.expr));
1511 178 : opt_rhs_charlen
1512 178 : = build_zero_cst (build_pointer_type (size_type_node));
1513 178 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1514 : }
1515 : }
1516 : else
1517 : {
1518 284 : rhs_se.force_tmp = rhs_expr->shape == NULL
1519 142 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1520 142 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1521 142 : gfc_add_block_to_block (&block, &rhs_se.pre);
1522 142 : opt_rhs_desc = rhs_se.expr;
1523 142 : if (rhs_expr->ts.type == BT_CHARACTER)
1524 : {
1525 28 : opt_rhs_charlen = gfc_build_addr_expr (
1526 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1527 28 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1528 : }
1529 : else
1530 : {
1531 114 : opt_rhs_charlen
1532 114 : = build_zero_cst (build_pointer_type (size_type_node));
1533 114 : rhs_size = fold_build2 (
1534 : MULT_EXPR, size_type_node,
1535 : fold_convert (size_type_node,
1536 : rhs_expr->shape
1537 : ? conv_shape_to_cst (rhs_expr)
1538 : : gfc_conv_descriptor_size (rhs_se.expr,
1539 : rhs_expr->rank)),
1540 : fold_convert (size_type_node,
1541 : gfc_conv_descriptor_span_get (rhs_se.expr)));
1542 : }
1543 :
1544 142 : rhs_data = gfc_build_addr_expr (
1545 : NULL_TREE, gfc_trans_force_lval (&block, gfc_conv_descriptor_data_get (
1546 : opt_rhs_desc)));
1547 142 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1548 : }
1549 360 : gfc_add_block_to_block (&block, &rhs_se.pre);
1550 :
1551 360 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1552 :
1553 360 : receiver_fn_index_tree
1554 360 : = conv_caf_func_index (&block, ns, "__caf_send_to_remote_fn_index_%d",
1555 : lhs_hash);
1556 360 : add_data_tree
1557 360 : = conv_caf_add_call_data (&block, ns, "__caf_send_to_remote_add_data_%d",
1558 : add_data_sym, &add_data_size);
1559 360 : ++caf_call_cnt;
1560 :
1561 360 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_to_remote, 14,
1562 : token, opt_lhs_desc, opt_lhs_charlen, image_index,
1563 : rhs_size, rhs_data, opt_rhs_charlen, opt_rhs_desc,
1564 : receiver_fn_index_tree, add_data_tree,
1565 : add_data_size, lhs_stat, lhs_team, lhs_team_no);
1566 :
1567 360 : gfc_add_expr_to_block (&block, tmp);
1568 360 : gfc_add_block_to_block (&block, &lhs_se.post);
1569 360 : gfc_add_block_to_block (&block, &rhs_se.post);
1570 :
1571 : /* It guarantees memory consistency within the same segment. */
1572 360 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1573 360 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1574 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1575 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1576 360 : ASM_VOLATILE_P (tmp) = 1;
1577 360 : gfc_add_expr_to_block (&block, tmp);
1578 :
1579 360 : return gfc_finish_block (&block);
1580 : }
1581 :
1582 : /* Send-get data to a remote coarray. */
1583 :
1584 : static tree
1585 140 : conv_caf_sendget (gfc_code *code)
1586 : {
1587 : /* lhs stuff */
1588 140 : gfc_expr *lhs_expr, *lhs_hash, *receiver_fn_expr;
1589 140 : gfc_symbol *lhs_add_data_sym;
1590 140 : gfc_se lhs_se;
1591 140 : tree lhs_caf_decl, lhs_token, opt_lhs_charlen,
1592 140 : opt_lhs_desc = NULL_TREE, receiver_fn_index_tree, lhs_image_index,
1593 : lhs_add_data_tree, lhs_add_data_size, lhs_stat, lhs_team, lhs_team_no;
1594 140 : int transfer_rank;
1595 :
1596 : /* rhs stuff */
1597 140 : gfc_expr *rhs_expr, *rhs_hash, *sender_fn_expr;
1598 140 : gfc_symbol *rhs_add_data_sym;
1599 140 : gfc_se rhs_se;
1600 140 : tree rhs_caf_decl, rhs_token, opt_rhs_charlen,
1601 140 : opt_rhs_desc = NULL_TREE, sender_fn_index_tree, rhs_image_index,
1602 : rhs_add_data_tree, rhs_add_data_size, rhs_stat, rhs_team, rhs_team_no;
1603 :
1604 : /* shared */
1605 140 : stmtblock_t block;
1606 140 : gfc_namespace *ns;
1607 140 : tree tmp, rhs_size;
1608 :
1609 140 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1610 140 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SENDGET);
1611 :
1612 140 : lhs_expr = code->ext.actual->expr;
1613 140 : rhs_expr = code->ext.actual->next->expr;
1614 140 : lhs_hash = code->ext.actual->next->next->expr;
1615 140 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1616 140 : rhs_hash = code->ext.actual->next->next->next->next->expr;
1617 140 : sender_fn_expr = code->ext.actual->next->next->next->next->next->expr;
1618 :
1619 140 : lhs_add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1620 140 : rhs_add_data_sym = sender_fn_expr->symtree->n.sym->formal->sym;
1621 :
1622 140 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1623 140 : && !lhs_expr->symtree->n.sym->attr.associate_var
1624 140 : ? lhs_expr->symtree->n.sym->ns
1625 : : gfc_current_ns;
1626 :
1627 140 : gfc_init_block (&block);
1628 :
1629 140 : lhs_stat = null_pointer_node;
1630 140 : lhs_team = null_pointer_node;
1631 140 : rhs_stat = null_pointer_node;
1632 140 : rhs_team = null_pointer_node;
1633 :
1634 : /* LHS. */
1635 140 : gfc_init_se (&lhs_se, NULL);
1636 140 : lhs_caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1637 140 : if (TREE_CODE (TREE_TYPE (lhs_caf_decl)) == REFERENCE_TYPE)
1638 0 : lhs_caf_decl = build_fold_indirect_ref_loc (input_location, lhs_caf_decl);
1639 140 : if (lhs_expr->rank == 0)
1640 : {
1641 78 : if (lhs_expr->ts.type == BT_CHARACTER)
1642 : {
1643 16 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1644 16 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1645 16 : opt_lhs_charlen = gfc_build_addr_expr (
1646 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1647 : }
1648 : else
1649 62 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1650 78 : opt_lhs_desc = null_pointer_node;
1651 : }
1652 : else
1653 : {
1654 62 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1655 62 : gfc_add_block_to_block (&block, &lhs_se.pre);
1656 62 : opt_lhs_desc = lhs_se.expr;
1657 62 : if (lhs_expr->ts.type == BT_CHARACTER)
1658 32 : opt_lhs_charlen = gfc_build_addr_expr (
1659 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1660 : else
1661 30 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1662 : /* Get the third formal argument of the receiver function. (This is the
1663 : location where to put the data on the remote image.) Need to look at
1664 : the argument in the function decl, because in the gfc_symbol's formal
1665 : argument an array may have no descriptor while in the generated
1666 : function decl it has. */
1667 62 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1668 : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1669 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1670 54 : opt_lhs_desc = null_pointer_node;
1671 : else
1672 8 : opt_lhs_desc
1673 8 : = gfc_build_addr_expr (NULL_TREE,
1674 : gfc_trans_force_lval (&block, opt_lhs_desc));
1675 : }
1676 :
1677 : /* Obtain token, offset and image index for the LHS. */
1678 140 : lhs_image_index = gfc_caf_get_image_index (&block, lhs_expr, lhs_caf_decl);
1679 140 : gfc_get_caf_token_offset (&lhs_se, &lhs_token, NULL, lhs_caf_decl, NULL,
1680 : lhs_expr);
1681 :
1682 : /* RHS. */
1683 140 : rhs_caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
1684 140 : if (TREE_CODE (TREE_TYPE (rhs_caf_decl)) == REFERENCE_TYPE)
1685 0 : rhs_caf_decl = build_fold_indirect_ref_loc (input_location, rhs_caf_decl);
1686 140 : transfer_rank = rhs_expr->rank;
1687 140 : gfc_expression_rank (rhs_expr);
1688 140 : gfc_init_se (&rhs_se, NULL);
1689 140 : if (rhs_expr->rank == 0)
1690 : {
1691 80 : opt_rhs_desc = null_pointer_node;
1692 80 : if (rhs_expr->ts.type == BT_CHARACTER)
1693 : {
1694 32 : gfc_conv_expr (&rhs_se, rhs_expr);
1695 32 : gfc_add_block_to_block (&block, &rhs_se.pre);
1696 32 : opt_rhs_charlen = gfc_build_addr_expr (
1697 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1698 32 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1699 : }
1700 : else
1701 : {
1702 48 : gfc_typespec *ts
1703 48 : = &sender_fn_expr->symtree->n.sym->formal->next->next->sym->ts;
1704 :
1705 48 : opt_rhs_charlen
1706 48 : = build_zero_cst (build_pointer_type (size_type_node));
1707 48 : rhs_size = gfc_typenode_for_spec (ts)->type_common.size_unit;
1708 : }
1709 : }
1710 : /* Get the fifth formal argument of the getter function. This is the argument
1711 : pointing to the data to get on the remote image. Need to look at the
1712 : argument in the function decl, because in the gfc_symbol's formal argument
1713 : an array may have no descriptor while in the generated function decl it
1714 : has. */
1715 60 : else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_VALUE (
1716 : TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1717 : TREE_TYPE (sender_fn_expr->symtree->n.sym->backend_decl))))))))))
1718 : {
1719 52 : rhs_se.data_not_needed = 1;
1720 52 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1721 52 : gfc_add_block_to_block (&block, &rhs_se.pre);
1722 52 : if (rhs_expr->ts.type == BT_CHARACTER)
1723 : {
1724 16 : opt_rhs_charlen = gfc_build_addr_expr (
1725 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1726 16 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1727 : }
1728 : else
1729 : {
1730 36 : opt_rhs_charlen
1731 36 : = build_zero_cst (build_pointer_type (size_type_node));
1732 36 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1733 : }
1734 52 : opt_rhs_desc = null_pointer_node;
1735 : }
1736 : else
1737 : {
1738 8 : gfc_ref *arr_ref = rhs_expr->ref;
1739 8 : while (arr_ref && arr_ref->type != REF_ARRAY)
1740 0 : arr_ref = arr_ref->next;
1741 8 : rhs_se.force_tmp
1742 16 : = (rhs_expr->shape == NULL
1743 8 : && (!arr_ref || !gfc_full_array_ref_p (arr_ref, nullptr)))
1744 16 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1745 8 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1746 8 : gfc_add_block_to_block (&block, &rhs_se.pre);
1747 8 : opt_rhs_desc = rhs_se.expr;
1748 8 : if (rhs_expr->ts.type == BT_CHARACTER)
1749 : {
1750 0 : opt_rhs_charlen = gfc_build_addr_expr (
1751 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1752 0 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1753 : }
1754 : else
1755 : {
1756 8 : opt_rhs_charlen
1757 8 : = build_zero_cst (build_pointer_type (size_type_node));
1758 8 : rhs_size = fold_build2 (
1759 : MULT_EXPR, size_type_node,
1760 : fold_convert (size_type_node,
1761 : rhs_expr->shape
1762 : ? conv_shape_to_cst (rhs_expr)
1763 : : gfc_conv_descriptor_size (rhs_se.expr,
1764 : rhs_expr->rank)),
1765 : fold_convert (size_type_node,
1766 : gfc_conv_descriptor_span_get (rhs_se.expr)));
1767 : }
1768 :
1769 8 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1770 : }
1771 140 : gfc_add_block_to_block (&block, &rhs_se.pre);
1772 :
1773 : /* Obtain token, offset and image index for the RHS. */
1774 140 : rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, rhs_caf_decl);
1775 140 : gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, rhs_caf_decl, NULL,
1776 : rhs_expr);
1777 :
1778 : /* stat and team. */
1779 140 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1780 140 : conv_stat_and_team (&block, rhs_expr, &rhs_stat, &rhs_team, &rhs_team_no);
1781 :
1782 140 : sender_fn_index_tree
1783 140 : = conv_caf_func_index (&block, ns, "__caf_transfer_from_fn_index_%d",
1784 : rhs_hash);
1785 140 : rhs_add_data_tree
1786 140 : = conv_caf_add_call_data (&block, ns,
1787 : "__caf_transfer_from_remote_add_data_%d",
1788 : rhs_add_data_sym, &rhs_add_data_size);
1789 140 : receiver_fn_index_tree
1790 140 : = conv_caf_func_index (&block, ns, "__caf_transfer_to_remote_fn_index_%d",
1791 : lhs_hash);
1792 140 : lhs_add_data_tree
1793 140 : = conv_caf_add_call_data (&block, ns,
1794 : "__caf_transfer_to_remote_add_data_%d",
1795 : lhs_add_data_sym, &lhs_add_data_size);
1796 140 : ++caf_call_cnt;
1797 :
1798 140 : tmp = build_call_expr_loc (
1799 : input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token,
1800 : opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree,
1801 : lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc,
1802 : opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree,
1803 : rhs_add_data_size, rhs_size,
1804 : transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat,
1805 : rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no);
1806 :
1807 140 : gfc_add_expr_to_block (&block, tmp);
1808 140 : gfc_add_block_to_block (&block, &lhs_se.post);
1809 140 : gfc_add_block_to_block (&block, &rhs_se.post);
1810 :
1811 : /* It guarantees memory consistency within the same segment. */
1812 140 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1813 140 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1814 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1815 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1816 140 : ASM_VOLATILE_P (tmp) = 1;
1817 140 : gfc_add_expr_to_block (&block, tmp);
1818 :
1819 140 : return gfc_finish_block (&block);
1820 : }
1821 :
1822 :
1823 : static void
1824 1291 : trans_this_image (gfc_se * se, gfc_expr *expr)
1825 : {
1826 1291 : stmtblock_t loop;
1827 1291 : tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound,
1828 : ubound, extent, ml, team;
1829 1291 : gfc_se argse;
1830 1291 : int rank, corank;
1831 :
1832 : /* The case -fcoarray=single is handled elsewhere. */
1833 1291 : gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
1834 :
1835 : /* Translate team, if present. */
1836 1291 : if (expr->value.function.actual->next->next->expr)
1837 : {
1838 18 : gfc_init_se (&argse, NULL);
1839 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr);
1840 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
1841 18 : gfc_add_block_to_block (&se->post, &argse.post);
1842 18 : team = fold_convert (pvoid_type_node, argse.expr);
1843 : }
1844 : else
1845 1273 : team = null_pointer_node;
1846 :
1847 : /* Argument-free version: THIS_IMAGE(). */
1848 1291 : if (expr->value.function.actual->expr == NULL)
1849 : {
1850 973 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1851 : team);
1852 973 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1853 : tmp);
1854 981 : return;
1855 : }
1856 :
1857 : /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1858 :
1859 318 : type = gfc_get_int_type (gfc_default_integer_kind);
1860 318 : corank = expr->value.function.actual->expr->corank;
1861 318 : rank = expr->value.function.actual->expr->rank;
1862 :
1863 : /* Obtain the descriptor of the COARRAY. */
1864 318 : gfc_init_se (&argse, NULL);
1865 318 : argse.want_coarray = 1;
1866 318 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
1867 318 : gfc_add_block_to_block (&se->pre, &argse.pre);
1868 318 : gfc_add_block_to_block (&se->post, &argse.post);
1869 318 : desc = argse.expr;
1870 :
1871 318 : if (se->ss)
1872 : {
1873 : /* Create an implicit second parameter from the loop variable. */
1874 70 : gcc_assert (!expr->value.function.actual->next->expr);
1875 70 : gcc_assert (corank > 0);
1876 70 : gcc_assert (se->loop->dimen == 1);
1877 70 : gcc_assert (se->ss->info->expr == expr);
1878 :
1879 70 : dim_arg = se->loop->loopvar[0];
1880 70 : dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1881 : gfc_array_index_type, dim_arg,
1882 70 : build_int_cst (TREE_TYPE (dim_arg), 1));
1883 70 : gfc_advance_se_ss_chain (se);
1884 : }
1885 : else
1886 : {
1887 : /* Use the passed DIM= argument. */
1888 248 : gcc_assert (expr->value.function.actual->next->expr);
1889 248 : gfc_init_se (&argse, NULL);
1890 248 : gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1891 : gfc_array_index_type);
1892 248 : gfc_add_block_to_block (&se->pre, &argse.pre);
1893 248 : dim_arg = argse.expr;
1894 :
1895 248 : if (INTEGER_CST_P (dim_arg))
1896 : {
1897 132 : if (wi::ltu_p (wi::to_wide (dim_arg), 1)
1898 264 : || wi::gtu_p (wi::to_wide (dim_arg),
1899 132 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
1900 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1901 0 : "dimension index", expr->value.function.isym->name,
1902 : &expr->where);
1903 : }
1904 116 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1905 : {
1906 0 : dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1907 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1908 : dim_arg,
1909 0 : build_int_cst (TREE_TYPE (dim_arg), 1));
1910 0 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1911 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1912 : dim_arg, tmp);
1913 0 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1914 : logical_type_node, cond, tmp);
1915 0 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1916 : gfc_msg_fault);
1917 : }
1918 : }
1919 :
1920 : /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1921 : one always has a dim_arg argument.
1922 :
1923 : m = this_image() - 1
1924 : if (corank == 1)
1925 : {
1926 : sub(1) = m + lcobound(corank)
1927 : return;
1928 : }
1929 : i = rank
1930 : min_var = min (rank + corank - 2, rank + dim_arg - 1)
1931 : for (;;)
1932 : {
1933 : extent = gfc_extent(i)
1934 : ml = m
1935 : m = m/extent
1936 : if (i >= min_var)
1937 : goto exit_label
1938 : i++
1939 : }
1940 : exit_label:
1941 : sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1942 : : m + lcobound(corank)
1943 : */
1944 :
1945 : /* this_image () - 1. */
1946 318 : tmp
1947 318 : = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team);
1948 318 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
1949 : fold_convert (type, tmp), build_int_cst (type, 1));
1950 318 : if (corank == 1)
1951 : {
1952 : /* sub(1) = m + lcobound(corank). */
1953 8 : lbound = gfc_conv_descriptor_lbound_get (desc,
1954 8 : build_int_cst (TREE_TYPE (gfc_array_index_type),
1955 8 : corank+rank-1));
1956 8 : lbound = fold_convert (type, lbound);
1957 8 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1958 :
1959 8 : se->expr = tmp;
1960 8 : return;
1961 : }
1962 :
1963 310 : m = gfc_create_var (type, NULL);
1964 310 : ml = gfc_create_var (type, NULL);
1965 310 : loop_var = gfc_create_var (integer_type_node, NULL);
1966 310 : min_var = gfc_create_var (integer_type_node, NULL);
1967 :
1968 : /* m = this_image () - 1. */
1969 310 : gfc_add_modify (&se->pre, m, tmp);
1970 :
1971 : /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1972 310 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1973 : fold_convert (integer_type_node, dim_arg),
1974 310 : build_int_cst (integer_type_node, rank - 1));
1975 310 : tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1976 310 : build_int_cst (integer_type_node, rank + corank - 2),
1977 : tmp);
1978 310 : gfc_add_modify (&se->pre, min_var, tmp);
1979 :
1980 : /* i = rank. */
1981 310 : tmp = build_int_cst (integer_type_node, rank);
1982 310 : gfc_add_modify (&se->pre, loop_var, tmp);
1983 :
1984 310 : exit_label = gfc_build_label_decl (NULL_TREE);
1985 310 : TREE_USED (exit_label) = 1;
1986 :
1987 : /* Loop body. */
1988 310 : gfc_init_block (&loop);
1989 :
1990 : /* ml = m. */
1991 310 : gfc_add_modify (&loop, ml, m);
1992 :
1993 : /* extent = ... */
1994 310 : lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1995 310 : ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1996 310 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1997 310 : extent = fold_convert (type, extent);
1998 :
1999 : /* m = m/extent. */
2000 310 : gfc_add_modify (&loop, m,
2001 : fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2002 : m, extent));
2003 :
2004 : /* Exit condition: if (i >= min_var) goto exit_label. */
2005 310 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2006 : min_var);
2007 310 : tmp = build1_v (GOTO_EXPR, exit_label);
2008 310 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2009 : build_empty_stmt (input_location));
2010 310 : gfc_add_expr_to_block (&loop, tmp);
2011 :
2012 : /* Increment loop variable: i++. */
2013 310 : gfc_add_modify (&loop, loop_var,
2014 : fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2015 : loop_var,
2016 : integer_one_node));
2017 :
2018 : /* Making the loop... actually loop! */
2019 310 : tmp = gfc_finish_block (&loop);
2020 310 : tmp = build1_v (LOOP_EXPR, tmp);
2021 310 : gfc_add_expr_to_block (&se->pre, tmp);
2022 :
2023 : /* The exit label. */
2024 310 : tmp = build1_v (LABEL_EXPR, exit_label);
2025 310 : gfc_add_expr_to_block (&se->pre, tmp);
2026 :
2027 : /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2028 : : m + lcobound(corank) */
2029 :
2030 310 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2031 310 : build_int_cst (TREE_TYPE (dim_arg), corank));
2032 :
2033 310 : lbound = gfc_conv_descriptor_lbound_get (desc,
2034 : fold_build2_loc (input_location, PLUS_EXPR,
2035 : gfc_array_index_type, dim_arg,
2036 310 : build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2037 310 : lbound = fold_convert (type, lbound);
2038 :
2039 310 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2040 : fold_build2_loc (input_location, MULT_EXPR, type,
2041 : m, extent));
2042 310 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2043 :
2044 310 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2045 : fold_build2_loc (input_location, PLUS_EXPR, type,
2046 : m, lbound));
2047 : }
2048 :
2049 :
2050 : /* Convert a call to image_status. */
2051 :
2052 : static void
2053 25 : conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2054 : {
2055 25 : unsigned int num_args;
2056 25 : tree *args, tmp;
2057 :
2058 25 : num_args = gfc_intrinsic_argument_list_length (expr);
2059 25 : args = XALLOCAVEC (tree, num_args);
2060 25 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2061 : /* In args[0] the number of the image the status is desired for has to be
2062 : given. */
2063 :
2064 25 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2065 : {
2066 0 : tree arg;
2067 0 : arg = gfc_evaluate_now (args[0], &se->pre);
2068 0 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2069 : fold_convert (integer_type_node, arg),
2070 : integer_one_node);
2071 0 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2072 : tmp, integer_zero_node,
2073 : build_int_cst (integer_type_node,
2074 : GFC_STAT_STOPPED_IMAGE));
2075 : }
2076 25 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2077 : /* The team is optional and therefore needs to be a pointer to the opaque
2078 : pointer. */
2079 29 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2080 : args[0],
2081 : num_args < 2
2082 : ? null_pointer_node
2083 4 : : gfc_build_addr_expr (NULL_TREE, args[1]));
2084 : else
2085 0 : gcc_unreachable ();
2086 :
2087 25 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2088 25 : }
2089 :
2090 : static void
2091 21 : conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2092 : {
2093 21 : unsigned int num_args;
2094 :
2095 21 : tree *args, tmp;
2096 :
2097 21 : num_args = gfc_intrinsic_argument_list_length (expr);
2098 21 : args = XALLOCAVEC (tree, num_args);
2099 21 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2100 :
2101 21 : if (flag_coarray ==
2102 18 : GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2103 0 : tmp = gfc_evaluate_now (args[0], &se->pre);
2104 21 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2105 : {
2106 : // the value -1 represents that no team has been created yet
2107 18 : tmp = build_int_cst (integer_type_node, -1);
2108 : }
2109 3 : else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2110 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2111 : args[0]);
2112 3 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2113 3 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2114 : null_pointer_node);
2115 : else
2116 0 : gcc_unreachable ();
2117 :
2118 21 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2119 21 : }
2120 :
2121 :
2122 : static void
2123 193 : trans_image_index (gfc_se * se, gfc_expr *expr)
2124 : {
2125 193 : tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp,
2126 193 : invalid_bound, team = null_pointer_node, team_number = null_pointer_node;
2127 193 : gfc_se argse, subse;
2128 193 : int rank, corank, codim;
2129 :
2130 193 : type = gfc_get_int_type (gfc_default_integer_kind);
2131 193 : corank = expr->value.function.actual->expr->corank;
2132 193 : rank = expr->value.function.actual->expr->rank;
2133 :
2134 : /* Obtain the descriptor of the COARRAY. */
2135 193 : gfc_init_se (&argse, NULL);
2136 193 : argse.want_coarray = 1;
2137 193 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2138 193 : gfc_add_block_to_block (&se->pre, &argse.pre);
2139 193 : gfc_add_block_to_block (&se->post, &argse.post);
2140 193 : desc = argse.expr;
2141 :
2142 : /* Obtain a handle to the SUB argument. */
2143 193 : gfc_init_se (&subse, NULL);
2144 193 : gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2145 193 : gfc_add_block_to_block (&se->pre, &subse.pre);
2146 193 : gfc_add_block_to_block (&se->post, &subse.post);
2147 193 : subdesc = build_fold_indirect_ref_loc (input_location,
2148 : gfc_conv_descriptor_data_get (subse.expr));
2149 :
2150 193 : if (expr->value.function.actual->next->next->expr)
2151 : {
2152 0 : gfc_init_se (&argse, NULL);
2153 0 : gfc_conv_expr_descriptor (&argse,
2154 0 : expr->value.function.actual->next->next->expr);
2155 0 : if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED)
2156 0 : team = argse.expr;
2157 : else
2158 0 : team_number = gfc_build_addr_expr (
2159 : NULL_TREE,
2160 : gfc_trans_force_lval (&argse.pre,
2161 : fold_convert (integer_type_node, argse.expr)));
2162 0 : gfc_add_block_to_block (&se->pre, &argse.pre);
2163 0 : gfc_add_block_to_block (&se->post, &argse.post);
2164 : }
2165 :
2166 : /* Fortran 2008 does not require that the values remain in the cobounds,
2167 : thus we need explicitly check this - and return 0 if they are exceeded. */
2168 :
2169 193 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2170 193 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2171 193 : invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2172 : fold_convert (gfc_array_index_type, tmp),
2173 : lbound);
2174 :
2175 443 : for (codim = corank + rank - 2; codim >= rank; codim--)
2176 : {
2177 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2178 250 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2179 250 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2180 250 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2181 : fold_convert (gfc_array_index_type, tmp),
2182 : lbound);
2183 250 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2184 : logical_type_node, invalid_bound, cond);
2185 250 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2186 : fold_convert (gfc_array_index_type, tmp),
2187 : ubound);
2188 250 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2189 : logical_type_node, invalid_bound, cond);
2190 : }
2191 :
2192 193 : invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2193 :
2194 : /* See Fortran 2008, C.10 for the following algorithm. */
2195 :
2196 : /* coindex = sub(corank) - lcobound(n). */
2197 193 : coindex = fold_convert (gfc_array_index_type,
2198 : gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2199 : NULL));
2200 193 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2201 193 : coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2202 : fold_convert (gfc_array_index_type, coindex),
2203 : lbound);
2204 :
2205 443 : for (codim = corank + rank - 2; codim >= rank; codim--)
2206 : {
2207 250 : tree extent, ubound;
2208 :
2209 : /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2210 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2211 250 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2212 250 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2213 :
2214 : /* coindex *= extent. */
2215 250 : coindex = fold_build2_loc (input_location, MULT_EXPR,
2216 : gfc_array_index_type, coindex, extent);
2217 :
2218 : /* coindex += sub(codim). */
2219 250 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2220 250 : coindex = fold_build2_loc (input_location, PLUS_EXPR,
2221 : gfc_array_index_type, coindex,
2222 : fold_convert (gfc_array_index_type, tmp));
2223 :
2224 : /* coindex -= lbound(codim). */
2225 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2226 250 : coindex = fold_build2_loc (input_location, MINUS_EXPR,
2227 : gfc_array_index_type, coindex, lbound);
2228 : }
2229 :
2230 193 : coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2231 : fold_convert(type, coindex),
2232 : build_int_cst (type, 1));
2233 :
2234 : /* Return 0 if "coindex" exceeds num_images(). */
2235 :
2236 193 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2237 108 : num_images = build_int_cst (type, 1);
2238 : else
2239 : {
2240 85 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2241 : team, team_number);
2242 85 : num_images = fold_convert (type, tmp);
2243 : }
2244 :
2245 193 : tmp = gfc_create_var (type, NULL);
2246 193 : gfc_add_modify (&se->pre, tmp, coindex);
2247 :
2248 193 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2249 : num_images);
2250 193 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2251 : cond,
2252 : fold_convert (logical_type_node, invalid_bound));
2253 193 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2254 : build_int_cst (type, 0), tmp);
2255 193 : }
2256 :
2257 : static void
2258 806 : trans_num_images (gfc_se * se, gfc_expr *expr)
2259 : {
2260 806 : tree tmp, team = null_pointer_node, team_number = null_pointer_node;
2261 806 : gfc_se argse;
2262 :
2263 806 : if (expr->value.function.actual->expr)
2264 : {
2265 18 : gfc_init_se (&argse, NULL);
2266 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2267 18 : if (expr->value.function.actual->expr->ts.type == BT_DERIVED)
2268 6 : team = argse.expr;
2269 : else
2270 12 : team_number = gfc_build_addr_expr (
2271 : NULL_TREE,
2272 : gfc_trans_force_lval (&se->pre,
2273 : fold_convert (integer_type_node, argse.expr)));
2274 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
2275 18 : gfc_add_block_to_block (&se->post, &argse.post);
2276 : }
2277 :
2278 806 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2279 : team, team_number);
2280 806 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2281 806 : }
2282 :
2283 :
2284 : static void
2285 12136 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2286 : {
2287 12136 : gfc_se argse;
2288 :
2289 12136 : gfc_init_se (&argse, NULL);
2290 12136 : argse.data_not_needed = 1;
2291 12136 : argse.descriptor_only = 1;
2292 :
2293 12136 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2294 12136 : gfc_add_block_to_block (&se->pre, &argse.pre);
2295 12136 : gfc_add_block_to_block (&se->post, &argse.post);
2296 :
2297 12136 : se->expr = gfc_conv_descriptor_rank (argse.expr);
2298 12136 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2299 : se->expr);
2300 12136 : }
2301 :
2302 :
2303 : static void
2304 735 : gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2305 : {
2306 735 : gfc_expr *arg;
2307 735 : arg = expr->value.function.actual->expr;
2308 735 : gfc_conv_is_contiguous_expr (se, arg);
2309 735 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2310 735 : }
2311 :
2312 : /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2313 : plus it can be called directly. */
2314 :
2315 : void
2316 2088 : gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2317 : {
2318 2088 : gfc_ss *ss;
2319 2088 : gfc_se argse;
2320 2088 : tree desc, tmp, stride, extent, cond;
2321 2088 : int i;
2322 2088 : tree fncall0;
2323 2088 : gfc_array_spec *as;
2324 2088 : gfc_symbol *sym = NULL;
2325 :
2326 2088 : if (arg->ts.type == BT_CLASS)
2327 90 : gfc_add_class_array_ref (arg);
2328 :
2329 2088 : if (arg->expr_type == EXPR_VARIABLE)
2330 2052 : sym = arg->symtree->n.sym;
2331 :
2332 2088 : ss = gfc_walk_expr (arg);
2333 2088 : gcc_assert (ss != gfc_ss_terminator);
2334 2088 : gfc_init_se (&argse, NULL);
2335 2088 : argse.data_not_needed = 1;
2336 2088 : gfc_conv_expr_descriptor (&argse, arg);
2337 :
2338 2088 : as = gfc_get_full_arrayspec_from_expr (arg);
2339 :
2340 : /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2341 : Note in addition that zero-sized arrays don't count as contiguous. */
2342 :
2343 2088 : if (as && as->type == AS_ASSUMED_RANK)
2344 : {
2345 : /* Build the call to is_contiguous0. */
2346 243 : argse.want_pointer = 1;
2347 243 : gfc_conv_expr_descriptor (&argse, arg);
2348 243 : gfc_add_block_to_block (&se->pre, &argse.pre);
2349 243 : gfc_add_block_to_block (&se->post, &argse.post);
2350 243 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2351 243 : fncall0 = build_call_expr_loc (input_location,
2352 : gfor_fndecl_is_contiguous0, 1, desc);
2353 243 : se->expr = fncall0;
2354 243 : se->expr = convert (boolean_type_node, se->expr);
2355 : }
2356 : else
2357 : {
2358 1845 : gfc_add_block_to_block (&se->pre, &argse.pre);
2359 1845 : gfc_add_block_to_block (&se->post, &argse.post);
2360 1845 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2361 :
2362 1845 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2363 1845 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2364 1845 : stride, build_int_cst (TREE_TYPE (stride), 1));
2365 :
2366 2177 : for (i = 0; i < arg->rank - 1; i++)
2367 : {
2368 332 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2369 332 : extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2370 332 : extent = fold_build2_loc (input_location, MINUS_EXPR,
2371 : gfc_array_index_type, extent, tmp);
2372 332 : extent = fold_build2_loc (input_location, PLUS_EXPR,
2373 : gfc_array_index_type, extent,
2374 : gfc_index_one_node);
2375 332 : tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2376 332 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2377 : tmp, extent);
2378 332 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2379 332 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2380 : stride, tmp);
2381 332 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2382 : boolean_type_node, cond, tmp);
2383 : }
2384 1845 : se->expr = cond;
2385 : }
2386 :
2387 : /* A pointer that does not have the CONTIGUOUS attribute needs to be checked
2388 : if it points to an array whose span differs from the element size. */
2389 2088 : if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous)
2390 : {
2391 180 : tree span = gfc_conv_descriptor_span_get (desc);
2392 180 : tmp = fold_convert (TREE_TYPE (span),
2393 : gfc_conv_descriptor_elem_len (desc));
2394 180 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2395 : span, tmp);
2396 180 : se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2397 : boolean_type_node, cond,
2398 : convert (boolean_type_node, se->expr));
2399 : }
2400 :
2401 2088 : gfc_free_ss_chain (ss);
2402 2088 : }
2403 :
2404 :
2405 : /* Evaluate a single upper or lower bound. */
2406 : /* TODO: bound intrinsic generates way too much unnecessary code. */
2407 :
2408 : static void
2409 16016 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2410 : {
2411 16016 : gfc_actual_arglist *arg;
2412 16016 : gfc_actual_arglist *arg2;
2413 16016 : tree desc;
2414 16016 : tree type;
2415 16016 : tree bound;
2416 16016 : tree tmp;
2417 16016 : tree cond, cond1;
2418 16016 : tree ubound;
2419 16016 : tree lbound;
2420 16016 : tree size;
2421 16016 : gfc_se argse;
2422 16016 : gfc_array_spec * as;
2423 16016 : bool assumed_rank_lb_one;
2424 :
2425 16016 : arg = expr->value.function.actual;
2426 16016 : arg2 = arg->next;
2427 :
2428 16016 : if (se->ss)
2429 : {
2430 : /* Create an implicit second parameter from the loop variable. */
2431 7830 : gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2432 7830 : gcc_assert (se->loop->dimen == 1);
2433 7830 : gcc_assert (se->ss->info->expr == expr);
2434 7830 : gfc_advance_se_ss_chain (se);
2435 7830 : bound = se->loop->loopvar[0];
2436 7830 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2437 : gfc_array_index_type, bound,
2438 : se->loop->from[0]);
2439 : }
2440 : else
2441 : {
2442 : /* use the passed argument. */
2443 8186 : gcc_assert (arg2->expr);
2444 8186 : gfc_init_se (&argse, NULL);
2445 8186 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2446 8186 : gfc_add_block_to_block (&se->pre, &argse.pre);
2447 8186 : bound = argse.expr;
2448 : /* Convert from one based to zero based. */
2449 8186 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2450 : gfc_array_index_type, bound,
2451 : gfc_index_one_node);
2452 : }
2453 :
2454 : /* TODO: don't re-evaluate the descriptor on each iteration. */
2455 : /* Get a descriptor for the first parameter. */
2456 16016 : gfc_init_se (&argse, NULL);
2457 16016 : gfc_conv_expr_descriptor (&argse, arg->expr);
2458 16016 : gfc_add_block_to_block (&se->pre, &argse.pre);
2459 16016 : gfc_add_block_to_block (&se->post, &argse.post);
2460 :
2461 16016 : desc = argse.expr;
2462 :
2463 16016 : as = gfc_get_full_arrayspec_from_expr (arg->expr);
2464 :
2465 16016 : if (INTEGER_CST_P (bound))
2466 : {
2467 8066 : gcc_assert (op != GFC_ISYM_SHAPE);
2468 7829 : if (((!as || as->type != AS_ASSUMED_RANK)
2469 7206 : && wi::geu_p (wi::to_wide (bound),
2470 7206 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2471 16132 : || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2472 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2473 : "dimension index",
2474 : (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
2475 : &expr->where);
2476 : }
2477 :
2478 16016 : if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2479 : {
2480 8810 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2481 : {
2482 651 : bound = gfc_evaluate_now (bound, &se->pre);
2483 651 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2484 651 : bound, build_int_cst (TREE_TYPE (bound), 0));
2485 651 : if (as && as->type == AS_ASSUMED_RANK)
2486 546 : tmp = gfc_conv_descriptor_rank (desc);
2487 : else
2488 105 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2489 651 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2490 651 : bound, fold_convert(TREE_TYPE (bound), tmp));
2491 651 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2492 : logical_type_node, cond, tmp);
2493 651 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2494 : gfc_msg_fault);
2495 : }
2496 : }
2497 :
2498 : /* Take care of the lbound shift for assumed-rank arrays that are
2499 : nonallocatable and nonpointers. Those have a lbound of 1. */
2500 15528 : assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2501 10929 : && ((arg->expr->ts.type != BT_CLASS
2502 1945 : && !arg->expr->symtree->n.sym->attr.allocatable
2503 1602 : && !arg->expr->symtree->n.sym->attr.pointer)
2504 896 : || (arg->expr->ts.type == BT_CLASS
2505 174 : && !CLASS_DATA (arg->expr)->attr.allocatable
2506 138 : && !CLASS_DATA (arg->expr)->attr.class_pointer));
2507 :
2508 16016 : ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2509 16016 : lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2510 16016 : size = fold_build2_loc (input_location, MINUS_EXPR,
2511 : gfc_array_index_type, ubound, lbound);
2512 16016 : size = fold_build2_loc (input_location, PLUS_EXPR,
2513 : gfc_array_index_type, size, gfc_index_one_node);
2514 :
2515 : /* 13.14.53: Result value for LBOUND
2516 :
2517 : Case (i): For an array section or for an array expression other than a
2518 : whole array or array structure component, LBOUND(ARRAY, DIM)
2519 : has the value 1. For a whole array or array structure
2520 : component, LBOUND(ARRAY, DIM) has the value:
2521 : (a) equal to the lower bound for subscript DIM of ARRAY if
2522 : dimension DIM of ARRAY does not have extent zero
2523 : or if ARRAY is an assumed-size array of rank DIM,
2524 : or (b) 1 otherwise.
2525 :
2526 : 13.14.113: Result value for UBOUND
2527 :
2528 : Case (i): For an array section or for an array expression other than a
2529 : whole array or array structure component, UBOUND(ARRAY, DIM)
2530 : has the value equal to the number of elements in the given
2531 : dimension; otherwise, it has a value equal to the upper bound
2532 : for subscript DIM of ARRAY if dimension DIM of ARRAY does
2533 : not have size zero and has value zero if dimension DIM has
2534 : size zero. */
2535 :
2536 16016 : if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
2537 532 : se->expr = gfc_index_one_node;
2538 15484 : else if (as)
2539 : {
2540 14996 : if (op == GFC_ISYM_UBOUND)
2541 : {
2542 5346 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2543 : size, gfc_index_zero_node);
2544 10088 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2545 : gfc_array_index_type, cond,
2546 : (assumed_rank_lb_one ? size : ubound),
2547 : gfc_index_zero_node);
2548 : }
2549 9650 : else if (op == GFC_ISYM_LBOUND)
2550 : {
2551 4869 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2552 : size, gfc_index_zero_node);
2553 4869 : if (as->type == AS_ASSUMED_SIZE)
2554 : {
2555 98 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2556 : logical_type_node, bound,
2557 98 : build_int_cst (TREE_TYPE (bound),
2558 98 : arg->expr->rank - 1));
2559 98 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2560 : logical_type_node, cond, cond1);
2561 : }
2562 4869 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2563 : gfc_array_index_type, cond,
2564 : lbound, gfc_index_one_node);
2565 : }
2566 4781 : else if (op == GFC_ISYM_SHAPE)
2567 4781 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2568 : gfc_array_index_type, size,
2569 : gfc_index_zero_node);
2570 : else
2571 0 : gcc_unreachable ();
2572 :
2573 : /* According to F2018 16.9.172, para 5, an assumed rank object,
2574 : argument associated with and assumed size array, has the ubound
2575 : of the final dimension set to -1 and UBOUND must return this.
2576 : Similarly for the SHAPE intrinsic. */
2577 14996 : if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
2578 : {
2579 793 : tree minus_one = build_int_cst (gfc_array_index_type, -1);
2580 793 : tree rank = fold_convert (gfc_array_index_type,
2581 : gfc_conv_descriptor_rank (desc));
2582 793 : rank = fold_build2_loc (input_location, PLUS_EXPR,
2583 : gfc_array_index_type, rank, minus_one);
2584 :
2585 : /* Fix the expression to stop it from becoming even more
2586 : complicated. */
2587 793 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
2588 :
2589 : /* Descriptors for assumed-size arrays have ubound = -1
2590 : in the last dimension. */
2591 793 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2592 : logical_type_node, ubound, minus_one);
2593 793 : cond = fold_build2_loc (input_location, EQ_EXPR,
2594 : logical_type_node, bound, rank);
2595 793 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2596 : logical_type_node, cond, cond1);
2597 793 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2598 : gfc_array_index_type, cond,
2599 : minus_one, se->expr);
2600 : }
2601 : }
2602 : else /* as is null; this is an old-fashioned 1-based array. */
2603 : {
2604 488 : if (op != GFC_ISYM_LBOUND)
2605 : {
2606 386 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2607 : gfc_array_index_type, size,
2608 : gfc_index_zero_node);
2609 : }
2610 : else
2611 102 : se->expr = gfc_index_one_node;
2612 : }
2613 :
2614 :
2615 16016 : type = gfc_typenode_for_spec (&expr->ts);
2616 16016 : se->expr = convert (type, se->expr);
2617 16016 : }
2618 :
2619 :
2620 : static void
2621 666 : conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2622 : {
2623 666 : gfc_actual_arglist *arg;
2624 666 : gfc_actual_arglist *arg2;
2625 666 : gfc_se argse;
2626 666 : tree bound, lbound, resbound, resbound2, desc, cond, tmp;
2627 666 : tree type;
2628 666 : int corank;
2629 :
2630 666 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2631 : || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2632 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE
2633 : || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2634 :
2635 666 : arg = expr->value.function.actual;
2636 666 : arg2 = arg->next;
2637 :
2638 666 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2639 666 : corank = arg->expr->corank;
2640 :
2641 666 : gfc_init_se (&argse, NULL);
2642 666 : argse.want_coarray = 1;
2643 :
2644 666 : gfc_conv_expr_descriptor (&argse, arg->expr);
2645 666 : gfc_add_block_to_block (&se->pre, &argse.pre);
2646 666 : gfc_add_block_to_block (&se->post, &argse.post);
2647 666 : desc = argse.expr;
2648 :
2649 666 : if (se->ss)
2650 : {
2651 : /* Create an implicit second parameter from the loop variable. */
2652 238 : gcc_assert (!arg2->expr
2653 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE);
2654 238 : gcc_assert (corank > 0);
2655 238 : gcc_assert (se->loop->dimen == 1);
2656 238 : gcc_assert (se->ss->info->expr == expr);
2657 :
2658 238 : bound = se->loop->loopvar[0];
2659 476 : bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2660 238 : bound, gfc_rank_cst[arg->expr->rank]);
2661 238 : gfc_advance_se_ss_chain (se);
2662 : }
2663 428 : else if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2664 0 : bound = gfc_index_zero_node;
2665 : else
2666 : {
2667 428 : gcc_assert (arg2->expr);
2668 428 : gfc_init_se (&argse, NULL);
2669 428 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2670 428 : gfc_add_block_to_block (&se->pre, &argse.pre);
2671 428 : bound = argse.expr;
2672 :
2673 428 : if (INTEGER_CST_P (bound))
2674 : {
2675 334 : if (wi::ltu_p (wi::to_wide (bound), 1)
2676 668 : || wi::gtu_p (wi::to_wide (bound),
2677 334 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2678 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2679 0 : "dimension index", expr->value.function.isym->name,
2680 : &expr->where);
2681 : }
2682 94 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2683 : {
2684 36 : bound = gfc_evaluate_now (bound, &se->pre);
2685 36 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2686 36 : bound, build_int_cst (TREE_TYPE (bound), 1));
2687 36 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2688 36 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2689 : bound, tmp);
2690 36 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2691 : logical_type_node, cond, tmp);
2692 36 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2693 : gfc_msg_fault);
2694 : }
2695 :
2696 :
2697 : /* Subtract 1 to get to zero based and add dimensions. */
2698 428 : switch (arg->expr->rank)
2699 : {
2700 70 : case 0:
2701 70 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2702 : gfc_array_index_type, bound,
2703 : gfc_index_one_node);
2704 : case 1:
2705 : break;
2706 38 : default:
2707 38 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2708 : gfc_array_index_type, bound,
2709 38 : gfc_rank_cst[arg->expr->rank - 1]);
2710 : }
2711 : }
2712 :
2713 666 : resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2714 :
2715 : /* COSHAPE needs the lower cobound and so it is stashed here before resbound
2716 : is overwritten. */
2717 666 : lbound = NULL_TREE;
2718 666 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2719 4 : lbound = resbound;
2720 :
2721 : /* Handle UCOBOUND with special handling of the last codimension. */
2722 666 : if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2723 422 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2724 : {
2725 : /* Last codimension: For -fcoarray=single just return
2726 : the lcobound - otherwise add
2727 : ceiling (real (num_images ()) / real (size)) - 1
2728 : = (num_images () + size - 1) / size - 1
2729 : = (num_images - 1) / size(),
2730 : where size is the product of the extent of all but the last
2731 : codimension. */
2732 :
2733 248 : if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2734 : {
2735 64 : tree cosize;
2736 :
2737 64 : cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2738 64 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2739 : 2, null_pointer_node, null_pointer_node);
2740 64 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2741 : gfc_array_index_type,
2742 : fold_convert (gfc_array_index_type, tmp),
2743 : build_int_cst (gfc_array_index_type, 1));
2744 64 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2745 : gfc_array_index_type, tmp,
2746 : fold_convert (gfc_array_index_type, cosize));
2747 64 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2748 : gfc_array_index_type, resbound, tmp);
2749 64 : }
2750 184 : else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2751 : {
2752 : /* ubound = lbound + num_images() - 1. */
2753 44 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2754 : 2, null_pointer_node, null_pointer_node);
2755 44 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2756 : gfc_array_index_type,
2757 : fold_convert (gfc_array_index_type, tmp),
2758 : build_int_cst (gfc_array_index_type, 1));
2759 44 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2760 : gfc_array_index_type, resbound, tmp);
2761 : }
2762 :
2763 248 : if (corank > 1)
2764 : {
2765 171 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2766 : bound,
2767 171 : build_int_cst (TREE_TYPE (bound),
2768 171 : arg->expr->rank + corank - 1));
2769 :
2770 171 : resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2771 171 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2772 : gfc_array_index_type, cond,
2773 : resbound, resbound2);
2774 : }
2775 : else
2776 77 : se->expr = resbound;
2777 :
2778 : /* Get the coshape for this dimension. */
2779 248 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2780 : {
2781 4 : gcc_assert (lbound != NULL_TREE);
2782 4 : se->expr = fold_build2_loc (input_location, MINUS_EXPR,
2783 : gfc_array_index_type,
2784 : se->expr, lbound);
2785 4 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2786 : gfc_array_index_type,
2787 : se->expr, gfc_index_one_node);
2788 : }
2789 : }
2790 : else
2791 418 : se->expr = resbound;
2792 :
2793 666 : type = gfc_typenode_for_spec (&expr->ts);
2794 666 : se->expr = convert (type, se->expr);
2795 666 : }
2796 :
2797 :
2798 : static void
2799 2193 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2800 : {
2801 2193 : gfc_actual_arglist *array_arg;
2802 2193 : gfc_actual_arglist *dim_arg;
2803 2193 : gfc_se argse;
2804 2193 : tree desc, tmp;
2805 :
2806 2193 : array_arg = expr->value.function.actual;
2807 2193 : dim_arg = array_arg->next;
2808 :
2809 2193 : gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2810 :
2811 2193 : gfc_init_se (&argse, NULL);
2812 2193 : gfc_conv_expr_descriptor (&argse, array_arg->expr);
2813 2193 : gfc_add_block_to_block (&se->pre, &argse.pre);
2814 2193 : gfc_add_block_to_block (&se->post, &argse.post);
2815 2193 : desc = argse.expr;
2816 :
2817 2193 : gcc_assert (dim_arg->expr);
2818 2193 : gfc_init_se (&argse, NULL);
2819 2193 : gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2820 2193 : gfc_add_block_to_block (&se->pre, &argse.pre);
2821 2193 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2822 : argse.expr, gfc_index_one_node);
2823 2193 : se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2824 2193 : }
2825 :
2826 : static void
2827 7818 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2828 : {
2829 7818 : tree arg, cabs;
2830 :
2831 7818 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2832 :
2833 7818 : switch (expr->value.function.actual->expr->ts.type)
2834 : {
2835 6812 : case BT_INTEGER:
2836 6812 : case BT_REAL:
2837 6812 : se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2838 : arg);
2839 6812 : break;
2840 :
2841 1006 : case BT_COMPLEX:
2842 1006 : cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
2843 1006 : se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2844 1006 : break;
2845 :
2846 0 : default:
2847 0 : gcc_unreachable ();
2848 : }
2849 7818 : }
2850 :
2851 :
2852 : /* Create a complex value from one or two real components. */
2853 :
2854 : static void
2855 491 : gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2856 : {
2857 491 : tree real;
2858 491 : tree imag;
2859 491 : tree type;
2860 491 : tree *args;
2861 491 : unsigned int num_args;
2862 :
2863 491 : num_args = gfc_intrinsic_argument_list_length (expr);
2864 491 : args = XALLOCAVEC (tree, num_args);
2865 :
2866 491 : type = gfc_typenode_for_spec (&expr->ts);
2867 491 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2868 491 : real = convert (TREE_TYPE (type), args[0]);
2869 491 : if (both)
2870 447 : imag = convert (TREE_TYPE (type), args[1]);
2871 44 : else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
2872 : {
2873 30 : imag = fold_build1_loc (input_location, IMAGPART_EXPR,
2874 30 : TREE_TYPE (TREE_TYPE (args[0])), args[0]);
2875 30 : imag = convert (TREE_TYPE (type), imag);
2876 : }
2877 : else
2878 14 : imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
2879 :
2880 491 : se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
2881 491 : }
2882 :
2883 :
2884 : /* Remainder function MOD(A, P) = A - INT(A / P) * P
2885 : MODULO(A, P) = A - FLOOR (A / P) * P
2886 :
2887 : The obvious algorithms above are numerically instable for large
2888 : arguments, hence these intrinsics are instead implemented via calls
2889 : to the fmod family of functions. It is the responsibility of the
2890 : user to ensure that the second argument is non-zero. */
2891 :
2892 : static void
2893 3573 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2894 : {
2895 3573 : tree type;
2896 3573 : tree tmp;
2897 3573 : tree test;
2898 3573 : tree test2;
2899 3573 : tree fmod;
2900 3573 : tree zero;
2901 3573 : tree args[2];
2902 :
2903 3573 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
2904 :
2905 3573 : switch (expr->ts.type)
2906 : {
2907 3420 : case BT_INTEGER:
2908 : /* Integer case is easy, we've got a builtin op. */
2909 3420 : type = TREE_TYPE (args[0]);
2910 :
2911 3420 : if (modulo)
2912 409 : se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2913 : args[0], args[1]);
2914 : else
2915 3011 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2916 : args[0], args[1]);
2917 : break;
2918 :
2919 30 : case BT_UNSIGNED:
2920 : /* Even easier, we only need one. */
2921 30 : type = TREE_TYPE (args[0]);
2922 30 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2923 : args[0], args[1]);
2924 30 : break;
2925 :
2926 123 : case BT_REAL:
2927 123 : fmod = NULL_TREE;
2928 : /* Check if we have a builtin fmod. */
2929 123 : fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
2930 :
2931 : /* The builtin should always be available. */
2932 123 : gcc_assert (fmod != NULL_TREE);
2933 :
2934 123 : tmp = build_addr (fmod);
2935 123 : se->expr = build_call_array_loc (input_location,
2936 123 : TREE_TYPE (TREE_TYPE (fmod)),
2937 : tmp, 2, args);
2938 123 : if (modulo == 0)
2939 123 : return;
2940 :
2941 25 : type = TREE_TYPE (args[0]);
2942 :
2943 25 : args[0] = gfc_evaluate_now (args[0], &se->pre);
2944 25 : args[1] = gfc_evaluate_now (args[1], &se->pre);
2945 :
2946 : /* Definition:
2947 : modulo = arg - floor (arg/arg2) * arg2
2948 :
2949 : In order to calculate the result accurately, we use the fmod
2950 : function as follows.
2951 :
2952 : res = fmod (arg, arg2);
2953 : if (res)
2954 : {
2955 : if ((arg < 0) xor (arg2 < 0))
2956 : res += arg2;
2957 : }
2958 : else
2959 : res = copysign (0., arg2);
2960 :
2961 : => As two nested ternary exprs:
2962 :
2963 : res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2964 : : copysign (0., arg2);
2965 :
2966 : */
2967 :
2968 25 : zero = gfc_build_const (type, integer_zero_node);
2969 25 : tmp = gfc_evaluate_now (se->expr, &se->pre);
2970 25 : if (!flag_signed_zeros)
2971 : {
2972 1 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2973 : args[0], zero);
2974 1 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2975 : args[1], zero);
2976 1 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2977 : logical_type_node, test, test2);
2978 1 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2979 : tmp, zero);
2980 1 : test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2981 : logical_type_node, test, test2);
2982 1 : test = gfc_evaluate_now (test, &se->pre);
2983 1 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2984 : fold_build2_loc (input_location,
2985 : PLUS_EXPR,
2986 : type, tmp, args[1]),
2987 : tmp);
2988 : }
2989 : else
2990 : {
2991 24 : tree expr1, copysign, cscall;
2992 24 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
2993 : expr->ts.kind);
2994 24 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2995 : args[0], zero);
2996 24 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2997 : args[1], zero);
2998 24 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2999 : logical_type_node, test, test2);
3000 24 : expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3001 : fold_build2_loc (input_location,
3002 : PLUS_EXPR,
3003 : type, tmp, args[1]),
3004 : tmp);
3005 24 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3006 : tmp, zero);
3007 24 : cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3008 : args[1]);
3009 24 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3010 : expr1, cscall);
3011 : }
3012 : return;
3013 :
3014 0 : default:
3015 0 : gcc_unreachable ();
3016 : }
3017 : }
3018 :
3019 : /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3020 : DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3021 : where the right shifts are logical (i.e. 0's are shifted in).
3022 : Because SHIFT_EXPR's want shifts strictly smaller than the integral
3023 : type width, we have to special-case both S == 0 and S == BITSIZE(J):
3024 : DSHIFTL(I,J,0) = I
3025 : DSHIFTL(I,J,BITSIZE) = J
3026 : DSHIFTR(I,J,0) = J
3027 : DSHIFTR(I,J,BITSIZE) = I. */
3028 :
3029 : static void
3030 132 : gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3031 : {
3032 132 : tree type, utype, stype, arg1, arg2, shift, res, left, right;
3033 132 : tree args[3], cond, tmp;
3034 132 : int bitsize;
3035 :
3036 132 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
3037 :
3038 132 : gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3039 132 : type = TREE_TYPE (args[0]);
3040 132 : bitsize = TYPE_PRECISION (type);
3041 132 : utype = unsigned_type_for (type);
3042 132 : stype = TREE_TYPE (args[2]);
3043 :
3044 132 : arg1 = gfc_evaluate_now (args[0], &se->pre);
3045 132 : arg2 = gfc_evaluate_now (args[1], &se->pre);
3046 132 : shift = gfc_evaluate_now (args[2], &se->pre);
3047 :
3048 : /* The generic case. */
3049 132 : tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3050 132 : build_int_cst (stype, bitsize), shift);
3051 198 : left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3052 : arg1, dshiftl ? shift : tmp);
3053 :
3054 198 : right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3055 : fold_convert (utype, arg2), dshiftl ? tmp : shift);
3056 132 : right = fold_convert (type, right);
3057 :
3058 132 : res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3059 :
3060 : /* Special cases. */
3061 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3062 : build_int_cst (stype, 0));
3063 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3064 : dshiftl ? arg1 : arg2, res);
3065 :
3066 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3067 132 : build_int_cst (stype, bitsize));
3068 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3069 : dshiftl ? arg2 : arg1, res);
3070 :
3071 132 : se->expr = res;
3072 132 : }
3073 :
3074 :
3075 : /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3076 :
3077 : static void
3078 96 : gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3079 : {
3080 96 : tree val;
3081 96 : tree tmp;
3082 96 : tree type;
3083 96 : tree zero;
3084 96 : tree args[2];
3085 :
3086 96 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3087 96 : type = TREE_TYPE (args[0]);
3088 :
3089 96 : val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3090 96 : val = gfc_evaluate_now (val, &se->pre);
3091 :
3092 96 : zero = gfc_build_const (type, integer_zero_node);
3093 96 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3094 96 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3095 96 : }
3096 :
3097 :
3098 : /* SIGN(A, B) is absolute value of A times sign of B.
3099 : The real value versions use library functions to ensure the correct
3100 : handling of negative zero. Integer case implemented as:
3101 : SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3102 : */
3103 :
3104 : static void
3105 423 : gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3106 : {
3107 423 : tree tmp;
3108 423 : tree type;
3109 423 : tree args[2];
3110 :
3111 423 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3112 423 : if (expr->ts.type == BT_REAL)
3113 : {
3114 161 : tree abs;
3115 :
3116 161 : tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3117 161 : abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3118 :
3119 : /* We explicitly have to ignore the minus sign. We do so by using
3120 : result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3121 161 : if (!flag_sign_zero
3122 197 : && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3123 : {
3124 12 : tree cond, zero;
3125 12 : zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3126 12 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3127 : args[1], zero);
3128 24 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3129 12 : TREE_TYPE (args[0]), cond,
3130 : build_call_expr_loc (input_location, abs, 1,
3131 : args[0]),
3132 : build_call_expr_loc (input_location, tmp, 2,
3133 : args[0], args[1]));
3134 : }
3135 : else
3136 149 : se->expr = build_call_expr_loc (input_location, tmp, 2,
3137 : args[0], args[1]);
3138 161 : return;
3139 : }
3140 :
3141 : /* Having excluded floating point types, we know we are now dealing
3142 : with signed integer types. */
3143 262 : type = TREE_TYPE (args[0]);
3144 :
3145 : /* Args[0] is used multiple times below. */
3146 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3147 :
3148 : /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3149 : the signs of A and B are the same, and of all ones if they differ. */
3150 262 : tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3151 262 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3152 262 : build_int_cst (type, TYPE_PRECISION (type) - 1));
3153 262 : tmp = gfc_evaluate_now (tmp, &se->pre);
3154 :
3155 : /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3156 : is all ones (i.e. -1). */
3157 262 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3158 : fold_build2_loc (input_location, PLUS_EXPR,
3159 : type, args[0], tmp), tmp);
3160 : }
3161 :
3162 :
3163 : /* Test for the presence of an optional argument. */
3164 :
3165 : static void
3166 5070 : gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3167 : {
3168 5070 : gfc_expr *arg;
3169 :
3170 5070 : arg = expr->value.function.actual->expr;
3171 5070 : gcc_assert (arg->expr_type == EXPR_VARIABLE);
3172 5070 : se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3173 5070 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3174 5070 : }
3175 :
3176 :
3177 : /* Calculate the double precision product of two single precision values. */
3178 :
3179 : static void
3180 13 : gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3181 : {
3182 13 : tree type;
3183 13 : tree args[2];
3184 :
3185 13 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3186 :
3187 : /* Convert the args to double precision before multiplying. */
3188 13 : type = gfc_typenode_for_spec (&expr->ts);
3189 13 : args[0] = convert (type, args[0]);
3190 13 : args[1] = convert (type, args[1]);
3191 13 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3192 : args[1]);
3193 13 : }
3194 :
3195 :
3196 : /* Return a length one character string containing an ascii character. */
3197 :
3198 : static void
3199 2020 : gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3200 : {
3201 2020 : tree arg[2];
3202 2020 : tree var;
3203 2020 : tree type;
3204 2020 : unsigned int num_args;
3205 :
3206 2020 : num_args = gfc_intrinsic_argument_list_length (expr);
3207 2020 : gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3208 :
3209 2020 : type = gfc_get_char_type (expr->ts.kind);
3210 2020 : var = gfc_create_var (type, "char");
3211 :
3212 2020 : arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3213 2020 : gfc_add_modify (&se->pre, var, arg[0]);
3214 2020 : se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3215 2020 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3216 2020 : }
3217 :
3218 :
3219 : static void
3220 0 : gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3221 : {
3222 0 : tree var;
3223 0 : tree len;
3224 0 : tree tmp;
3225 0 : tree cond;
3226 0 : tree fndecl;
3227 0 : tree *args;
3228 0 : unsigned int num_args;
3229 :
3230 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3231 0 : args = XALLOCAVEC (tree, num_args);
3232 :
3233 0 : var = gfc_create_var (pchar_type_node, "pstr");
3234 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3235 :
3236 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3237 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3238 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3239 :
3240 0 : fndecl = build_addr (gfor_fndecl_ctime);
3241 0 : tmp = build_call_array_loc (input_location,
3242 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3243 : fndecl, num_args, args);
3244 0 : gfc_add_expr_to_block (&se->pre, tmp);
3245 :
3246 : /* Free the temporary afterwards, if necessary. */
3247 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3248 0 : len, build_int_cst (TREE_TYPE (len), 0));
3249 0 : tmp = gfc_call_free (var);
3250 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3251 0 : gfc_add_expr_to_block (&se->post, tmp);
3252 :
3253 0 : se->expr = var;
3254 0 : se->string_length = len;
3255 0 : }
3256 :
3257 :
3258 : static void
3259 0 : gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3260 : {
3261 0 : tree var;
3262 0 : tree len;
3263 0 : tree tmp;
3264 0 : tree cond;
3265 0 : tree fndecl;
3266 0 : tree *args;
3267 0 : unsigned int num_args;
3268 :
3269 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3270 0 : args = XALLOCAVEC (tree, num_args);
3271 :
3272 0 : var = gfc_create_var (pchar_type_node, "pstr");
3273 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3274 :
3275 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3276 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3277 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3278 :
3279 0 : fndecl = build_addr (gfor_fndecl_fdate);
3280 0 : tmp = build_call_array_loc (input_location,
3281 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3282 : fndecl, num_args, args);
3283 0 : gfc_add_expr_to_block (&se->pre, tmp);
3284 :
3285 : /* Free the temporary afterwards, if necessary. */
3286 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3287 0 : len, build_int_cst (TREE_TYPE (len), 0));
3288 0 : tmp = gfc_call_free (var);
3289 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3290 0 : gfc_add_expr_to_block (&se->post, tmp);
3291 :
3292 0 : se->expr = var;
3293 0 : se->string_length = len;
3294 0 : }
3295 :
3296 :
3297 : /* Generate a direct call to free() for the FREE subroutine. */
3298 :
3299 : static tree
3300 10 : conv_intrinsic_free (gfc_code *code)
3301 : {
3302 10 : stmtblock_t block;
3303 10 : gfc_se argse;
3304 10 : tree arg, call;
3305 :
3306 10 : gfc_init_se (&argse, NULL);
3307 10 : gfc_conv_expr (&argse, code->ext.actual->expr);
3308 10 : arg = fold_convert (ptr_type_node, argse.expr);
3309 :
3310 10 : gfc_init_block (&block);
3311 10 : call = build_call_expr_loc (input_location,
3312 : builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3313 10 : gfc_add_expr_to_block (&block, call);
3314 10 : return gfc_finish_block (&block);
3315 : }
3316 :
3317 :
3318 : /* Call the RANDOM_INIT library subroutine with a hidden argument for
3319 : handling seeding on coarray images. */
3320 :
3321 : static tree
3322 90 : conv_intrinsic_random_init (gfc_code *code)
3323 : {
3324 90 : stmtblock_t block;
3325 90 : gfc_se se;
3326 90 : tree arg1, arg2, tmp;
3327 : /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3328 90 : tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3329 90 : ? logical_type_node
3330 90 : : gfc_get_logical_type (4);
3331 :
3332 : /* Make the function call. */
3333 90 : gfc_init_block (&block);
3334 90 : gfc_init_se (&se, NULL);
3335 :
3336 : /* Convert REPEATABLE to the desired LOGICAL entity. */
3337 90 : gfc_conv_expr (&se, code->ext.actual->expr);
3338 90 : gfc_add_block_to_block (&block, &se.pre);
3339 90 : arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3340 90 : gfc_add_block_to_block (&block, &se.post);
3341 :
3342 : /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3343 90 : gfc_conv_expr (&se, code->ext.actual->next->expr);
3344 90 : gfc_add_block_to_block (&block, &se.pre);
3345 90 : arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3346 90 : gfc_add_block_to_block (&block, &se.post);
3347 :
3348 90 : if (flag_coarray == GFC_FCOARRAY_LIB)
3349 : {
3350 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3351 : 2, arg1, arg2);
3352 : }
3353 : else
3354 : {
3355 : /* The ABI for libgfortran needs to be maintained, so a hidden
3356 : argument must be include if code is compiled with -fcoarray=single
3357 : or without the option. Set to 0. */
3358 90 : tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3359 90 : tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3360 : 3, arg1, arg2, arg3);
3361 : }
3362 :
3363 90 : gfc_add_expr_to_block (&block, tmp);
3364 :
3365 90 : return gfc_finish_block (&block);
3366 : }
3367 :
3368 :
3369 : /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3370 : conversions. */
3371 :
3372 : static tree
3373 194 : conv_intrinsic_system_clock (gfc_code *code)
3374 : {
3375 194 : stmtblock_t block;
3376 194 : gfc_se count_se, count_rate_se, count_max_se;
3377 194 : tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3378 194 : tree tmp;
3379 194 : int least;
3380 :
3381 194 : gfc_expr *count = code->ext.actual->expr;
3382 194 : gfc_expr *count_rate = code->ext.actual->next->expr;
3383 194 : gfc_expr *count_max = code->ext.actual->next->next->expr;
3384 :
3385 : /* Evaluate our arguments. */
3386 194 : if (count)
3387 : {
3388 194 : gfc_init_se (&count_se, NULL);
3389 194 : gfc_conv_expr (&count_se, count);
3390 : }
3391 :
3392 194 : if (count_rate)
3393 : {
3394 181 : gfc_init_se (&count_rate_se, NULL);
3395 181 : gfc_conv_expr (&count_rate_se, count_rate);
3396 : }
3397 :
3398 194 : if (count_max)
3399 : {
3400 180 : gfc_init_se (&count_max_se, NULL);
3401 180 : gfc_conv_expr (&count_max_se, count_max);
3402 : }
3403 :
3404 : /* Find the smallest kind found of the arguments. */
3405 194 : least = 16;
3406 194 : least = (count && count->ts.kind < least) ? count->ts.kind : least;
3407 194 : least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3408 : : least;
3409 194 : least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3410 : : least;
3411 :
3412 : /* Prepare temporary variables. */
3413 :
3414 194 : if (count)
3415 : {
3416 194 : if (least >= 8)
3417 18 : arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3418 176 : else if (least == 4)
3419 152 : arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3420 24 : else if (count->ts.kind == 1)
3421 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3422 : count->ts.kind);
3423 : else
3424 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3425 : count->ts.kind);
3426 : }
3427 :
3428 194 : if (count_rate)
3429 : {
3430 181 : if (least >= 8)
3431 18 : arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3432 163 : else if (least == 4)
3433 139 : arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3434 : else
3435 24 : arg2 = integer_zero_node;
3436 : }
3437 :
3438 194 : if (count_max)
3439 : {
3440 180 : if (least >= 8)
3441 18 : arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3442 162 : else if (least == 4)
3443 138 : arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3444 : else
3445 24 : arg3 = integer_zero_node;
3446 : }
3447 :
3448 : /* Make the function call. */
3449 194 : gfc_init_block (&block);
3450 :
3451 194 : if (least <= 2)
3452 : {
3453 24 : if (least == 1)
3454 : {
3455 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3456 : : null_pointer_node;
3457 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3458 : : null_pointer_node;
3459 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3460 : : null_pointer_node;
3461 : }
3462 :
3463 24 : if (least == 2)
3464 : {
3465 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3466 : : null_pointer_node;
3467 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3468 : : null_pointer_node;
3469 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3470 : : null_pointer_node;
3471 : }
3472 : }
3473 : else
3474 : {
3475 170 : if (least == 4)
3476 : {
3477 581 : tmp = build_call_expr_loc (input_location,
3478 : gfor_fndecl_system_clock4, 3,
3479 152 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3480 : : null_pointer_node,
3481 139 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3482 : : null_pointer_node,
3483 138 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3484 : : null_pointer_node);
3485 152 : gfc_add_expr_to_block (&block, tmp);
3486 : }
3487 : /* Handle kind>=8, 10, or 16 arguments */
3488 170 : if (least >= 8)
3489 : {
3490 72 : tmp = build_call_expr_loc (input_location,
3491 : gfor_fndecl_system_clock8, 3,
3492 18 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3493 : : null_pointer_node,
3494 18 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3495 : : null_pointer_node,
3496 18 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3497 : : null_pointer_node);
3498 18 : gfc_add_expr_to_block (&block, tmp);
3499 : }
3500 : }
3501 :
3502 : /* And store values back if needed. */
3503 194 : if (arg1 && arg1 != count_se.expr)
3504 194 : gfc_add_modify (&block, count_se.expr,
3505 194 : fold_convert (TREE_TYPE (count_se.expr), arg1));
3506 194 : if (arg2 && arg2 != count_rate_se.expr)
3507 181 : gfc_add_modify (&block, count_rate_se.expr,
3508 181 : fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3509 194 : if (arg3 && arg3 != count_max_se.expr)
3510 180 : gfc_add_modify (&block, count_max_se.expr,
3511 180 : fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3512 :
3513 194 : return gfc_finish_block (&block);
3514 : }
3515 :
3516 : static tree
3517 102 : conv_intrinsic_split (gfc_code *code)
3518 : {
3519 102 : stmtblock_t block, post_block;
3520 102 : gfc_se se;
3521 102 : gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
3522 102 : tree string, string_len;
3523 102 : tree set, set_len;
3524 102 : tree pos, pos_for_call;
3525 102 : tree back;
3526 102 : tree fndecl, call;
3527 :
3528 102 : string_expr = code->ext.actual->expr;
3529 102 : set_expr = code->ext.actual->next->expr;
3530 102 : pos_expr = code->ext.actual->next->next->expr;
3531 102 : back_expr = code->ext.actual->next->next->next->expr;
3532 :
3533 102 : gfc_start_block (&block);
3534 102 : gfc_init_block (&post_block);
3535 :
3536 102 : gfc_init_se (&se, NULL);
3537 102 : gfc_conv_expr (&se, string_expr);
3538 102 : gfc_conv_string_parameter (&se);
3539 102 : gfc_add_block_to_block (&block, &se.pre);
3540 102 : gfc_add_block_to_block (&post_block, &se.post);
3541 102 : string = se.expr;
3542 102 : string_len = se.string_length;
3543 :
3544 102 : gfc_init_se (&se, NULL);
3545 102 : gfc_conv_expr (&se, set_expr);
3546 102 : gfc_conv_string_parameter (&se);
3547 102 : gfc_add_block_to_block (&block, &se.pre);
3548 102 : gfc_add_block_to_block (&post_block, &se.post);
3549 102 : set = se.expr;
3550 102 : set_len = se.string_length;
3551 :
3552 102 : gfc_init_se (&se, NULL);
3553 102 : gfc_conv_expr (&se, pos_expr);
3554 102 : gfc_add_block_to_block (&block, &se.pre);
3555 102 : gfc_add_block_to_block (&post_block, &se.post);
3556 102 : pos = se.expr;
3557 102 : pos_for_call = fold_convert (gfc_charlen_type_node, pos);
3558 :
3559 102 : if (back_expr)
3560 : {
3561 48 : gfc_init_se (&se, NULL);
3562 48 : gfc_conv_expr (&se, back_expr);
3563 48 : gfc_add_block_to_block (&block, &se.pre);
3564 48 : gfc_add_block_to_block (&post_block, &se.post);
3565 48 : back = se.expr;
3566 : }
3567 : else
3568 54 : back = logical_false_node;
3569 :
3570 102 : if (string_expr->ts.kind == 1)
3571 66 : fndecl = gfor_fndecl_string_split;
3572 36 : else if (string_expr->ts.kind == 4)
3573 36 : fndecl = gfor_fndecl_string_split_char4;
3574 : else
3575 0 : gcc_unreachable ();
3576 :
3577 102 : call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
3578 : set_len, set, pos_for_call, back);
3579 102 : gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
3580 :
3581 102 : gfc_add_block_to_block (&block, &post_block);
3582 102 : return gfc_finish_block (&block);
3583 : }
3584 :
3585 : /* Return a character string containing the tty name. */
3586 :
3587 : static void
3588 0 : gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3589 : {
3590 0 : tree var;
3591 0 : tree len;
3592 0 : tree tmp;
3593 0 : tree cond;
3594 0 : tree fndecl;
3595 0 : tree *args;
3596 0 : unsigned int num_args;
3597 :
3598 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3599 0 : args = XALLOCAVEC (tree, num_args);
3600 :
3601 0 : var = gfc_create_var (pchar_type_node, "pstr");
3602 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3603 :
3604 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3605 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3606 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3607 :
3608 0 : fndecl = build_addr (gfor_fndecl_ttynam);
3609 0 : tmp = build_call_array_loc (input_location,
3610 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3611 : fndecl, num_args, args);
3612 0 : gfc_add_expr_to_block (&se->pre, tmp);
3613 :
3614 : /* Free the temporary afterwards, if necessary. */
3615 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3616 0 : len, build_int_cst (TREE_TYPE (len), 0));
3617 0 : tmp = gfc_call_free (var);
3618 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3619 0 : gfc_add_expr_to_block (&se->post, tmp);
3620 :
3621 0 : se->expr = var;
3622 0 : se->string_length = len;
3623 0 : }
3624 :
3625 :
3626 : /* Get the minimum/maximum value of all the parameters.
3627 : minmax (a1, a2, a3, ...)
3628 : {
3629 : mvar = a1;
3630 : mvar = COMP (mvar, a2)
3631 : mvar = COMP (mvar, a3)
3632 : ...
3633 : return mvar;
3634 : }
3635 : Where COMP is MIN/MAX_EXPR for integral types or when we don't
3636 : care about NaNs, or IFN_FMIN/MAX when the target has support for
3637 : fast NaN-honouring min/max. When neither holds expand a sequence
3638 : of explicit comparisons. */
3639 :
3640 : /* TODO: Mismatching types can occur when specific names are used.
3641 : These should be handled during resolution. */
3642 : static void
3643 1364 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3644 : {
3645 1364 : tree tmp;
3646 1364 : tree mvar;
3647 1364 : tree val;
3648 1364 : tree *args;
3649 1364 : tree type;
3650 1364 : tree argtype;
3651 1364 : gfc_actual_arglist *argexpr;
3652 1364 : unsigned int i, nargs;
3653 :
3654 1364 : nargs = gfc_intrinsic_argument_list_length (expr);
3655 1364 : args = XALLOCAVEC (tree, nargs);
3656 :
3657 1364 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3658 1364 : type = gfc_typenode_for_spec (&expr->ts);
3659 :
3660 : /* Only evaluate the argument once. */
3661 1364 : if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3662 367 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3663 :
3664 : /* Determine suitable type of temporary, as a GNU extension allows
3665 : different argument kinds. */
3666 1364 : argtype = TREE_TYPE (args[0]);
3667 1364 : argexpr = expr->value.function.actual;
3668 2947 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3669 : {
3670 1583 : tree tmptype = TREE_TYPE (args[i]);
3671 1583 : if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
3672 1 : argtype = tmptype;
3673 : }
3674 1364 : mvar = gfc_create_var (argtype, "M");
3675 1364 : gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
3676 :
3677 1364 : argexpr = expr->value.function.actual;
3678 2947 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3679 : {
3680 1583 : tree cond = NULL_TREE;
3681 1583 : val = args[i];
3682 :
3683 : /* Handle absent optional arguments by ignoring the comparison. */
3684 1583 : if (argexpr->expr->expr_type == EXPR_VARIABLE
3685 920 : && argexpr->expr->symtree->n.sym->attr.optional
3686 45 : && INDIRECT_REF_P (val))
3687 : {
3688 84 : cond = fold_build2_loc (input_location,
3689 : NE_EXPR, logical_type_node,
3690 42 : TREE_OPERAND (val, 0),
3691 42 : build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3692 : }
3693 1541 : else if (!VAR_P (val) && !TREE_CONSTANT (val))
3694 : /* Only evaluate the argument once. */
3695 599 : val = gfc_evaluate_now (val, &se->pre);
3696 :
3697 1583 : tree calc;
3698 : /* For floating point types, the question is what MAX(a, NaN) or
3699 : MIN(a, NaN) should return (where "a" is a normal number).
3700 : There are valid use case for returning either one, but the
3701 : Fortran standard doesn't specify which one should be chosen.
3702 : Also, there is no consensus among other tested compilers. In
3703 : short, it's a mess. So lets just do whatever is fastest. */
3704 1583 : tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
3705 1583 : calc = fold_build2_loc (input_location, code, argtype,
3706 : convert (argtype, val), mvar);
3707 1583 : tmp = build2_v (MODIFY_EXPR, mvar, calc);
3708 :
3709 1583 : if (cond != NULL_TREE)
3710 42 : tmp = build3_v (COND_EXPR, cond, tmp,
3711 : build_empty_stmt (input_location));
3712 1583 : gfc_add_expr_to_block (&se->pre, tmp);
3713 : }
3714 1364 : se->expr = convert (type, mvar);
3715 1364 : }
3716 :
3717 :
3718 : /* Generate library calls for MIN and MAX intrinsics for character
3719 : variables. */
3720 : static void
3721 282 : gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3722 : {
3723 282 : tree *args;
3724 282 : tree var, len, fndecl, tmp, cond, function;
3725 282 : unsigned int nargs;
3726 :
3727 282 : nargs = gfc_intrinsic_argument_list_length (expr);
3728 282 : args = XALLOCAVEC (tree, nargs + 4);
3729 282 : gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3730 :
3731 : /* Create the result variables. */
3732 282 : len = gfc_create_var (gfc_charlen_type_node, "len");
3733 282 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
3734 282 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3735 282 : args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3736 282 : args[2] = build_int_cst (integer_type_node, op);
3737 282 : args[3] = build_int_cst (integer_type_node, nargs / 2);
3738 :
3739 282 : if (expr->ts.kind == 1)
3740 210 : function = gfor_fndecl_string_minmax;
3741 72 : else if (expr->ts.kind == 4)
3742 72 : function = gfor_fndecl_string_minmax_char4;
3743 : else
3744 0 : gcc_unreachable ();
3745 :
3746 : /* Make the function call. */
3747 282 : fndecl = build_addr (function);
3748 282 : tmp = build_call_array_loc (input_location,
3749 282 : TREE_TYPE (TREE_TYPE (function)), fndecl,
3750 : nargs + 4, args);
3751 282 : gfc_add_expr_to_block (&se->pre, tmp);
3752 :
3753 : /* Free the temporary afterwards, if necessary. */
3754 282 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3755 282 : len, build_int_cst (TREE_TYPE (len), 0));
3756 282 : tmp = gfc_call_free (var);
3757 282 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3758 282 : gfc_add_expr_to_block (&se->post, tmp);
3759 :
3760 282 : se->expr = var;
3761 282 : se->string_length = len;
3762 282 : }
3763 :
3764 :
3765 : /* Create a symbol node for this intrinsic. The symbol from the frontend
3766 : has the generic name. */
3767 :
3768 : static gfc_symbol *
3769 11129 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3770 : {
3771 11129 : gfc_symbol *sym;
3772 :
3773 : /* TODO: Add symbols for intrinsic function to the global namespace. */
3774 11129 : gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3775 11129 : sym = gfc_new_symbol (expr->value.function.name, NULL);
3776 :
3777 11129 : sym->ts = expr->ts;
3778 11129 : if (sym->ts.type == BT_CHARACTER)
3779 1781 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3780 11129 : sym->attr.external = 1;
3781 11129 : sym->attr.function = 1;
3782 11129 : sym->attr.always_explicit = 1;
3783 11129 : sym->attr.proc = PROC_INTRINSIC;
3784 11129 : sym->attr.flavor = FL_PROCEDURE;
3785 11129 : sym->result = sym;
3786 11129 : if (expr->rank > 0)
3787 : {
3788 9755 : sym->attr.dimension = 1;
3789 9755 : sym->as = gfc_get_array_spec ();
3790 9755 : sym->as->type = AS_ASSUMED_SHAPE;
3791 9755 : sym->as->rank = expr->rank;
3792 : }
3793 :
3794 11129 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3795 : ignore_optional ? expr->value.function.actual
3796 : : NULL);
3797 :
3798 11129 : return sym;
3799 : }
3800 :
3801 : /* Remove empty actual arguments. */
3802 :
3803 : static void
3804 8277 : remove_empty_actual_arguments (gfc_actual_arglist **ap)
3805 : {
3806 44456 : while (*ap)
3807 : {
3808 36179 : if ((*ap)->expr == NULL)
3809 : {
3810 11076 : gfc_actual_arglist *r = *ap;
3811 11076 : *ap = r->next;
3812 11076 : r->next = NULL;
3813 11076 : gfc_free_actual_arglist (r);
3814 : }
3815 : else
3816 25103 : ap = &((*ap)->next);
3817 : }
3818 8277 : }
3819 :
3820 : #define MAX_SPEC_ARG 12
3821 :
3822 : /* Make up an fn spec that's right for intrinsic functions that we
3823 : want to call. */
3824 :
3825 : static char *
3826 1939 : intrinsic_fnspec (gfc_expr *expr)
3827 : {
3828 1939 : static char fnspec_buf[MAX_SPEC_ARG*2+1];
3829 1939 : char *fp;
3830 1939 : int i;
3831 1939 : int num_char_args;
3832 :
3833 : #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
3834 :
3835 : /* Set the fndecl. */
3836 1939 : fp = fnspec_buf;
3837 : /* Function return value. FIXME: Check if the second letter could
3838 : be something other than a space, for further optimization. */
3839 1939 : ADD_CHAR ('.');
3840 1939 : if (expr->rank == 0)
3841 : {
3842 238 : if (expr->ts.type == BT_CHARACTER)
3843 : {
3844 84 : ADD_CHAR ('w'); /* Address of character. */
3845 84 : ADD_CHAR ('.'); /* Length of character. */
3846 : }
3847 : }
3848 : else
3849 1701 : ADD_CHAR ('w'); /* Return value is a descriptor. */
3850 :
3851 1939 : num_char_args = 0;
3852 10224 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
3853 : {
3854 8285 : if (a->expr == NULL)
3855 2565 : continue;
3856 :
3857 5720 : if (a->name && strcmp (a->name,"%VAL") == 0)
3858 1300 : ADD_CHAR ('.');
3859 : else
3860 : {
3861 4420 : if (a->expr->rank > 0)
3862 2575 : ADD_CHAR ('r');
3863 : else
3864 1845 : ADD_CHAR ('R');
3865 : }
3866 5720 : num_char_args += a->expr->ts.type == BT_CHARACTER;
3867 5720 : gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
3868 : }
3869 :
3870 2743 : for (i = 0; i < num_char_args; i++)
3871 804 : ADD_CHAR ('.');
3872 :
3873 1939 : *fp = '\0';
3874 1939 : return fnspec_buf;
3875 : }
3876 :
3877 : #undef MAX_SPEC_ARG
3878 : #undef ADD_CHAR
3879 :
3880 : /* Generate the right symbol for the specific intrinsic function and
3881 : modify the expr accordingly. This assumes that absent optional
3882 : arguments should be removed. */
3883 :
3884 : gfc_symbol *
3885 8277 : specific_intrinsic_symbol (gfc_expr *expr)
3886 : {
3887 8277 : gfc_symbol *sym;
3888 :
3889 8277 : sym = gfc_find_intrinsic_symbol (expr);
3890 8277 : if (sym == NULL)
3891 : {
3892 1939 : sym = gfc_get_intrinsic_function_symbol (expr);
3893 1939 : sym->ts = expr->ts;
3894 1939 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
3895 240 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
3896 :
3897 1939 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3898 : expr->value.function.actual, true);
3899 1939 : sym->backend_decl
3900 1939 : = gfc_get_extern_function_decl (sym, expr->value.function.actual,
3901 1939 : intrinsic_fnspec (expr));
3902 : }
3903 :
3904 8277 : remove_empty_actual_arguments (&(expr->value.function.actual));
3905 :
3906 8277 : return sym;
3907 : }
3908 :
3909 : /* Generate a call to an external intrinsic function. FIXME: So far,
3910 : this only works for functions which are called with well-defined
3911 : types; CSHIFT and friends will come later. */
3912 :
3913 : static void
3914 13581 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3915 : {
3916 13581 : gfc_symbol *sym;
3917 13581 : vec<tree, va_gc> *append_args;
3918 13581 : bool specific_symbol;
3919 :
3920 13581 : gcc_assert (!se->ss || se->ss->info->expr == expr);
3921 :
3922 13581 : if (se->ss)
3923 11645 : gcc_assert (expr->rank > 0);
3924 : else
3925 1936 : gcc_assert (expr->rank == 0);
3926 :
3927 13581 : switch (expr->value.function.isym->id)
3928 : {
3929 : case GFC_ISYM_ANY:
3930 : case GFC_ISYM_ALL:
3931 : case GFC_ISYM_FINDLOC:
3932 : case GFC_ISYM_MAXLOC:
3933 : case GFC_ISYM_MINLOC:
3934 : case GFC_ISYM_MAXVAL:
3935 : case GFC_ISYM_MINVAL:
3936 : case GFC_ISYM_NORM2:
3937 : case GFC_ISYM_PRODUCT:
3938 : case GFC_ISYM_SUM:
3939 : specific_symbol = true;
3940 : break;
3941 5304 : default:
3942 5304 : specific_symbol = false;
3943 : }
3944 :
3945 13581 : if (specific_symbol)
3946 : {
3947 : /* Need to copy here because specific_intrinsic_symbol modifies
3948 : expr to omit the absent optional arguments. */
3949 8277 : expr = gfc_copy_expr (expr);
3950 8277 : sym = specific_intrinsic_symbol (expr);
3951 : }
3952 : else
3953 5304 : sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
3954 :
3955 : /* Calls to libgfortran_matmul need to be appended special arguments,
3956 : to be able to call the BLAS ?gemm functions if required and possible. */
3957 13581 : append_args = NULL;
3958 13581 : if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3959 865 : && !expr->external_blas
3960 827 : && sym->ts.type != BT_LOGICAL)
3961 : {
3962 811 : tree cint = gfc_get_int_type (gfc_c_int_kind);
3963 :
3964 811 : if (flag_external_blas
3965 0 : && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3966 0 : && (sym->ts.kind == 4 || sym->ts.kind == 8))
3967 : {
3968 0 : tree gemm_fndecl;
3969 :
3970 0 : if (sym->ts.type == BT_REAL)
3971 : {
3972 0 : if (sym->ts.kind == 4)
3973 0 : gemm_fndecl = gfor_fndecl_sgemm;
3974 : else
3975 0 : gemm_fndecl = gfor_fndecl_dgemm;
3976 : }
3977 : else
3978 : {
3979 0 : if (sym->ts.kind == 4)
3980 0 : gemm_fndecl = gfor_fndecl_cgemm;
3981 : else
3982 0 : gemm_fndecl = gfor_fndecl_zgemm;
3983 : }
3984 :
3985 0 : vec_alloc (append_args, 3);
3986 0 : append_args->quick_push (build_int_cst (cint, 1));
3987 0 : append_args->quick_push (build_int_cst (cint,
3988 0 : flag_blas_matmul_limit));
3989 0 : append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
3990 : gemm_fndecl));
3991 0 : }
3992 : else
3993 : {
3994 811 : vec_alloc (append_args, 3);
3995 811 : append_args->quick_push (build_int_cst (cint, 0));
3996 811 : append_args->quick_push (build_int_cst (cint, 0));
3997 811 : append_args->quick_push (null_pointer_node);
3998 : }
3999 : }
4000 : /* Non-character scalar reduce returns a pointer to a result of size set by
4001 : the element size of 'array'. Setting 'sym' allocatable ensures that the
4002 : result is deallocated at the appropriate time. */
4003 12770 : else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
4004 102 : && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
4005 96 : sym->attr.allocatable = 1;
4006 :
4007 :
4008 13581 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4009 : append_args);
4010 :
4011 13581 : if (specific_symbol)
4012 8277 : gfc_free_expr (expr);
4013 : else
4014 5304 : gfc_free_symbol (sym);
4015 13581 : }
4016 :
4017 : /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4018 : Implemented as
4019 : any(a)
4020 : {
4021 : forall (i=...)
4022 : if (a[i] != 0)
4023 : return 1
4024 : end forall
4025 : return 0
4026 : }
4027 : all(a)
4028 : {
4029 : forall (i=...)
4030 : if (a[i] == 0)
4031 : return 0
4032 : end forall
4033 : return 1
4034 : }
4035 : */
4036 : static void
4037 37786 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4038 : {
4039 37786 : tree resvar;
4040 37786 : stmtblock_t block;
4041 37786 : stmtblock_t body;
4042 37786 : tree type;
4043 37786 : tree tmp;
4044 37786 : tree found;
4045 37786 : gfc_loopinfo loop;
4046 37786 : gfc_actual_arglist *actual;
4047 37786 : gfc_ss *arrayss;
4048 37786 : gfc_se arrayse;
4049 37786 : tree exit_label;
4050 :
4051 37786 : if (se->ss)
4052 : {
4053 0 : gfc_conv_intrinsic_funcall (se, expr);
4054 0 : return;
4055 : }
4056 :
4057 37786 : actual = expr->value.function.actual;
4058 37786 : type = gfc_typenode_for_spec (&expr->ts);
4059 : /* Initialize the result. */
4060 37786 : resvar = gfc_create_var (type, "test");
4061 37786 : if (op == EQ_EXPR)
4062 420 : tmp = convert (type, boolean_true_node);
4063 : else
4064 37366 : tmp = convert (type, boolean_false_node);
4065 37786 : gfc_add_modify (&se->pre, resvar, tmp);
4066 :
4067 : /* Walk the arguments. */
4068 37786 : arrayss = gfc_walk_expr (actual->expr);
4069 37786 : gcc_assert (arrayss != gfc_ss_terminator);
4070 :
4071 : /* Initialize the scalarizer. */
4072 37786 : gfc_init_loopinfo (&loop);
4073 37786 : exit_label = gfc_build_label_decl (NULL_TREE);
4074 37786 : TREE_USED (exit_label) = 1;
4075 37786 : gfc_add_ss_to_loop (&loop, arrayss);
4076 :
4077 : /* Initialize the loop. */
4078 37786 : gfc_conv_ss_startstride (&loop);
4079 37786 : gfc_conv_loop_setup (&loop, &expr->where);
4080 :
4081 37786 : gfc_mark_ss_chain_used (arrayss, 1);
4082 : /* Generate the loop body. */
4083 37786 : gfc_start_scalarized_body (&loop, &body);
4084 :
4085 : /* If the condition matches then set the return value. */
4086 37786 : gfc_start_block (&block);
4087 37786 : if (op == EQ_EXPR)
4088 420 : tmp = convert (type, boolean_false_node);
4089 : else
4090 37366 : tmp = convert (type, boolean_true_node);
4091 37786 : gfc_add_modify (&block, resvar, tmp);
4092 :
4093 : /* And break out of the loop. */
4094 37786 : tmp = build1_v (GOTO_EXPR, exit_label);
4095 37786 : gfc_add_expr_to_block (&block, tmp);
4096 :
4097 37786 : found = gfc_finish_block (&block);
4098 :
4099 : /* Check this element. */
4100 37786 : gfc_init_se (&arrayse, NULL);
4101 37786 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4102 37786 : arrayse.ss = arrayss;
4103 37786 : gfc_conv_expr_val (&arrayse, actual->expr);
4104 :
4105 37786 : gfc_add_block_to_block (&body, &arrayse.pre);
4106 37786 : tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4107 37786 : build_int_cst (TREE_TYPE (arrayse.expr), 0));
4108 37786 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4109 37786 : gfc_add_expr_to_block (&body, tmp);
4110 37786 : gfc_add_block_to_block (&body, &arrayse.post);
4111 :
4112 37786 : gfc_trans_scalarizing_loops (&loop, &body);
4113 :
4114 : /* Add the exit label. */
4115 37786 : tmp = build1_v (LABEL_EXPR, exit_label);
4116 37786 : gfc_add_expr_to_block (&loop.pre, tmp);
4117 :
4118 37786 : gfc_add_block_to_block (&se->pre, &loop.pre);
4119 37786 : gfc_add_block_to_block (&se->pre, &loop.post);
4120 37786 : gfc_cleanup_loop (&loop);
4121 :
4122 37786 : se->expr = resvar;
4123 : }
4124 :
4125 :
4126 : /* Generate the constant 180 / pi, which is used in the conversion
4127 : of acosd(), asind(), atand(), atan2d(). */
4128 :
4129 : static tree
4130 336 : rad2deg (int kind)
4131 : {
4132 336 : tree retval;
4133 336 : mpfr_t pi, t0;
4134 :
4135 336 : gfc_set_model_kind (kind);
4136 336 : mpfr_init (pi);
4137 336 : mpfr_init (t0);
4138 336 : mpfr_set_si (t0, 180, GFC_RND_MODE);
4139 336 : mpfr_const_pi (pi, GFC_RND_MODE);
4140 336 : mpfr_div (t0, t0, pi, GFC_RND_MODE);
4141 336 : retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4142 336 : mpfr_clear (t0);
4143 336 : mpfr_clear (pi);
4144 336 : return retval;
4145 : }
4146 :
4147 :
4148 : static gfc_intrinsic_map_t *
4149 546 : gfc_lookup_intrinsic (gfc_isym_id id)
4150 : {
4151 546 : gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4152 11154 : for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4153 11154 : if (id == m->id)
4154 : break;
4155 546 : gcc_assert (id == m->id);
4156 546 : return m;
4157 : }
4158 :
4159 :
4160 : /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4161 : ASIND(x) is translated into ASIN(x) * 180 / pi.
4162 : ATAND(x) is translated into ATAN(x) * 180 / pi. */
4163 :
4164 : static void
4165 216 : gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4166 : {
4167 216 : tree arg;
4168 216 : tree atrigd;
4169 216 : tree type;
4170 216 : gfc_intrinsic_map_t *m;
4171 :
4172 216 : type = gfc_typenode_for_spec (&expr->ts);
4173 :
4174 216 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4175 :
4176 216 : switch (id)
4177 : {
4178 72 : case GFC_ISYM_ACOSD:
4179 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
4180 72 : break;
4181 72 : case GFC_ISYM_ASIND:
4182 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
4183 72 : break;
4184 72 : case GFC_ISYM_ATAND:
4185 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
4186 72 : break;
4187 0 : default:
4188 0 : gcc_unreachable ();
4189 : }
4190 216 : atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4191 216 : atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4192 :
4193 216 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4194 : fold_convert (type, rad2deg (expr->ts.kind)));
4195 216 : }
4196 :
4197 :
4198 : /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4199 : COS(X) / SIN(X) for COMPLEX argument. */
4200 :
4201 : static void
4202 102 : gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4203 : {
4204 102 : gfc_intrinsic_map_t *m;
4205 102 : tree arg;
4206 102 : tree type;
4207 :
4208 102 : type = gfc_typenode_for_spec (&expr->ts);
4209 102 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4210 :
4211 102 : if (expr->ts.type == BT_REAL)
4212 : {
4213 102 : tree tan;
4214 102 : tree tmp;
4215 102 : mpfr_t pio2;
4216 :
4217 : /* Create pi/2. */
4218 102 : gfc_set_model_kind (expr->ts.kind);
4219 102 : mpfr_init (pio2);
4220 102 : mpfr_const_pi (pio2, GFC_RND_MODE);
4221 102 : mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4222 102 : tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4223 102 : mpfr_clear (pio2);
4224 :
4225 : /* Find tan builtin function. */
4226 102 : m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
4227 102 : tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4228 102 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4229 102 : tan = build_call_expr_loc (input_location, tan, 1, tmp);
4230 102 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4231 : }
4232 : else
4233 : {
4234 0 : tree sin;
4235 0 : tree cos;
4236 :
4237 : /* Find cos builtin function. */
4238 0 : m = gfc_lookup_intrinsic (GFC_ISYM_COS);
4239 0 : cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4240 0 : cos = build_call_expr_loc (input_location, cos, 1, arg);
4241 :
4242 : /* Find sin builtin function. */
4243 0 : m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
4244 0 : sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4245 0 : sin = build_call_expr_loc (input_location, sin, 1, arg);
4246 :
4247 : /* Divide cos by sin. */
4248 0 : se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4249 : }
4250 102 : }
4251 :
4252 :
4253 : /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4254 :
4255 : static void
4256 108 : gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4257 : {
4258 108 : tree arg;
4259 108 : tree type;
4260 108 : tree ninety_tree;
4261 108 : mpfr_t ninety;
4262 :
4263 108 : type = gfc_typenode_for_spec (&expr->ts);
4264 108 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4265 :
4266 108 : gfc_set_model_kind (expr->ts.kind);
4267 :
4268 : /* Build the tree for x + 90. */
4269 108 : mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4270 108 : ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4271 108 : arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4272 108 : mpfr_clear (ninety);
4273 :
4274 : /* Find tand. */
4275 108 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
4276 108 : tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4277 108 : tand = build_call_expr_loc (input_location, tand, 1, arg);
4278 :
4279 108 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4280 108 : }
4281 :
4282 :
4283 : /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4284 :
4285 : static void
4286 120 : gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4287 : {
4288 120 : tree args[2];
4289 120 : tree atan2d;
4290 120 : tree type;
4291 :
4292 120 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
4293 120 : type = TREE_TYPE (args[0]);
4294 :
4295 120 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
4296 120 : atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4297 120 : atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4298 :
4299 120 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4300 : rad2deg (expr->ts.kind));
4301 120 : }
4302 :
4303 :
4304 : /* COUNT(A) = Number of true elements in A. */
4305 : static void
4306 143 : gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4307 : {
4308 143 : tree resvar;
4309 143 : tree type;
4310 143 : stmtblock_t body;
4311 143 : tree tmp;
4312 143 : gfc_loopinfo loop;
4313 143 : gfc_actual_arglist *actual;
4314 143 : gfc_ss *arrayss;
4315 143 : gfc_se arrayse;
4316 :
4317 143 : if (se->ss)
4318 : {
4319 0 : gfc_conv_intrinsic_funcall (se, expr);
4320 0 : return;
4321 : }
4322 :
4323 143 : actual = expr->value.function.actual;
4324 :
4325 143 : type = gfc_typenode_for_spec (&expr->ts);
4326 : /* Initialize the result. */
4327 143 : resvar = gfc_create_var (type, "count");
4328 143 : gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4329 :
4330 : /* Walk the arguments. */
4331 143 : arrayss = gfc_walk_expr (actual->expr);
4332 143 : gcc_assert (arrayss != gfc_ss_terminator);
4333 :
4334 : /* Initialize the scalarizer. */
4335 143 : gfc_init_loopinfo (&loop);
4336 143 : gfc_add_ss_to_loop (&loop, arrayss);
4337 :
4338 : /* Initialize the loop. */
4339 143 : gfc_conv_ss_startstride (&loop);
4340 143 : gfc_conv_loop_setup (&loop, &expr->where);
4341 :
4342 143 : gfc_mark_ss_chain_used (arrayss, 1);
4343 : /* Generate the loop body. */
4344 143 : gfc_start_scalarized_body (&loop, &body);
4345 :
4346 143 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4347 143 : resvar, build_int_cst (TREE_TYPE (resvar), 1));
4348 143 : tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4349 :
4350 143 : gfc_init_se (&arrayse, NULL);
4351 143 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4352 143 : arrayse.ss = arrayss;
4353 143 : gfc_conv_expr_val (&arrayse, actual->expr);
4354 143 : tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4355 : build_empty_stmt (input_location));
4356 :
4357 143 : gfc_add_block_to_block (&body, &arrayse.pre);
4358 143 : gfc_add_expr_to_block (&body, tmp);
4359 143 : gfc_add_block_to_block (&body, &arrayse.post);
4360 :
4361 143 : gfc_trans_scalarizing_loops (&loop, &body);
4362 :
4363 143 : gfc_add_block_to_block (&se->pre, &loop.pre);
4364 143 : gfc_add_block_to_block (&se->pre, &loop.post);
4365 143 : gfc_cleanup_loop (&loop);
4366 :
4367 143 : se->expr = resvar;
4368 : }
4369 :
4370 :
4371 : /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4372 : struct and return the corresponding loopinfo. */
4373 :
4374 : static gfc_loopinfo *
4375 3374 : enter_nested_loop (gfc_se *se)
4376 : {
4377 3374 : se->ss = se->ss->nested_ss;
4378 3374 : gcc_assert (se->ss == se->ss->loop->ss);
4379 :
4380 3374 : return se->ss->loop;
4381 : }
4382 :
4383 : /* Build the condition for a mask, which may be optional. */
4384 :
4385 : static tree
4386 12763 : conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4387 : bool optional_mask)
4388 : {
4389 12763 : tree present;
4390 12763 : tree type;
4391 :
4392 12763 : if (optional_mask)
4393 : {
4394 206 : type = TREE_TYPE (maskse->expr);
4395 206 : present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4396 206 : present = convert (type, present);
4397 206 : present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4398 : present);
4399 206 : return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4400 206 : type, present, maskse->expr);
4401 : }
4402 : else
4403 12557 : return maskse->expr;
4404 : }
4405 :
4406 : /* Inline implementation of the sum and product intrinsics. */
4407 : static void
4408 2501 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4409 : bool norm2)
4410 : {
4411 2501 : tree resvar;
4412 2501 : tree scale = NULL_TREE;
4413 2501 : tree type;
4414 2501 : stmtblock_t body;
4415 2501 : stmtblock_t block;
4416 2501 : tree tmp;
4417 2501 : gfc_loopinfo loop, *ploop;
4418 2501 : gfc_actual_arglist *arg_array, *arg_mask;
4419 2501 : gfc_ss *arrayss = NULL;
4420 2501 : gfc_ss *maskss = NULL;
4421 2501 : gfc_se arrayse;
4422 2501 : gfc_se maskse;
4423 2501 : gfc_se *parent_se;
4424 2501 : gfc_expr *arrayexpr;
4425 2501 : gfc_expr *maskexpr;
4426 2501 : bool optional_mask;
4427 :
4428 2501 : if (expr->rank > 0)
4429 : {
4430 578 : gcc_assert (gfc_inline_intrinsic_function_p (expr));
4431 : parent_se = se;
4432 : }
4433 : else
4434 : parent_se = NULL;
4435 :
4436 2501 : type = gfc_typenode_for_spec (&expr->ts);
4437 : /* Initialize the result. */
4438 2501 : resvar = gfc_create_var (type, "val");
4439 2501 : if (norm2)
4440 : {
4441 : /* result = 0.0;
4442 : scale = 1.0. */
4443 68 : scale = gfc_create_var (type, "scale");
4444 68 : gfc_add_modify (&se->pre, scale,
4445 : gfc_build_const (type, integer_one_node));
4446 68 : tmp = gfc_build_const (type, integer_zero_node);
4447 : }
4448 2433 : else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4449 2027 : tmp = gfc_build_const (type, integer_zero_node);
4450 406 : else if (op == NE_EXPR)
4451 : /* PARITY. */
4452 36 : tmp = convert (type, boolean_false_node);
4453 370 : else if (op == BIT_AND_EXPR)
4454 24 : tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4455 : type, integer_one_node));
4456 : else
4457 346 : tmp = gfc_build_const (type, integer_one_node);
4458 :
4459 2501 : gfc_add_modify (&se->pre, resvar, tmp);
4460 :
4461 2501 : arg_array = expr->value.function.actual;
4462 :
4463 2501 : arrayexpr = arg_array->expr;
4464 :
4465 2501 : if (op == NE_EXPR || norm2)
4466 : {
4467 : /* PARITY and NORM2. */
4468 : maskexpr = NULL;
4469 : optional_mask = false;
4470 : }
4471 : else
4472 : {
4473 2397 : arg_mask = arg_array->next->next;
4474 2397 : gcc_assert (arg_mask != NULL);
4475 2397 : maskexpr = arg_mask->expr;
4476 371 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4477 266 : && maskexpr->symtree->n.sym->attr.dummy
4478 2415 : && maskexpr->symtree->n.sym->attr.optional;
4479 : }
4480 :
4481 2501 : if (expr->rank == 0)
4482 : {
4483 : /* Walk the arguments. */
4484 1923 : arrayss = gfc_walk_expr (arrayexpr);
4485 1923 : gcc_assert (arrayss != gfc_ss_terminator);
4486 :
4487 1923 : if (maskexpr && maskexpr->rank > 0)
4488 : {
4489 223 : maskss = gfc_walk_expr (maskexpr);
4490 223 : gcc_assert (maskss != gfc_ss_terminator);
4491 : }
4492 : else
4493 : maskss = NULL;
4494 :
4495 : /* Initialize the scalarizer. */
4496 1923 : gfc_init_loopinfo (&loop);
4497 :
4498 : /* We add the mask first because the number of iterations is
4499 : taken from the last ss, and this breaks if an absent
4500 : optional argument is used for mask. */
4501 :
4502 1923 : if (maskexpr && maskexpr->rank > 0)
4503 223 : gfc_add_ss_to_loop (&loop, maskss);
4504 1923 : gfc_add_ss_to_loop (&loop, arrayss);
4505 :
4506 : /* Initialize the loop. */
4507 1923 : gfc_conv_ss_startstride (&loop);
4508 1923 : gfc_conv_loop_setup (&loop, &expr->where);
4509 :
4510 1923 : if (maskexpr && maskexpr->rank > 0)
4511 223 : gfc_mark_ss_chain_used (maskss, 1);
4512 1923 : gfc_mark_ss_chain_used (arrayss, 1);
4513 :
4514 1923 : ploop = &loop;
4515 : }
4516 : else
4517 : /* All the work has been done in the parent loops. */
4518 578 : ploop = enter_nested_loop (se);
4519 :
4520 2501 : gcc_assert (ploop);
4521 :
4522 : /* Generate the loop body. */
4523 2501 : gfc_start_scalarized_body (ploop, &body);
4524 :
4525 : /* If we have a mask, only add this element if the mask is set. */
4526 2501 : if (maskexpr && maskexpr->rank > 0)
4527 : {
4528 307 : gfc_init_se (&maskse, parent_se);
4529 307 : gfc_copy_loopinfo_to_se (&maskse, ploop);
4530 307 : if (expr->rank == 0)
4531 223 : maskse.ss = maskss;
4532 307 : gfc_conv_expr_val (&maskse, maskexpr);
4533 307 : gfc_add_block_to_block (&body, &maskse.pre);
4534 :
4535 307 : gfc_start_block (&block);
4536 : }
4537 : else
4538 2194 : gfc_init_block (&block);
4539 :
4540 : /* Do the actual summation/product. */
4541 2501 : gfc_init_se (&arrayse, parent_se);
4542 2501 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
4543 2501 : if (expr->rank == 0)
4544 1923 : arrayse.ss = arrayss;
4545 2501 : gfc_conv_expr_val (&arrayse, arrayexpr);
4546 2501 : gfc_add_block_to_block (&block, &arrayse.pre);
4547 :
4548 2501 : if (norm2)
4549 : {
4550 : /* if (x (i) != 0.0)
4551 : {
4552 : absX = abs(x(i))
4553 : if (absX > scale)
4554 : {
4555 : val = scale/absX;
4556 : result = 1.0 + result * val * val;
4557 : scale = absX;
4558 : }
4559 : else
4560 : {
4561 : val = absX/scale;
4562 : result += val * val;
4563 : }
4564 : } */
4565 68 : tree res1, res2, cond, absX, val;
4566 68 : stmtblock_t ifblock1, ifblock2, ifblock3;
4567 :
4568 68 : gfc_init_block (&ifblock1);
4569 :
4570 68 : absX = gfc_create_var (type, "absX");
4571 68 : gfc_add_modify (&ifblock1, absX,
4572 : fold_build1_loc (input_location, ABS_EXPR, type,
4573 : arrayse.expr));
4574 68 : val = gfc_create_var (type, "val");
4575 68 : gfc_add_expr_to_block (&ifblock1, val);
4576 :
4577 68 : gfc_init_block (&ifblock2);
4578 68 : gfc_add_modify (&ifblock2, val,
4579 : fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4580 : absX));
4581 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4582 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4583 68 : res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4584 : gfc_build_const (type, integer_one_node));
4585 68 : gfc_add_modify (&ifblock2, resvar, res1);
4586 68 : gfc_add_modify (&ifblock2, scale, absX);
4587 68 : res1 = gfc_finish_block (&ifblock2);
4588 :
4589 68 : gfc_init_block (&ifblock3);
4590 68 : gfc_add_modify (&ifblock3, val,
4591 : fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4592 : scale));
4593 68 : res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4594 68 : res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4595 68 : gfc_add_modify (&ifblock3, resvar, res2);
4596 68 : res2 = gfc_finish_block (&ifblock3);
4597 :
4598 68 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4599 : absX, scale);
4600 68 : tmp = build3_v (COND_EXPR, cond, res1, res2);
4601 68 : gfc_add_expr_to_block (&ifblock1, tmp);
4602 68 : tmp = gfc_finish_block (&ifblock1);
4603 :
4604 68 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4605 : arrayse.expr,
4606 : gfc_build_const (type, integer_zero_node));
4607 :
4608 68 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4609 68 : gfc_add_expr_to_block (&block, tmp);
4610 : }
4611 : else
4612 : {
4613 2433 : tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4614 2433 : gfc_add_modify (&block, resvar, tmp);
4615 : }
4616 :
4617 2501 : gfc_add_block_to_block (&block, &arrayse.post);
4618 :
4619 2501 : if (maskexpr && maskexpr->rank > 0)
4620 : {
4621 : /* We enclose the above in if (mask) {...} . If the mask is an
4622 : optional argument, generate
4623 : IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4624 307 : tree ifmask;
4625 307 : tmp = gfc_finish_block (&block);
4626 307 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4627 307 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4628 : build_empty_stmt (input_location));
4629 307 : }
4630 : else
4631 2194 : tmp = gfc_finish_block (&block);
4632 2501 : gfc_add_expr_to_block (&body, tmp);
4633 :
4634 2501 : gfc_trans_scalarizing_loops (ploop, &body);
4635 :
4636 : /* For a scalar mask, enclose the loop in an if statement. */
4637 2501 : if (maskexpr && maskexpr->rank == 0)
4638 : {
4639 64 : gfc_init_block (&block);
4640 64 : gfc_add_block_to_block (&block, &ploop->pre);
4641 64 : gfc_add_block_to_block (&block, &ploop->post);
4642 64 : tmp = gfc_finish_block (&block);
4643 :
4644 64 : if (expr->rank > 0)
4645 : {
4646 34 : tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4647 : build_empty_stmt (input_location));
4648 34 : gfc_advance_se_ss_chain (se);
4649 : }
4650 : else
4651 : {
4652 30 : tree ifmask;
4653 :
4654 30 : gcc_assert (expr->rank == 0);
4655 30 : gfc_init_se (&maskse, NULL);
4656 30 : gfc_conv_expr_val (&maskse, maskexpr);
4657 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4658 30 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4659 : build_empty_stmt (input_location));
4660 : }
4661 :
4662 64 : gfc_add_expr_to_block (&block, tmp);
4663 64 : gfc_add_block_to_block (&se->pre, &block);
4664 64 : gcc_assert (se->post.head == NULL);
4665 : }
4666 : else
4667 : {
4668 2437 : gfc_add_block_to_block (&se->pre, &ploop->pre);
4669 2437 : gfc_add_block_to_block (&se->pre, &ploop->post);
4670 : }
4671 :
4672 2501 : if (expr->rank == 0)
4673 1923 : gfc_cleanup_loop (ploop);
4674 :
4675 2501 : if (norm2)
4676 : {
4677 : /* result = scale * sqrt(result). */
4678 68 : tree sqrt;
4679 68 : sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4680 68 : resvar = build_call_expr_loc (input_location,
4681 : sqrt, 1, resvar);
4682 68 : resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4683 : }
4684 :
4685 2501 : se->expr = resvar;
4686 2501 : }
4687 :
4688 :
4689 : /* Inline implementation of the dot_product intrinsic. This function
4690 : is based on gfc_conv_intrinsic_arith (the previous function). */
4691 : static void
4692 113 : gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4693 : {
4694 113 : tree resvar;
4695 113 : tree type;
4696 113 : stmtblock_t body;
4697 113 : stmtblock_t block;
4698 113 : tree tmp;
4699 113 : gfc_loopinfo loop;
4700 113 : gfc_actual_arglist *actual;
4701 113 : gfc_ss *arrayss1, *arrayss2;
4702 113 : gfc_se arrayse1, arrayse2;
4703 113 : gfc_expr *arrayexpr1, *arrayexpr2;
4704 :
4705 113 : type = gfc_typenode_for_spec (&expr->ts);
4706 :
4707 : /* Initialize the result. */
4708 113 : resvar = gfc_create_var (type, "val");
4709 113 : if (expr->ts.type == BT_LOGICAL)
4710 30 : tmp = build_int_cst (type, 0);
4711 : else
4712 83 : tmp = gfc_build_const (type, integer_zero_node);
4713 :
4714 113 : gfc_add_modify (&se->pre, resvar, tmp);
4715 :
4716 : /* Walk argument #1. */
4717 113 : actual = expr->value.function.actual;
4718 113 : arrayexpr1 = actual->expr;
4719 113 : arrayss1 = gfc_walk_expr (arrayexpr1);
4720 113 : gcc_assert (arrayss1 != gfc_ss_terminator);
4721 :
4722 : /* Walk argument #2. */
4723 113 : actual = actual->next;
4724 113 : arrayexpr2 = actual->expr;
4725 113 : arrayss2 = gfc_walk_expr (arrayexpr2);
4726 113 : gcc_assert (arrayss2 != gfc_ss_terminator);
4727 :
4728 : /* Initialize the scalarizer. */
4729 113 : gfc_init_loopinfo (&loop);
4730 113 : gfc_add_ss_to_loop (&loop, arrayss1);
4731 113 : gfc_add_ss_to_loop (&loop, arrayss2);
4732 :
4733 : /* Initialize the loop. */
4734 113 : gfc_conv_ss_startstride (&loop);
4735 113 : gfc_conv_loop_setup (&loop, &expr->where);
4736 :
4737 113 : gfc_mark_ss_chain_used (arrayss1, 1);
4738 113 : gfc_mark_ss_chain_used (arrayss2, 1);
4739 :
4740 : /* Generate the loop body. */
4741 113 : gfc_start_scalarized_body (&loop, &body);
4742 113 : gfc_init_block (&block);
4743 :
4744 : /* Make the tree expression for [conjg(]array1[)]. */
4745 113 : gfc_init_se (&arrayse1, NULL);
4746 113 : gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4747 113 : arrayse1.ss = arrayss1;
4748 113 : gfc_conv_expr_val (&arrayse1, arrayexpr1);
4749 113 : if (expr->ts.type == BT_COMPLEX)
4750 9 : arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4751 : arrayse1.expr);
4752 113 : gfc_add_block_to_block (&block, &arrayse1.pre);
4753 :
4754 : /* Make the tree expression for array2. */
4755 113 : gfc_init_se (&arrayse2, NULL);
4756 113 : gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4757 113 : arrayse2.ss = arrayss2;
4758 113 : gfc_conv_expr_val (&arrayse2, arrayexpr2);
4759 113 : gfc_add_block_to_block (&block, &arrayse2.pre);
4760 :
4761 : /* Do the actual product and sum. */
4762 113 : if (expr->ts.type == BT_LOGICAL)
4763 : {
4764 30 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4765 : arrayse1.expr, arrayse2.expr);
4766 30 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4767 : }
4768 : else
4769 : {
4770 83 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4771 : arrayse2.expr);
4772 83 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4773 : }
4774 113 : gfc_add_modify (&block, resvar, tmp);
4775 :
4776 : /* Finish up the loop block and the loop. */
4777 113 : tmp = gfc_finish_block (&block);
4778 113 : gfc_add_expr_to_block (&body, tmp);
4779 :
4780 113 : gfc_trans_scalarizing_loops (&loop, &body);
4781 113 : gfc_add_block_to_block (&se->pre, &loop.pre);
4782 113 : gfc_add_block_to_block (&se->pre, &loop.post);
4783 113 : gfc_cleanup_loop (&loop);
4784 :
4785 113 : se->expr = resvar;
4786 113 : }
4787 :
4788 :
4789 : /* Tells whether the expression E is a reference to an optional variable whose
4790 : presence is not known at compile time. Those are variable references without
4791 : subreference; if there is a subreference, we can assume the variable is
4792 : present. We have to special case full arrays, which we represent with a fake
4793 : "full" reference, and class descriptors for which a reference to data is not
4794 : really a subreference. */
4795 :
4796 : bool
4797 14613 : maybe_absent_optional_variable (gfc_expr *e)
4798 : {
4799 14613 : if (!(e && e->expr_type == EXPR_VARIABLE))
4800 : return false;
4801 :
4802 1716 : gfc_symbol *sym = e->symtree->n.sym;
4803 1716 : if (!sym->attr.optional)
4804 : return false;
4805 :
4806 224 : gfc_ref *ref = e->ref;
4807 224 : if (ref == nullptr)
4808 : return true;
4809 :
4810 20 : if (ref->type == REF_ARRAY
4811 20 : && ref->u.ar.type == AR_FULL
4812 20 : && ref->next == nullptr)
4813 : return true;
4814 :
4815 0 : if (!(sym->ts.type == BT_CLASS
4816 0 : && ref->type == REF_COMPONENT
4817 0 : && ref->u.c.component == CLASS_DATA (sym)))
4818 : return false;
4819 :
4820 0 : gfc_ref *next_ref = ref->next;
4821 0 : if (next_ref == nullptr)
4822 : return true;
4823 :
4824 0 : if (next_ref->type == REF_ARRAY
4825 0 : && next_ref->u.ar.type == AR_FULL
4826 0 : && next_ref->next == nullptr)
4827 0 : return true;
4828 :
4829 : return false;
4830 : }
4831 :
4832 :
4833 : /* Emit code for minloc or maxloc intrinsic. There are many different cases
4834 : we need to handle. For performance reasons we sometimes create two
4835 : loops instead of one, where the second one is much simpler.
4836 : Examples for minloc intrinsic:
4837 : A: Result is scalar.
4838 : 1) Array mask is used and NaNs need to be supported:
4839 : limit = Infinity;
4840 : pos = 0;
4841 : S = from;
4842 : while (S <= to) {
4843 : if (mask[S]) {
4844 : if (pos == 0) pos = S + (1 - from);
4845 : if (a[S] <= limit) {
4846 : limit = a[S];
4847 : pos = S + (1 - from);
4848 : goto lab1;
4849 : }
4850 : }
4851 : S++;
4852 : }
4853 : goto lab2;
4854 : lab1:;
4855 : while (S <= to) {
4856 : if (mask[S])
4857 : if (a[S] < limit) {
4858 : limit = a[S];
4859 : pos = S + (1 - from);
4860 : }
4861 : S++;
4862 : }
4863 : lab2:;
4864 : 2) NaNs need to be supported, but it is known at compile time or cheaply
4865 : at runtime whether array is nonempty or not:
4866 : limit = Infinity;
4867 : pos = 0;
4868 : S = from;
4869 : while (S <= to) {
4870 : if (a[S] <= limit) {
4871 : limit = a[S];
4872 : pos = S + (1 - from);
4873 : goto lab1;
4874 : }
4875 : S++;
4876 : }
4877 : if (from <= to) pos = 1;
4878 : goto lab2;
4879 : lab1:;
4880 : while (S <= to) {
4881 : if (a[S] < limit) {
4882 : limit = a[S];
4883 : pos = S + (1 - from);
4884 : }
4885 : S++;
4886 : }
4887 : lab2:;
4888 : 3) NaNs aren't supported, array mask is used:
4889 : limit = infinities_supported ? Infinity : huge (limit);
4890 : pos = 0;
4891 : S = from;
4892 : while (S <= to) {
4893 : if (mask[S]) {
4894 : limit = a[S];
4895 : pos = S + (1 - from);
4896 : goto lab1;
4897 : }
4898 : S++;
4899 : }
4900 : goto lab2;
4901 : lab1:;
4902 : while (S <= to) {
4903 : if (mask[S])
4904 : if (a[S] < limit) {
4905 : limit = a[S];
4906 : pos = S + (1 - from);
4907 : }
4908 : S++;
4909 : }
4910 : lab2:;
4911 : 4) Same without array mask:
4912 : limit = infinities_supported ? Infinity : huge (limit);
4913 : pos = (from <= to) ? 1 : 0;
4914 : S = from;
4915 : while (S <= to) {
4916 : if (a[S] < limit) {
4917 : limit = a[S];
4918 : pos = S + (1 - from);
4919 : }
4920 : S++;
4921 : }
4922 : B: Array result, non-CHARACTER type, DIM absent
4923 : Generate similar code as in the scalar case, using a collection of
4924 : variables (one per dimension) instead of a single variable as result.
4925 : Picking only cases 1) and 4) with ARRAY of rank 2, the generated code
4926 : becomes:
4927 : 1) Array mask is used and NaNs need to be supported:
4928 : limit = Infinity;
4929 : pos0 = 0;
4930 : pos1 = 0;
4931 : S1 = from1;
4932 : second_loop_entry = false;
4933 : while (S1 <= to1) {
4934 : S0 = from0;
4935 : while (s0 <= to0 {
4936 : if (mask[S1][S0]) {
4937 : if (pos0 == 0) {
4938 : pos0 = S0 + (1 - from0);
4939 : pos1 = S1 + (1 - from1);
4940 : }
4941 : if (a[S1][S0] <= limit) {
4942 : limit = a[S1][S0];
4943 : pos0 = S0 + (1 - from0);
4944 : pos1 = S1 + (1 - from1);
4945 : second_loop_entry = true;
4946 : goto lab1;
4947 : }
4948 : }
4949 : S0++;
4950 : }
4951 : S1++;
4952 : }
4953 : goto lab2;
4954 : lab1:;
4955 : S1 = second_loop_entry ? S1 : from1;
4956 : while (S1 <= to1) {
4957 : S0 = second_loop_entry ? S0 : from0;
4958 : while (S0 <= to0) {
4959 : if (mask[S1][S0])
4960 : if (a[S1][S0] < limit) {
4961 : limit = a[S1][S0];
4962 : pos0 = S + (1 - from0);
4963 : pos1 = S + (1 - from1);
4964 : }
4965 : second_loop_entry = false;
4966 : S0++;
4967 : }
4968 : S1++;
4969 : }
4970 : lab2:;
4971 : result = { pos0, pos1 };
4972 : ...
4973 : 4) NANs aren't supported, no array mask.
4974 : limit = infinities_supported ? Infinity : huge (limit);
4975 : pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4976 : pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4977 : S1 = from1;
4978 : while (S1 <= to1) {
4979 : S0 = from0;
4980 : while (S0 <= to0) {
4981 : if (a[S1][S0] < limit) {
4982 : limit = a[S1][S0];
4983 : pos0 = S + (1 - from0);
4984 : pos1 = S + (1 - from1);
4985 : }
4986 : S0++;
4987 : }
4988 : S1++;
4989 : }
4990 : result = { pos0, pos1 };
4991 : C: Otherwise, a call is generated.
4992 : For 2) and 4), if mask is scalar, this all goes into a conditional,
4993 : setting pos = 0; in the else branch.
4994 :
4995 : Since we now also support the BACK argument, instead of using
4996 : if (a[S] < limit), we now use
4997 :
4998 : if (back)
4999 : cond = a[S] <= limit;
5000 : else
5001 : cond = a[S] < limit;
5002 : if (cond) {
5003 : ....
5004 :
5005 : The optimizer is smart enough to move the condition out of the loop.
5006 : They are now marked as unlikely too for further speedup. */
5007 :
5008 : static void
5009 18898 : gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5010 : {
5011 18898 : stmtblock_t body;
5012 18898 : stmtblock_t block;
5013 18898 : stmtblock_t ifblock;
5014 18898 : stmtblock_t elseblock;
5015 18898 : tree limit;
5016 18898 : tree type;
5017 18898 : tree tmp;
5018 18898 : tree cond;
5019 18898 : tree elsetmp;
5020 18898 : tree ifbody;
5021 18898 : tree offset[GFC_MAX_DIMENSIONS];
5022 18898 : tree nonempty;
5023 18898 : tree lab1, lab2;
5024 18898 : tree b_if, b_else;
5025 18898 : tree back;
5026 18898 : gfc_loopinfo loop, *ploop;
5027 18898 : gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg;
5028 18898 : gfc_actual_arglist *back_arg;
5029 18898 : gfc_ss *arrayss = nullptr;
5030 18898 : gfc_ss *maskss = nullptr;
5031 18898 : gfc_ss *orig_ss = nullptr;
5032 18898 : gfc_se arrayse;
5033 18898 : gfc_se maskse;
5034 18898 : gfc_se nested_se;
5035 18898 : gfc_se *base_se;
5036 18898 : gfc_expr *arrayexpr;
5037 18898 : gfc_expr *maskexpr;
5038 18898 : gfc_expr *backexpr;
5039 18898 : gfc_se backse;
5040 18898 : tree pos[GFC_MAX_DIMENSIONS];
5041 18898 : tree idx[GFC_MAX_DIMENSIONS];
5042 18898 : tree result_var = NULL_TREE;
5043 18898 : int n;
5044 18898 : bool optional_mask;
5045 :
5046 18898 : array_arg = expr->value.function.actual;
5047 18898 : dim_arg = array_arg->next;
5048 18898 : mask_arg = dim_arg->next;
5049 18898 : kind_arg = mask_arg->next;
5050 18898 : back_arg = kind_arg->next;
5051 :
5052 18898 : bool dim_present = dim_arg->expr != nullptr;
5053 18898 : bool nested_loop = dim_present && expr->rank > 0;
5054 :
5055 : /* Remove kind. */
5056 18898 : if (kind_arg->expr)
5057 : {
5058 2240 : gfc_free_expr (kind_arg->expr);
5059 2240 : kind_arg->expr = NULL;
5060 : }
5061 :
5062 : /* Pass BACK argument by value. */
5063 18898 : back_arg->name = "%VAL";
5064 :
5065 18898 : if (se->ss)
5066 : {
5067 14732 : if (se->ss->info->useflags)
5068 : {
5069 7671 : if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
5070 : {
5071 : /* The code generating and initializing the result array has been
5072 : generated already before the scalarization loop, either with a
5073 : library function call or with inline code; now we can just use
5074 : the result. */
5075 4875 : gfc_conv_tmp_array_ref (se);
5076 13822 : return;
5077 : }
5078 : }
5079 7061 : else if (!gfc_inline_intrinsic_function_p (expr))
5080 : {
5081 3780 : gfc_conv_intrinsic_funcall (se, expr);
5082 3780 : return;
5083 : }
5084 : }
5085 :
5086 10243 : arrayexpr = array_arg->expr;
5087 :
5088 : /* Special case for character maxloc. Remove unneeded "dim" actual
5089 : argument, then call a library function. */
5090 :
5091 10243 : if (arrayexpr->ts.type == BT_CHARACTER)
5092 : {
5093 292 : gcc_assert (expr->rank == 0);
5094 :
5095 292 : if (dim_arg->expr)
5096 : {
5097 292 : gfc_free_expr (dim_arg->expr);
5098 292 : dim_arg->expr = NULL;
5099 : }
5100 292 : gfc_conv_intrinsic_funcall (se, expr);
5101 292 : return;
5102 : }
5103 :
5104 9951 : type = gfc_typenode_for_spec (&expr->ts);
5105 :
5106 9951 : if (expr->rank > 0 && !dim_present)
5107 : {
5108 3281 : gfc_array_spec as;
5109 3281 : memset (&as, 0, sizeof (as));
5110 :
5111 3281 : as.rank = 1;
5112 3281 : as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5113 : &arrayexpr->where,
5114 : HOST_WIDE_INT_1);
5115 6562 : as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind,
5116 : &arrayexpr->where,
5117 3281 : arrayexpr->rank);
5118 :
5119 3281 : tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
5120 :
5121 3281 : result_var = gfc_create_var (array, "loc_result");
5122 : }
5123 :
5124 7155 : const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
5125 :
5126 : /* Initialize the result. */
5127 22177 : for (int i = 0; i < reduction_dimensions; i++)
5128 : {
5129 12226 : pos[i] = gfc_create_var (gfc_array_index_type,
5130 : gfc_get_string ("pos%d", i));
5131 12226 : offset[i] = gfc_create_var (gfc_array_index_type,
5132 : gfc_get_string ("offset%d", i));
5133 12226 : idx[i] = gfc_create_var (gfc_array_index_type,
5134 : gfc_get_string ("idx%d", i));
5135 : }
5136 :
5137 9951 : maskexpr = mask_arg->expr;
5138 6518 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5139 5329 : && maskexpr->symtree->n.sym->attr.dummy
5140 10116 : && maskexpr->symtree->n.sym->attr.optional;
5141 9951 : backexpr = back_arg->expr;
5142 :
5143 17106 : gfc_init_se (&backse, nested_loop ? se : nullptr);
5144 9951 : if (backexpr == nullptr)
5145 0 : back = logical_false_node;
5146 9951 : else if (maybe_absent_optional_variable (backexpr))
5147 : {
5148 : /* This should have been checked already by
5149 : maybe_absent_optional_variable. */
5150 184 : gcc_checking_assert (backexpr->expr_type == EXPR_VARIABLE);
5151 :
5152 184 : gfc_conv_expr (&backse, backexpr);
5153 184 : tree present = gfc_conv_expr_present (backexpr->symtree->n.sym, false);
5154 184 : back = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5155 : logical_type_node, present, backse.expr);
5156 : }
5157 : else
5158 : {
5159 9767 : gfc_conv_expr (&backse, backexpr);
5160 9767 : back = backse.expr;
5161 : }
5162 9951 : gfc_add_block_to_block (&se->pre, &backse.pre);
5163 9951 : back = gfc_evaluate_now_loc (input_location, back, &se->pre);
5164 9951 : gfc_add_block_to_block (&se->pre, &backse.post);
5165 :
5166 9951 : if (nested_loop)
5167 : {
5168 2796 : gfc_init_se (&nested_se, se);
5169 2796 : base_se = &nested_se;
5170 : }
5171 : else
5172 : {
5173 : /* Walk the arguments. */
5174 7155 : arrayss = gfc_walk_expr (arrayexpr);
5175 7155 : gcc_assert (arrayss != gfc_ss_terminator);
5176 :
5177 7155 : if (maskexpr && maskexpr->rank != 0)
5178 : {
5179 2700 : maskss = gfc_walk_expr (maskexpr);
5180 2700 : gcc_assert (maskss != gfc_ss_terminator);
5181 : }
5182 :
5183 : base_se = nullptr;
5184 : }
5185 :
5186 18091 : nonempty = nullptr;
5187 7448 : if (!(maskexpr && maskexpr->rank > 0))
5188 : {
5189 6077 : mpz_t asize;
5190 6077 : bool reduction_size_known;
5191 :
5192 6077 : if (dim_present)
5193 : {
5194 4032 : int reduction_dim;
5195 4032 : if (dim_arg->expr->expr_type == EXPR_CONSTANT)
5196 4030 : reduction_dim = mpz_get_si (dim_arg->expr->value.integer) - 1;
5197 2 : else if (arrayexpr->rank == 1)
5198 : reduction_dim = 0;
5199 : else
5200 0 : gcc_unreachable ();
5201 4032 : reduction_size_known = gfc_array_dimen_size (arrayexpr, reduction_dim,
5202 : &asize);
5203 : }
5204 : else
5205 2045 : reduction_size_known = gfc_array_size (arrayexpr, &asize);
5206 :
5207 6077 : if (reduction_size_known)
5208 : {
5209 4482 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5210 4482 : mpz_clear (asize);
5211 4482 : nonempty = fold_build2_loc (input_location, GT_EXPR,
5212 : logical_type_node, nonempty,
5213 : gfc_index_zero_node);
5214 : }
5215 6077 : maskss = NULL;
5216 : }
5217 :
5218 9951 : limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5219 9951 : switch (arrayexpr->ts.type)
5220 : {
5221 3898 : case BT_REAL:
5222 3898 : tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5223 3898 : break;
5224 :
5225 6029 : case BT_INTEGER:
5226 6029 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5227 6029 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5228 : arrayexpr->ts.kind);
5229 6029 : break;
5230 :
5231 24 : case BT_UNSIGNED:
5232 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
5233 24 : if (op == GT_EXPR)
5234 : {
5235 12 : tmp = gfc_get_unsigned_type (arrayexpr->ts.kind);
5236 12 : tmp = build_int_cst (tmp, 0);
5237 : }
5238 : else
5239 : {
5240 12 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5241 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
5242 : expr->ts.kind);
5243 : }
5244 : break;
5245 :
5246 0 : default:
5247 0 : gcc_unreachable ();
5248 : }
5249 :
5250 : /* We start with the most negative possible value for MAXLOC, and the most
5251 : positive possible value for MINLOC. The most negative possible value is
5252 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5253 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
5254 : with above. */
5255 9951 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
5256 4724 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5257 4724 : if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5258 2914 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5259 2914 : build_int_cst (TREE_TYPE (tmp), 1));
5260 :
5261 9951 : gfc_add_modify (&se->pre, limit, tmp);
5262 :
5263 : /* If we are in a case where we generate two sets of loops, the second one
5264 : should continue where the first stopped instead of restarting from the
5265 : beginning. So nested loops in the second set should have a partial range
5266 : on the first iteration, but they should start from the beginning and span
5267 : their full range on the following iterations. So we use conditionals in
5268 : the loops lower bounds, and use the following variable in those
5269 : conditionals to decide whether to use the original loop bound or to use
5270 : the index at which the loop from the first set stopped. */
5271 9951 : tree second_loop_entry = gfc_create_var (logical_type_node,
5272 : "second_loop_entry");
5273 9951 : gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
5274 :
5275 9951 : if (nested_loop)
5276 : {
5277 2796 : ploop = enter_nested_loop (&nested_se);
5278 2796 : orig_ss = nested_se.ss;
5279 2796 : ploop->temp_dim = 1;
5280 : }
5281 : else
5282 : {
5283 : /* Initialize the scalarizer. */
5284 7155 : gfc_init_loopinfo (&loop);
5285 :
5286 : /* We add the mask first because the number of iterations is taken
5287 : from the last ss, and this breaks if an absent optional argument
5288 : is used for mask. */
5289 :
5290 7155 : if (maskss)
5291 2700 : gfc_add_ss_to_loop (&loop, maskss);
5292 :
5293 7155 : gfc_add_ss_to_loop (&loop, arrayss);
5294 :
5295 : /* Initialize the loop. */
5296 7155 : gfc_conv_ss_startstride (&loop);
5297 :
5298 : /* The code generated can have more than one loop in sequence (see the
5299 : comment at the function header). This doesn't work well with the
5300 : scalarizer, which changes arrays' offset when the scalarization loops
5301 : are generated (see gfc_trans_preloop_setup). Fortunately, we can use
5302 : the scalarizer temporary code to handle multiple loops. Thus, we set
5303 : temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
5304 : we use gfc_trans_scalarized_loop_boundary even later to restore
5305 : offset. */
5306 7155 : loop.temp_dim = loop.dimen;
5307 7155 : gfc_conv_loop_setup (&loop, &expr->where);
5308 :
5309 7155 : ploop = &loop;
5310 : }
5311 :
5312 9951 : gcc_assert (reduction_dimensions == ploop->dimen);
5313 :
5314 9951 : if (nonempty == NULL && !(maskexpr && maskexpr->rank > 0))
5315 : {
5316 1595 : nonempty = logical_true_node;
5317 :
5318 3697 : for (int i = 0; i < ploop->dimen; i++)
5319 : {
5320 2102 : if (!(ploop->from[i] && ploop->to[i]))
5321 : {
5322 : nonempty = NULL;
5323 : break;
5324 : }
5325 :
5326 2102 : tree tmp = fold_build2_loc (input_location, LE_EXPR,
5327 : logical_type_node, ploop->from[i],
5328 : ploop->to[i]);
5329 :
5330 2102 : nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5331 : logical_type_node, nonempty, tmp);
5332 : }
5333 : }
5334 :
5335 11546 : lab1 = NULL;
5336 11546 : lab2 = NULL;
5337 : /* Initialize the position to zero, following Fortran 2003. We are free
5338 : to do this because Fortran 95 allows the result of an entirely false
5339 : mask to be processor dependent. If we know at compile time the array
5340 : is non-empty and no MASK is used, we can initialize to 1 to simplify
5341 : the inner loop. */
5342 9951 : if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5343 : {
5344 3748 : tree init = fold_build3_loc (input_location, COND_EXPR,
5345 : gfc_array_index_type, nonempty,
5346 : gfc_index_one_node,
5347 : gfc_index_zero_node);
5348 8430 : for (int i = 0; i < ploop->dimen; i++)
5349 4682 : gfc_add_modify (&ploop->pre, pos[i], init);
5350 : }
5351 : else
5352 : {
5353 13747 : for (int i = 0; i < ploop->dimen; i++)
5354 7544 : gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node);
5355 6203 : lab1 = gfc_build_label_decl (NULL_TREE);
5356 6203 : TREE_USED (lab1) = 1;
5357 6203 : lab2 = gfc_build_label_decl (NULL_TREE);
5358 6203 : TREE_USED (lab2) = 1;
5359 : }
5360 :
5361 : /* An offset must be added to the loop
5362 : counter to obtain the required position. */
5363 22177 : for (int i = 0; i < ploop->dimen; i++)
5364 : {
5365 12226 : gcc_assert (ploop->from[i]);
5366 :
5367 12226 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5368 : gfc_index_one_node, ploop->from[i]);
5369 12226 : gfc_add_modify (&ploop->pre, offset[i], tmp);
5370 : }
5371 :
5372 9951 : if (!nested_loop)
5373 : {
5374 9965 : gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5375 7155 : if (maskss)
5376 2700 : gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5377 : }
5378 :
5379 : /* Generate the loop body. */
5380 9951 : gfc_start_scalarized_body (ploop, &body);
5381 :
5382 : /* If we have a mask, only check this element if the mask is set. */
5383 9951 : if (maskexpr && maskexpr->rank > 0)
5384 : {
5385 3874 : gfc_init_se (&maskse, base_se);
5386 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5387 3874 : if (!nested_loop)
5388 2700 : maskse.ss = maskss;
5389 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5390 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5391 :
5392 3874 : gfc_start_block (&block);
5393 : }
5394 : else
5395 6077 : gfc_init_block (&block);
5396 :
5397 : /* Compare with the current limit. */
5398 9951 : gfc_init_se (&arrayse, base_se);
5399 9951 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5400 9951 : if (!nested_loop)
5401 7155 : arrayse.ss = arrayss;
5402 9951 : gfc_conv_expr_val (&arrayse, arrayexpr);
5403 9951 : gfc_add_block_to_block (&block, &arrayse.pre);
5404 :
5405 : /* We do the following if this is a more extreme value. */
5406 9951 : gfc_start_block (&ifblock);
5407 :
5408 : /* Assign the value to the limit... */
5409 9951 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5410 :
5411 9951 : if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5412 : {
5413 1569 : stmtblock_t ifblock2;
5414 1569 : tree ifbody2;
5415 :
5416 1569 : gfc_start_block (&ifblock2);
5417 3439 : for (int i = 0; i < ploop->dimen; i++)
5418 : {
5419 1870 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5420 : ploop->loopvar[i], offset[i]);
5421 1870 : gfc_add_modify (&ifblock2, pos[i], tmp);
5422 : }
5423 1569 : ifbody2 = gfc_finish_block (&ifblock2);
5424 :
5425 1569 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5426 : pos[0], gfc_index_zero_node);
5427 1569 : tmp = build3_v (COND_EXPR, cond, ifbody2,
5428 : build_empty_stmt (input_location));
5429 1569 : gfc_add_expr_to_block (&block, tmp);
5430 : }
5431 :
5432 22177 : for (int i = 0; i < ploop->dimen; i++)
5433 : {
5434 12226 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5435 : ploop->loopvar[i], offset[i]);
5436 12226 : gfc_add_modify (&ifblock, pos[i], tmp);
5437 12226 : gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
5438 : }
5439 :
5440 9951 : gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
5441 :
5442 9951 : if (lab1)
5443 6203 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5444 :
5445 9951 : ifbody = gfc_finish_block (&ifblock);
5446 :
5447 9951 : if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5448 : {
5449 7646 : if (lab1)
5450 5998 : cond = fold_build2_loc (input_location,
5451 : op == GT_EXPR ? GE_EXPR : LE_EXPR,
5452 : logical_type_node, arrayse.expr, limit);
5453 : else
5454 : {
5455 3748 : tree ifbody2, elsebody2;
5456 :
5457 : /* We switch to > or >= depending on the value of the BACK argument. */
5458 3748 : cond = gfc_create_var (logical_type_node, "cond");
5459 :
5460 3748 : gfc_start_block (&ifblock);
5461 5641 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5462 : logical_type_node, arrayse.expr, limit);
5463 :
5464 3748 : gfc_add_modify (&ifblock, cond, b_if);
5465 3748 : ifbody2 = gfc_finish_block (&ifblock);
5466 :
5467 3748 : gfc_start_block (&elseblock);
5468 3748 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5469 : arrayse.expr, limit);
5470 :
5471 3748 : gfc_add_modify (&elseblock, cond, b_else);
5472 3748 : elsebody2 = gfc_finish_block (&elseblock);
5473 :
5474 3748 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5475 : back, ifbody2, elsebody2);
5476 :
5477 3748 : gfc_add_expr_to_block (&block, tmp);
5478 : }
5479 :
5480 7646 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5481 7646 : ifbody = build3_v (COND_EXPR, cond, ifbody,
5482 : build_empty_stmt (input_location));
5483 : }
5484 9951 : gfc_add_expr_to_block (&block, ifbody);
5485 :
5486 9951 : if (maskexpr && maskexpr->rank > 0)
5487 : {
5488 : /* We enclose the above in if (mask) {...}. If the mask is an
5489 : optional argument, generate IF (.NOT. PRESENT(MASK)
5490 : .OR. MASK(I)). */
5491 :
5492 3874 : tree ifmask;
5493 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5494 3874 : tmp = gfc_finish_block (&block);
5495 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5496 : build_empty_stmt (input_location));
5497 3874 : }
5498 : else
5499 6077 : tmp = gfc_finish_block (&block);
5500 9951 : gfc_add_expr_to_block (&body, tmp);
5501 :
5502 9951 : if (lab1)
5503 : {
5504 13747 : for (int i = 0; i < ploop->dimen; i++)
5505 7544 : ploop->from[i] = fold_build3_loc (input_location, COND_EXPR,
5506 7544 : TREE_TYPE (ploop->from[i]),
5507 : second_loop_entry, idx[i],
5508 : ploop->from[i]);
5509 :
5510 6203 : gfc_trans_scalarized_loop_boundary (ploop, &body);
5511 :
5512 6203 : if (nested_loop)
5513 : {
5514 : /* The first loop already advanced the parent se'ss chain, so clear
5515 : the parent now to avoid doing it a second time, making the chain
5516 : out of sync. */
5517 1858 : nested_se.parent = nullptr;
5518 1858 : nested_se.ss = orig_ss;
5519 : }
5520 :
5521 6203 : stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1];
5522 :
5523 6203 : if (HONOR_NANS (DECL_MODE (limit)))
5524 : {
5525 3898 : if (nonempty != NULL)
5526 : {
5527 2329 : stmtblock_t init_block;
5528 2329 : gfc_init_block (&init_block);
5529 :
5530 5229 : for (int i = 0; i < ploop->dimen; i++)
5531 2900 : gfc_add_modify (&init_block, pos[i], gfc_index_one_node);
5532 :
5533 2329 : tree ifbody = gfc_finish_block (&init_block);
5534 2329 : tmp = build3_v (COND_EXPR, nonempty, ifbody,
5535 : build_empty_stmt (input_location));
5536 2329 : gfc_add_expr_to_block (outer_block, tmp);
5537 : }
5538 : }
5539 :
5540 6203 : gfc_add_expr_to_block (outer_block, build1_v (GOTO_EXPR, lab2));
5541 6203 : gfc_add_expr_to_block (outer_block, build1_v (LABEL_EXPR, lab1));
5542 :
5543 : /* If we have a mask, only check this element if the mask is set. */
5544 6203 : if (maskexpr && maskexpr->rank > 0)
5545 : {
5546 3874 : gfc_init_se (&maskse, base_se);
5547 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5548 3874 : if (!nested_loop)
5549 2700 : maskse.ss = maskss;
5550 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5551 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5552 :
5553 3874 : gfc_start_block (&block);
5554 : }
5555 : else
5556 2329 : gfc_init_block (&block);
5557 :
5558 : /* Compare with the current limit. */
5559 6203 : gfc_init_se (&arrayse, base_se);
5560 6203 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5561 6203 : if (!nested_loop)
5562 4345 : arrayse.ss = arrayss;
5563 6203 : gfc_conv_expr_val (&arrayse, arrayexpr);
5564 6203 : gfc_add_block_to_block (&block, &arrayse.pre);
5565 :
5566 : /* We do the following if this is a more extreme value. */
5567 6203 : gfc_start_block (&ifblock);
5568 :
5569 : /* Assign the value to the limit... */
5570 6203 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5571 :
5572 13747 : for (int i = 0; i < ploop->dimen; i++)
5573 : {
5574 7544 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5575 : ploop->loopvar[i], offset[i]);
5576 7544 : gfc_add_modify (&ifblock, pos[i], tmp);
5577 : }
5578 :
5579 6203 : ifbody = gfc_finish_block (&ifblock);
5580 :
5581 : /* We switch to > or >= depending on the value of the BACK argument. */
5582 6203 : {
5583 6203 : tree ifbody2, elsebody2;
5584 :
5585 6203 : cond = gfc_create_var (logical_type_node, "cond");
5586 :
5587 6203 : gfc_start_block (&ifblock);
5588 9537 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5589 : logical_type_node, arrayse.expr, limit);
5590 :
5591 6203 : gfc_add_modify (&ifblock, cond, b_if);
5592 6203 : ifbody2 = gfc_finish_block (&ifblock);
5593 :
5594 6203 : gfc_start_block (&elseblock);
5595 6203 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5596 : arrayse.expr, limit);
5597 :
5598 6203 : gfc_add_modify (&elseblock, cond, b_else);
5599 6203 : elsebody2 = gfc_finish_block (&elseblock);
5600 :
5601 6203 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5602 : back, ifbody2, elsebody2);
5603 : }
5604 :
5605 6203 : gfc_add_expr_to_block (&block, tmp);
5606 6203 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5607 6203 : tmp = build3_v (COND_EXPR, cond, ifbody,
5608 : build_empty_stmt (input_location));
5609 :
5610 6203 : gfc_add_expr_to_block (&block, tmp);
5611 :
5612 6203 : if (maskexpr && maskexpr->rank > 0)
5613 : {
5614 : /* We enclose the above in if (mask) {...}. If the mask is
5615 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5616 : .OR. MASK(I)).*/
5617 :
5618 3874 : tree ifmask;
5619 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5620 3874 : tmp = gfc_finish_block (&block);
5621 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5622 : build_empty_stmt (input_location));
5623 3874 : }
5624 : else
5625 2329 : tmp = gfc_finish_block (&block);
5626 :
5627 6203 : gfc_add_expr_to_block (&body, tmp);
5628 6203 : gfc_add_modify (&body, second_loop_entry, logical_false_node);
5629 : }
5630 :
5631 9951 : gfc_trans_scalarizing_loops (ploop, &body);
5632 :
5633 9951 : if (lab2)
5634 6203 : gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2));
5635 :
5636 : /* For a scalar mask, enclose the loop in an if statement. */
5637 9951 : if (maskexpr && maskexpr->rank == 0)
5638 : {
5639 2644 : tree ifmask;
5640 :
5641 2644 : gfc_init_se (&maskse, nested_loop ? se : nullptr);
5642 2644 : gfc_conv_expr_val (&maskse, maskexpr);
5643 2644 : gfc_add_block_to_block (&se->pre, &maskse.pre);
5644 2644 : gfc_init_block (&block);
5645 2644 : gfc_add_block_to_block (&block, &ploop->pre);
5646 2644 : gfc_add_block_to_block (&block, &ploop->post);
5647 2644 : tmp = gfc_finish_block (&block);
5648 :
5649 : /* For the else part of the scalar mask, just initialize
5650 : the pos variable the same way as above. */
5651 :
5652 2644 : gfc_init_block (&elseblock);
5653 5580 : for (int i = 0; i < ploop->dimen; i++)
5654 2936 : gfc_add_modify (&elseblock, pos[i], gfc_index_zero_node);
5655 2644 : elsetmp = gfc_finish_block (&elseblock);
5656 2644 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5657 2644 : tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5658 2644 : gfc_add_expr_to_block (&block, tmp);
5659 2644 : gfc_add_block_to_block (&se->pre, &block);
5660 2644 : }
5661 : else
5662 : {
5663 7307 : gfc_add_block_to_block (&se->pre, &ploop->pre);
5664 7307 : gfc_add_block_to_block (&se->pre, &ploop->post);
5665 : }
5666 :
5667 9951 : if (!nested_loop)
5668 7155 : gfc_cleanup_loop (&loop);
5669 :
5670 9951 : if (!dim_present)
5671 : {
5672 8837 : for (int i = 0; i < arrayexpr->rank; i++)
5673 : {
5674 5556 : tree res_idx = build_int_cst (gfc_array_index_type, i);
5675 5556 : tree res_arr_ref = gfc_build_array_ref (result_var, res_idx,
5676 : NULL_TREE, true);
5677 :
5678 5556 : tree value = convert (type, pos[i]);
5679 5556 : gfc_add_modify (&se->pre, res_arr_ref, value);
5680 : }
5681 :
5682 3281 : se->expr = result_var;
5683 : }
5684 : else
5685 6670 : se->expr = convert (type, pos[0]);
5686 : }
5687 :
5688 : /* Emit code for findloc. */
5689 :
5690 : static void
5691 1332 : gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5692 : {
5693 1332 : gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5694 : *kind_arg, *back_arg;
5695 1332 : gfc_expr *value_expr;
5696 1332 : int ikind;
5697 1332 : tree resvar;
5698 1332 : stmtblock_t block;
5699 1332 : stmtblock_t body;
5700 1332 : stmtblock_t loopblock;
5701 1332 : tree type;
5702 1332 : tree tmp;
5703 1332 : tree found;
5704 1332 : tree forward_branch = NULL_TREE;
5705 1332 : tree back_branch;
5706 1332 : gfc_loopinfo loop;
5707 1332 : gfc_ss *arrayss;
5708 1332 : gfc_ss *maskss;
5709 1332 : gfc_se arrayse;
5710 1332 : gfc_se valuese;
5711 1332 : gfc_se maskse;
5712 1332 : gfc_se backse;
5713 1332 : tree exit_label;
5714 1332 : gfc_expr *maskexpr;
5715 1332 : tree offset;
5716 1332 : int i;
5717 1332 : bool optional_mask;
5718 :
5719 1332 : array_arg = expr->value.function.actual;
5720 1332 : value_arg = array_arg->next;
5721 1332 : dim_arg = value_arg->next;
5722 1332 : mask_arg = dim_arg->next;
5723 1332 : kind_arg = mask_arg->next;
5724 1332 : back_arg = kind_arg->next;
5725 :
5726 : /* Remove kind and set ikind. */
5727 1332 : if (kind_arg->expr)
5728 : {
5729 0 : ikind = mpz_get_si (kind_arg->expr->value.integer);
5730 0 : gfc_free_expr (kind_arg->expr);
5731 0 : kind_arg->expr = NULL;
5732 : }
5733 : else
5734 1332 : ikind = gfc_default_integer_kind;
5735 :
5736 1332 : value_expr = value_arg->expr;
5737 :
5738 : /* Unless it's a string, pass VALUE by value. */
5739 1332 : if (value_expr->ts.type != BT_CHARACTER)
5740 732 : value_arg->name = "%VAL";
5741 :
5742 : /* Pass BACK argument by value. */
5743 1332 : back_arg->name = "%VAL";
5744 :
5745 : /* Call the library if we have a character function or if
5746 : rank > 0. */
5747 1332 : if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5748 : {
5749 1200 : se->ignore_optional = 1;
5750 1200 : if (expr->rank == 0)
5751 : {
5752 : /* Remove dim argument. */
5753 84 : gfc_free_expr (dim_arg->expr);
5754 84 : dim_arg->expr = NULL;
5755 : }
5756 1200 : gfc_conv_intrinsic_funcall (se, expr);
5757 1200 : return;
5758 : }
5759 :
5760 132 : type = gfc_get_int_type (ikind);
5761 :
5762 : /* Initialize the result. */
5763 132 : resvar = gfc_create_var (gfc_array_index_type, "pos");
5764 132 : gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5765 132 : offset = gfc_create_var (gfc_array_index_type, "offset");
5766 :
5767 132 : maskexpr = mask_arg->expr;
5768 72 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5769 60 : && maskexpr->symtree->n.sym->attr.dummy
5770 144 : && maskexpr->symtree->n.sym->attr.optional;
5771 :
5772 : /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5773 :
5774 396 : for (i = 0 ; i < 2; i++)
5775 : {
5776 : /* Walk the arguments. */
5777 264 : arrayss = gfc_walk_expr (array_arg->expr);
5778 264 : gcc_assert (arrayss != gfc_ss_terminator);
5779 :
5780 264 : if (maskexpr && maskexpr->rank != 0)
5781 : {
5782 84 : maskss = gfc_walk_expr (maskexpr);
5783 84 : gcc_assert (maskss != gfc_ss_terminator);
5784 : }
5785 : else
5786 : maskss = NULL;
5787 :
5788 : /* Initialize the scalarizer. */
5789 264 : gfc_init_loopinfo (&loop);
5790 264 : exit_label = gfc_build_label_decl (NULL_TREE);
5791 264 : TREE_USED (exit_label) = 1;
5792 :
5793 : /* We add the mask first because the number of iterations is
5794 : taken from the last ss, and this breaks if an absent
5795 : optional argument is used for mask. */
5796 :
5797 264 : if (maskss)
5798 84 : gfc_add_ss_to_loop (&loop, maskss);
5799 264 : gfc_add_ss_to_loop (&loop, arrayss);
5800 :
5801 : /* Initialize the loop. */
5802 264 : gfc_conv_ss_startstride (&loop);
5803 264 : gfc_conv_loop_setup (&loop, &expr->where);
5804 :
5805 : /* Calculate the offset. */
5806 264 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5807 : gfc_index_one_node, loop.from[0]);
5808 264 : gfc_add_modify (&loop.pre, offset, tmp);
5809 :
5810 264 : gfc_mark_ss_chain_used (arrayss, 1);
5811 264 : if (maskss)
5812 84 : gfc_mark_ss_chain_used (maskss, 1);
5813 :
5814 : /* The first loop is for BACK=.true. */
5815 264 : if (i == 0)
5816 132 : loop.reverse[0] = GFC_REVERSE_SET;
5817 :
5818 : /* Generate the loop body. */
5819 264 : gfc_start_scalarized_body (&loop, &body);
5820 :
5821 : /* If we have an array mask, only add the element if it is
5822 : set. */
5823 264 : if (maskss)
5824 : {
5825 84 : gfc_init_se (&maskse, NULL);
5826 84 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5827 84 : maskse.ss = maskss;
5828 84 : gfc_conv_expr_val (&maskse, maskexpr);
5829 84 : gfc_add_block_to_block (&body, &maskse.pre);
5830 : }
5831 :
5832 : /* If the condition matches then set the return value. */
5833 264 : gfc_start_block (&block);
5834 :
5835 : /* Add the offset. */
5836 264 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5837 264 : TREE_TYPE (resvar),
5838 : loop.loopvar[0], offset);
5839 264 : gfc_add_modify (&block, resvar, tmp);
5840 : /* And break out of the loop. */
5841 264 : tmp = build1_v (GOTO_EXPR, exit_label);
5842 264 : gfc_add_expr_to_block (&block, tmp);
5843 :
5844 264 : found = gfc_finish_block (&block);
5845 :
5846 : /* Check this element. */
5847 264 : gfc_init_se (&arrayse, NULL);
5848 264 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5849 264 : arrayse.ss = arrayss;
5850 264 : gfc_conv_expr_val (&arrayse, array_arg->expr);
5851 264 : gfc_add_block_to_block (&body, &arrayse.pre);
5852 :
5853 264 : gfc_init_se (&valuese, NULL);
5854 264 : gfc_conv_expr_val (&valuese, value_arg->expr);
5855 264 : gfc_add_block_to_block (&body, &valuese.pre);
5856 :
5857 264 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5858 : arrayse.expr, valuese.expr);
5859 :
5860 264 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5861 264 : if (maskss)
5862 : {
5863 : /* We enclose the above in if (mask) {...}. If the mask is
5864 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5865 : .OR. MASK(I)). */
5866 :
5867 84 : tree ifmask;
5868 84 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5869 84 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5870 : build_empty_stmt (input_location));
5871 : }
5872 :
5873 264 : gfc_add_expr_to_block (&body, tmp);
5874 264 : gfc_add_block_to_block (&body, &arrayse.post);
5875 :
5876 264 : gfc_trans_scalarizing_loops (&loop, &body);
5877 :
5878 : /* Add the exit label. */
5879 264 : tmp = build1_v (LABEL_EXPR, exit_label);
5880 264 : gfc_add_expr_to_block (&loop.pre, tmp);
5881 264 : gfc_start_block (&loopblock);
5882 264 : gfc_add_block_to_block (&loopblock, &loop.pre);
5883 264 : gfc_add_block_to_block (&loopblock, &loop.post);
5884 264 : if (i == 0)
5885 132 : forward_branch = gfc_finish_block (&loopblock);
5886 : else
5887 132 : back_branch = gfc_finish_block (&loopblock);
5888 :
5889 264 : gfc_cleanup_loop (&loop);
5890 : }
5891 :
5892 : /* Enclose the two loops in an IF statement. */
5893 :
5894 132 : gfc_init_se (&backse, NULL);
5895 132 : gfc_conv_expr_val (&backse, back_arg->expr);
5896 132 : gfc_add_block_to_block (&se->pre, &backse.pre);
5897 132 : tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5898 :
5899 : /* For a scalar mask, enclose the loop in an if statement. */
5900 132 : if (maskexpr && maskss == NULL)
5901 : {
5902 30 : tree ifmask;
5903 30 : tree if_stmt;
5904 :
5905 30 : gfc_init_se (&maskse, NULL);
5906 30 : gfc_conv_expr_val (&maskse, maskexpr);
5907 30 : gfc_init_block (&block);
5908 30 : gfc_add_expr_to_block (&block, maskse.expr);
5909 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5910 30 : if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5911 : build_empty_stmt (input_location));
5912 30 : gfc_add_expr_to_block (&block, if_stmt);
5913 30 : tmp = gfc_finish_block (&block);
5914 : }
5915 :
5916 132 : gfc_add_expr_to_block (&se->pre, tmp);
5917 132 : se->expr = convert (type, resvar);
5918 :
5919 : }
5920 :
5921 : /* Emit code for fstat, lstat and stat intrinsic subroutines. */
5922 :
5923 : static tree
5924 55 : conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code)
5925 : {
5926 55 : stmtblock_t block;
5927 55 : gfc_se se, se_stat;
5928 55 : tree unit = NULL_TREE;
5929 55 : tree name = NULL_TREE;
5930 55 : tree slen = NULL_TREE;
5931 55 : tree vals;
5932 55 : tree arg3 = NULL_TREE;
5933 55 : tree stat = NULL_TREE ;
5934 55 : tree present = NULL_TREE;
5935 55 : tree tmp;
5936 55 : int kind;
5937 :
5938 55 : gfc_init_block (&block);
5939 55 : gfc_init_se (&se, NULL);
5940 :
5941 55 : switch (code->resolved_isym->id)
5942 : {
5943 21 : case GFC_ISYM_FSTAT:
5944 : /* Deal with the UNIT argument. */
5945 21 : gfc_conv_expr (&se, code->ext.actual->expr);
5946 21 : gfc_add_block_to_block (&block, &se.pre);
5947 21 : unit = gfc_evaluate_now (se.expr, &block);
5948 21 : unit = gfc_build_addr_expr (NULL_TREE, unit);
5949 21 : gfc_add_block_to_block (&block, &se.post);
5950 21 : break;
5951 :
5952 34 : case GFC_ISYM_LSTAT:
5953 34 : case GFC_ISYM_STAT:
5954 : /* Deal with the NAME argument. */
5955 34 : gfc_conv_expr (&se, code->ext.actual->expr);
5956 34 : gfc_conv_string_parameter (&se);
5957 34 : gfc_add_block_to_block (&block, &se.pre);
5958 34 : name = se.expr;
5959 34 : slen = se.string_length;
5960 34 : gfc_add_block_to_block (&block, &se.post);
5961 34 : break;
5962 :
5963 0 : default:
5964 0 : gcc_unreachable ();
5965 : }
5966 :
5967 : /* Deal with the VALUES argument. */
5968 55 : gfc_init_se (&se, NULL);
5969 55 : gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr);
5970 55 : vals = gfc_build_addr_expr (NULL_TREE, se.expr);
5971 55 : gfc_add_block_to_block (&block, &se.pre);
5972 55 : gfc_add_block_to_block (&block, &se.post);
5973 55 : kind = code->ext.actual->next->expr->ts.kind;
5974 :
5975 : /* Deal with an optional STATUS. */
5976 55 : if (code->ext.actual->next->next->expr)
5977 : {
5978 45 : gfc_init_se (&se_stat, NULL);
5979 45 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
5980 45 : stat = gfc_create_var (gfc_get_int_type (kind), "_stat");
5981 45 : arg3 = gfc_build_addr_expr (NULL_TREE, stat);
5982 :
5983 : /* Handle case of status being an optional dummy. */
5984 45 : gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym;
5985 45 : if (sym->attr.dummy && sym->attr.optional)
5986 : {
5987 6 : present = gfc_conv_expr_present (sym);
5988 12 : arg3 = fold_build3_loc (input_location, COND_EXPR,
5989 6 : TREE_TYPE (arg3), present, arg3,
5990 6 : fold_convert (TREE_TYPE (arg3),
5991 : null_pointer_node));
5992 : }
5993 : }
5994 :
5995 : /* Call library function depending on KIND of VALUES argument. */
5996 55 : switch (code->resolved_isym->id)
5997 : {
5998 21 : case GFC_ISYM_FSTAT:
5999 21 : tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub);
6000 : break;
6001 14 : case GFC_ISYM_LSTAT:
6002 14 : tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub);
6003 : break;
6004 20 : case GFC_ISYM_STAT:
6005 20 : tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub);
6006 : break;
6007 0 : default:
6008 0 : gcc_unreachable ();
6009 : }
6010 :
6011 55 : if (code->resolved_isym->id == GFC_ISYM_FSTAT)
6012 21 : tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals,
6013 : stat ? arg3 : null_pointer_node);
6014 : else
6015 34 : tmp = build_call_expr_loc (input_location, tmp, 4, name, vals,
6016 : stat ? arg3 : null_pointer_node, slen);
6017 55 : gfc_add_expr_to_block (&block, tmp);
6018 :
6019 : /* Handle kind conversion of status. */
6020 55 : if (stat && stat != se_stat.expr)
6021 : {
6022 45 : stmtblock_t block2;
6023 :
6024 45 : gfc_init_block (&block2);
6025 45 : gfc_add_modify (&block2, se_stat.expr,
6026 45 : fold_convert (TREE_TYPE (se_stat.expr), stat));
6027 :
6028 45 : if (present)
6029 : {
6030 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2),
6031 : build_empty_stmt (input_location));
6032 6 : gfc_add_expr_to_block (&block, tmp);
6033 : }
6034 : else
6035 39 : gfc_add_block_to_block (&block, &block2);
6036 : }
6037 :
6038 55 : return gfc_finish_block (&block);
6039 : }
6040 :
6041 : /* Emit code for minval or maxval intrinsic. There are many different cases
6042 : we need to handle. For performance reasons we sometimes create two
6043 : loops instead of one, where the second one is much simpler.
6044 : Examples for minval intrinsic:
6045 : 1) Result is an array, a call is generated
6046 : 2) Array mask is used and NaNs need to be supported, rank 1:
6047 : limit = Infinity;
6048 : nonempty = false;
6049 : S = from;
6050 : while (S <= to) {
6051 : if (mask[S]) {
6052 : nonempty = true;
6053 : if (a[S] <= limit) {
6054 : limit = a[S];
6055 : S++;
6056 : goto lab;
6057 : }
6058 : else
6059 : S++;
6060 : }
6061 : }
6062 : limit = nonempty ? NaN : huge (limit);
6063 : lab:
6064 : while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6065 : 3) NaNs need to be supported, but it is known at compile time or cheaply
6066 : at runtime whether array is nonempty or not, rank 1:
6067 : limit = Infinity;
6068 : S = from;
6069 : while (S <= to) {
6070 : if (a[S] <= limit) {
6071 : limit = a[S];
6072 : S++;
6073 : goto lab;
6074 : }
6075 : else
6076 : S++;
6077 : }
6078 : limit = (from <= to) ? NaN : huge (limit);
6079 : lab:
6080 : while (S <= to) { limit = min (a[S], limit); S++; }
6081 : 4) Array mask is used and NaNs need to be supported, rank > 1:
6082 : limit = Infinity;
6083 : nonempty = false;
6084 : fast = false;
6085 : S1 = from1;
6086 : while (S1 <= to1) {
6087 : S2 = from2;
6088 : while (S2 <= to2) {
6089 : if (mask[S1][S2]) {
6090 : if (fast) limit = min (a[S1][S2], limit);
6091 : else {
6092 : nonempty = true;
6093 : if (a[S1][S2] <= limit) {
6094 : limit = a[S1][S2];
6095 : fast = true;
6096 : }
6097 : }
6098 : }
6099 : S2++;
6100 : }
6101 : S1++;
6102 : }
6103 : if (!fast)
6104 : limit = nonempty ? NaN : huge (limit);
6105 : 5) NaNs need to be supported, but it is known at compile time or cheaply
6106 : at runtime whether array is nonempty or not, rank > 1:
6107 : limit = Infinity;
6108 : fast = false;
6109 : S1 = from1;
6110 : while (S1 <= to1) {
6111 : S2 = from2;
6112 : while (S2 <= to2) {
6113 : if (fast) limit = min (a[S1][S2], limit);
6114 : else {
6115 : if (a[S1][S2] <= limit) {
6116 : limit = a[S1][S2];
6117 : fast = true;
6118 : }
6119 : }
6120 : S2++;
6121 : }
6122 : S1++;
6123 : }
6124 : if (!fast)
6125 : limit = (nonempty_array) ? NaN : huge (limit);
6126 : 6) NaNs aren't supported, but infinities are. Array mask is used:
6127 : limit = Infinity;
6128 : nonempty = false;
6129 : S = from;
6130 : while (S <= to) {
6131 : if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6132 : S++;
6133 : }
6134 : limit = nonempty ? limit : huge (limit);
6135 : 7) Same without array mask:
6136 : limit = Infinity;
6137 : S = from;
6138 : while (S <= to) { limit = min (a[S], limit); S++; }
6139 : limit = (from <= to) ? limit : huge (limit);
6140 : 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6141 : limit = huge (limit);
6142 : S = from;
6143 : while (S <= to) { limit = min (a[S], limit); S++); }
6144 : (or
6145 : while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6146 : with array mask instead).
6147 : For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6148 : setting limit = huge (limit); in the else branch. */
6149 :
6150 : static void
6151 2417 : gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6152 : {
6153 2417 : tree limit;
6154 2417 : tree type;
6155 2417 : tree tmp;
6156 2417 : tree ifbody;
6157 2417 : tree nonempty;
6158 2417 : tree nonempty_var;
6159 2417 : tree lab;
6160 2417 : tree fast;
6161 2417 : tree huge_cst = NULL, nan_cst = NULL;
6162 2417 : stmtblock_t body;
6163 2417 : stmtblock_t block, block2;
6164 2417 : gfc_loopinfo loop;
6165 2417 : gfc_actual_arglist *actual;
6166 2417 : gfc_ss *arrayss;
6167 2417 : gfc_ss *maskss;
6168 2417 : gfc_se arrayse;
6169 2417 : gfc_se maskse;
6170 2417 : gfc_expr *arrayexpr;
6171 2417 : gfc_expr *maskexpr;
6172 2417 : int n;
6173 2417 : bool optional_mask;
6174 :
6175 2417 : if (se->ss)
6176 : {
6177 0 : gfc_conv_intrinsic_funcall (se, expr);
6178 186 : return;
6179 : }
6180 :
6181 2417 : actual = expr->value.function.actual;
6182 2417 : arrayexpr = actual->expr;
6183 :
6184 2417 : if (arrayexpr->ts.type == BT_CHARACTER)
6185 : {
6186 186 : gfc_actual_arglist *dim = actual->next;
6187 186 : if (expr->rank == 0 && dim->expr != 0)
6188 : {
6189 6 : gfc_free_expr (dim->expr);
6190 6 : dim->expr = NULL;
6191 : }
6192 186 : gfc_conv_intrinsic_funcall (se, expr);
6193 186 : return;
6194 : }
6195 :
6196 2231 : type = gfc_typenode_for_spec (&expr->ts);
6197 : /* Initialize the result. */
6198 2231 : limit = gfc_create_var (type, "limit");
6199 2231 : n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6200 2231 : switch (expr->ts.type)
6201 : {
6202 1245 : case BT_REAL:
6203 1245 : huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6204 : expr->ts.kind, 0);
6205 1245 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6206 : {
6207 1241 : REAL_VALUE_TYPE real;
6208 1241 : real_inf (&real);
6209 1241 : tmp = build_real (type, real);
6210 : }
6211 : else
6212 : tmp = huge_cst;
6213 1245 : if (HONOR_NANS (DECL_MODE (limit)))
6214 1241 : nan_cst = gfc_build_nan (type, "");
6215 : break;
6216 :
6217 956 : case BT_INTEGER:
6218 956 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6219 956 : break;
6220 :
6221 30 : case BT_UNSIGNED:
6222 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
6223 30 : if (op == GT_EXPR)
6224 18 : tmp = build_int_cst (type, 0);
6225 : else
6226 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
6227 : expr->ts.kind);
6228 : break;
6229 :
6230 0 : default:
6231 0 : gcc_unreachable ();
6232 : }
6233 :
6234 : /* We start with the most negative possible value for MAXVAL, and the most
6235 : positive possible value for MINVAL. The most negative possible value is
6236 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6237 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
6238 : with above. */
6239 2231 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
6240 : {
6241 987 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6242 987 : if (huge_cst)
6243 560 : huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6244 560 : TREE_TYPE (huge_cst), huge_cst);
6245 : }
6246 :
6247 1005 : if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6248 427 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6249 : tmp, build_int_cst (type, 1));
6250 :
6251 2231 : gfc_add_modify (&se->pre, limit, tmp);
6252 :
6253 : /* Walk the arguments. */
6254 2231 : arrayss = gfc_walk_expr (arrayexpr);
6255 2231 : gcc_assert (arrayss != gfc_ss_terminator);
6256 :
6257 2231 : actual = actual->next->next;
6258 2231 : gcc_assert (actual);
6259 2231 : maskexpr = actual->expr;
6260 1572 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6261 1560 : && maskexpr->symtree->n.sym->attr.dummy
6262 2243 : && maskexpr->symtree->n.sym->attr.optional;
6263 1560 : nonempty = NULL;
6264 1572 : if (maskexpr && maskexpr->rank != 0)
6265 : {
6266 1026 : maskss = gfc_walk_expr (maskexpr);
6267 1026 : gcc_assert (maskss != gfc_ss_terminator);
6268 : }
6269 : else
6270 : {
6271 1205 : mpz_t asize;
6272 1205 : if (gfc_array_size (arrayexpr, &asize))
6273 : {
6274 678 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6275 678 : mpz_clear (asize);
6276 678 : nonempty = fold_build2_loc (input_location, GT_EXPR,
6277 : logical_type_node, nonempty,
6278 : gfc_index_zero_node);
6279 : }
6280 1205 : maskss = NULL;
6281 : }
6282 :
6283 : /* Initialize the scalarizer. */
6284 2231 : gfc_init_loopinfo (&loop);
6285 :
6286 : /* We add the mask first because the number of iterations is taken
6287 : from the last ss, and this breaks if an absent optional argument
6288 : is used for mask. */
6289 :
6290 2231 : if (maskss)
6291 1026 : gfc_add_ss_to_loop (&loop, maskss);
6292 2231 : gfc_add_ss_to_loop (&loop, arrayss);
6293 :
6294 : /* Initialize the loop. */
6295 2231 : gfc_conv_ss_startstride (&loop);
6296 :
6297 : /* The code generated can have more than one loop in sequence (see the
6298 : comment at the function header). This doesn't work well with the
6299 : scalarizer, which changes arrays' offset when the scalarization loops
6300 : are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6301 : are currently inlined in the scalar case only. As there is no dependency
6302 : to care about in that case, there is no temporary, so that we can use the
6303 : scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6304 : here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6305 : gfc_trans_scalarized_loop_boundary even later to restore offset.
6306 : TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6307 : should eventually go away. We could either create two loops properly,
6308 : or find another way to save/restore the array offsets between the two
6309 : loops (without conflicting with temporary management), or use a single
6310 : loop minmaxval implementation. See PR 31067. */
6311 2231 : loop.temp_dim = loop.dimen;
6312 2231 : gfc_conv_loop_setup (&loop, &expr->where);
6313 :
6314 2231 : if (nonempty == NULL && maskss == NULL
6315 527 : && loop.dimen == 1 && loop.from[0] && loop.to[0])
6316 491 : nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6317 : loop.from[0], loop.to[0]);
6318 2231 : nonempty_var = NULL;
6319 2231 : if (nonempty == NULL
6320 2231 : && (HONOR_INFINITIES (DECL_MODE (limit))
6321 480 : || HONOR_NANS (DECL_MODE (limit))))
6322 : {
6323 582 : nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6324 582 : gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6325 582 : nonempty = nonempty_var;
6326 : }
6327 2231 : lab = NULL;
6328 2231 : fast = NULL;
6329 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6330 : {
6331 1241 : if (loop.dimen == 1)
6332 : {
6333 821 : lab = gfc_build_label_decl (NULL_TREE);
6334 821 : TREE_USED (lab) = 1;
6335 : }
6336 : else
6337 : {
6338 420 : fast = gfc_create_var (logical_type_node, "fast");
6339 420 : gfc_add_modify (&se->pre, fast, logical_false_node);
6340 : }
6341 : }
6342 :
6343 2231 : gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6344 2231 : if (maskss)
6345 1704 : gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6346 : /* Generate the loop body. */
6347 2231 : gfc_start_scalarized_body (&loop, &body);
6348 :
6349 : /* If we have a mask, only add this element if the mask is set. */
6350 2231 : if (maskss)
6351 : {
6352 1026 : gfc_init_se (&maskse, NULL);
6353 1026 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6354 1026 : maskse.ss = maskss;
6355 1026 : gfc_conv_expr_val (&maskse, maskexpr);
6356 1026 : gfc_add_block_to_block (&body, &maskse.pre);
6357 :
6358 1026 : gfc_start_block (&block);
6359 : }
6360 : else
6361 1205 : gfc_init_block (&block);
6362 :
6363 : /* Compare with the current limit. */
6364 2231 : gfc_init_se (&arrayse, NULL);
6365 2231 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6366 2231 : arrayse.ss = arrayss;
6367 2231 : gfc_conv_expr_val (&arrayse, arrayexpr);
6368 2231 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6369 2231 : gfc_add_block_to_block (&block, &arrayse.pre);
6370 :
6371 2231 : gfc_init_block (&block2);
6372 :
6373 2231 : if (nonempty_var)
6374 582 : gfc_add_modify (&block2, nonempty_var, logical_true_node);
6375 :
6376 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6377 : {
6378 1922 : tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6379 : logical_type_node, arrayse.expr, limit);
6380 1241 : if (lab)
6381 : {
6382 821 : stmtblock_t ifblock;
6383 821 : tree inc_loop;
6384 821 : inc_loop = fold_build2_loc (input_location, PLUS_EXPR,
6385 821 : TREE_TYPE (loop.loopvar[0]),
6386 : loop.loopvar[0], gfc_index_one_node);
6387 821 : gfc_init_block (&ifblock);
6388 821 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6389 821 : gfc_add_modify (&ifblock, loop.loopvar[0], inc_loop);
6390 821 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab));
6391 821 : ifbody = gfc_finish_block (&ifblock);
6392 : }
6393 : else
6394 : {
6395 420 : stmtblock_t ifblock;
6396 :
6397 420 : gfc_init_block (&ifblock);
6398 420 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6399 420 : gfc_add_modify (&ifblock, fast, logical_true_node);
6400 420 : ifbody = gfc_finish_block (&ifblock);
6401 : }
6402 1241 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6403 : build_empty_stmt (input_location));
6404 1241 : gfc_add_expr_to_block (&block2, tmp);
6405 : }
6406 : else
6407 : {
6408 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6409 : signed zeros. */
6410 1535 : tmp = fold_build2_loc (input_location,
6411 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6412 : type, arrayse.expr, limit);
6413 990 : gfc_add_modify (&block2, limit, tmp);
6414 : }
6415 :
6416 2231 : if (fast)
6417 : {
6418 420 : tree elsebody = gfc_finish_block (&block2);
6419 :
6420 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6421 : signed zeros. */
6422 420 : if (HONOR_NANS (DECL_MODE (limit)))
6423 : {
6424 420 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6425 : arrayse.expr, limit);
6426 420 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6427 420 : ifbody = build3_v (COND_EXPR, tmp, ifbody,
6428 : build_empty_stmt (input_location));
6429 : }
6430 : else
6431 : {
6432 0 : tmp = fold_build2_loc (input_location,
6433 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6434 : type, arrayse.expr, limit);
6435 0 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6436 : }
6437 420 : tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6438 420 : gfc_add_expr_to_block (&block, tmp);
6439 : }
6440 : else
6441 1811 : gfc_add_block_to_block (&block, &block2);
6442 :
6443 2231 : gfc_add_block_to_block (&block, &arrayse.post);
6444 :
6445 2231 : tmp = gfc_finish_block (&block);
6446 2231 : if (maskss)
6447 : {
6448 : /* We enclose the above in if (mask) {...}. If the mask is an
6449 : optional argument, generate IF (.NOT. PRESENT(MASK)
6450 : .OR. MASK(I)). */
6451 1026 : tree ifmask;
6452 1026 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6453 1026 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6454 : build_empty_stmt (input_location));
6455 : }
6456 2231 : gfc_add_expr_to_block (&body, tmp);
6457 :
6458 2231 : if (lab)
6459 : {
6460 821 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6461 :
6462 821 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6463 : nan_cst, huge_cst);
6464 821 : gfc_add_modify (&loop.code[0], limit, tmp);
6465 821 : gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6466 :
6467 : /* If we have a mask, only add this element if the mask is set. */
6468 821 : if (maskss)
6469 : {
6470 348 : gfc_init_se (&maskse, NULL);
6471 348 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6472 348 : maskse.ss = maskss;
6473 348 : gfc_conv_expr_val (&maskse, maskexpr);
6474 348 : gfc_add_block_to_block (&body, &maskse.pre);
6475 :
6476 348 : gfc_start_block (&block);
6477 : }
6478 : else
6479 473 : gfc_init_block (&block);
6480 :
6481 : /* Compare with the current limit. */
6482 821 : gfc_init_se (&arrayse, NULL);
6483 821 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6484 821 : arrayse.ss = arrayss;
6485 821 : gfc_conv_expr_val (&arrayse, arrayexpr);
6486 821 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6487 821 : gfc_add_block_to_block (&block, &arrayse.pre);
6488 :
6489 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6490 : signed zeros. */
6491 821 : if (HONOR_NANS (DECL_MODE (limit)))
6492 : {
6493 821 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6494 : arrayse.expr, limit);
6495 821 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6496 821 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6497 : build_empty_stmt (input_location));
6498 821 : gfc_add_expr_to_block (&block, tmp);
6499 : }
6500 : else
6501 : {
6502 0 : tmp = fold_build2_loc (input_location,
6503 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6504 : type, arrayse.expr, limit);
6505 0 : gfc_add_modify (&block, limit, tmp);
6506 : }
6507 :
6508 821 : gfc_add_block_to_block (&block, &arrayse.post);
6509 :
6510 821 : tmp = gfc_finish_block (&block);
6511 821 : if (maskss)
6512 : /* We enclose the above in if (mask) {...}. */
6513 : {
6514 348 : tree ifmask;
6515 348 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6516 348 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6517 : build_empty_stmt (input_location));
6518 : }
6519 :
6520 821 : gfc_add_expr_to_block (&body, tmp);
6521 : /* Avoid initializing loopvar[0] again, it should be left where
6522 : it finished by the first loop. */
6523 821 : loop.from[0] = loop.loopvar[0];
6524 : }
6525 2231 : gfc_trans_scalarizing_loops (&loop, &body);
6526 :
6527 2231 : if (fast)
6528 : {
6529 420 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6530 : nan_cst, huge_cst);
6531 420 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6532 420 : tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6533 : ifbody);
6534 420 : gfc_add_expr_to_block (&loop.pre, tmp);
6535 : }
6536 1811 : else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6537 : {
6538 0 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6539 : huge_cst);
6540 0 : gfc_add_modify (&loop.pre, limit, tmp);
6541 : }
6542 :
6543 : /* For a scalar mask, enclose the loop in an if statement. */
6544 2231 : if (maskexpr && maskss == NULL)
6545 : {
6546 546 : tree else_stmt;
6547 546 : tree ifmask;
6548 :
6549 546 : gfc_init_se (&maskse, NULL);
6550 546 : gfc_conv_expr_val (&maskse, maskexpr);
6551 546 : gfc_init_block (&block);
6552 546 : gfc_add_block_to_block (&block, &loop.pre);
6553 546 : gfc_add_block_to_block (&block, &loop.post);
6554 546 : tmp = gfc_finish_block (&block);
6555 :
6556 546 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6557 354 : else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6558 : else
6559 192 : else_stmt = build_empty_stmt (input_location);
6560 :
6561 546 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6562 546 : tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6563 546 : gfc_add_expr_to_block (&block, tmp);
6564 546 : gfc_add_block_to_block (&se->pre, &block);
6565 : }
6566 : else
6567 : {
6568 1685 : gfc_add_block_to_block (&se->pre, &loop.pre);
6569 1685 : gfc_add_block_to_block (&se->pre, &loop.post);
6570 : }
6571 :
6572 2231 : gfc_cleanup_loop (&loop);
6573 :
6574 2231 : se->expr = limit;
6575 : }
6576 :
6577 : /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6578 : static void
6579 145 : gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6580 : {
6581 145 : tree args[2];
6582 145 : tree type;
6583 145 : tree tmp;
6584 :
6585 145 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6586 145 : type = TREE_TYPE (args[0]);
6587 :
6588 : /* Optionally generate code for runtime argument check. */
6589 145 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6590 : {
6591 6 : tree below = fold_build2_loc (input_location, LT_EXPR,
6592 : logical_type_node, args[1],
6593 6 : build_int_cst (TREE_TYPE (args[1]), 0));
6594 6 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6595 6 : tree above = fold_build2_loc (input_location, GE_EXPR,
6596 : logical_type_node, args[1], nbits);
6597 6 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6598 : logical_type_node, below, above);
6599 6 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6600 : "POS argument (%ld) out of range 0:%ld "
6601 : "in intrinsic BTEST",
6602 : fold_convert (long_integer_type_node, args[1]),
6603 : fold_convert (long_integer_type_node, nbits));
6604 : }
6605 :
6606 145 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6607 : build_int_cst (type, 1), args[1]);
6608 145 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6609 145 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6610 : build_int_cst (type, 0));
6611 145 : type = gfc_typenode_for_spec (&expr->ts);
6612 145 : se->expr = convert (type, tmp);
6613 145 : }
6614 :
6615 :
6616 : /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6617 : static void
6618 216 : gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6619 : {
6620 216 : tree args[2];
6621 :
6622 216 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6623 :
6624 : /* Convert both arguments to the unsigned type of the same size. */
6625 216 : args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6626 216 : args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6627 :
6628 : /* If they have unequal type size, convert to the larger one. */
6629 216 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
6630 216 : > TYPE_PRECISION (TREE_TYPE (args[1])))
6631 0 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6632 216 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6633 216 : > TYPE_PRECISION (TREE_TYPE (args[0])))
6634 0 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6635 :
6636 : /* Now, we compare them. */
6637 216 : se->expr = fold_build2_loc (input_location, op, logical_type_node,
6638 : args[0], args[1]);
6639 216 : }
6640 :
6641 :
6642 : /* Generate code to perform the specified operation. */
6643 : static void
6644 1915 : gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6645 : {
6646 1915 : tree args[2];
6647 :
6648 1915 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6649 1915 : se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6650 : args[0], args[1]);
6651 1915 : }
6652 :
6653 : /* Bitwise not. */
6654 : static void
6655 230 : gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6656 : {
6657 230 : tree arg;
6658 :
6659 230 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6660 230 : se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6661 230 : TREE_TYPE (arg), arg);
6662 230 : }
6663 :
6664 :
6665 : /* Generate code for OUT_OF_RANGE. */
6666 : static void
6667 468 : gfc_conv_intrinsic_out_of_range (gfc_se * se, gfc_expr * expr)
6668 : {
6669 468 : tree *args;
6670 468 : tree type;
6671 468 : tree tmp = NULL_TREE, tmp1, tmp2;
6672 468 : unsigned int num_args;
6673 468 : int k;
6674 468 : gfc_se rnd_se;
6675 468 : gfc_actual_arglist *arg = expr->value.function.actual;
6676 468 : gfc_expr *x = arg->expr;
6677 468 : gfc_expr *mold = arg->next->expr;
6678 :
6679 468 : num_args = gfc_intrinsic_argument_list_length (expr);
6680 468 : args = XALLOCAVEC (tree, num_args);
6681 :
6682 468 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6683 :
6684 468 : gfc_init_se (&rnd_se, NULL);
6685 :
6686 468 : if (num_args == 3)
6687 : {
6688 : /* The ROUND argument is optional and shall appear only if X is
6689 : of type real and MOLD is of type integer (see edit F23/004). */
6690 270 : gfc_expr *round = arg->next->next->expr;
6691 270 : gfc_conv_expr (&rnd_se, round);
6692 :
6693 270 : if (round->expr_type == EXPR_VARIABLE
6694 198 : && round->symtree->n.sym->attr.dummy
6695 30 : && round->symtree->n.sym->attr.optional)
6696 : {
6697 30 : tree present = gfc_conv_expr_present (round->symtree->n.sym);
6698 30 : rnd_se.expr = build3_loc (input_location, COND_EXPR,
6699 : logical_type_node, present,
6700 : rnd_se.expr, logical_false_node);
6701 30 : gfc_add_block_to_block (&se->pre, &rnd_se.pre);
6702 : }
6703 : }
6704 : else
6705 : {
6706 : /* If ROUND is absent, it is equivalent to having the value false. */
6707 198 : rnd_se.expr = logical_false_node;
6708 : }
6709 :
6710 468 : type = TREE_TYPE (args[0]);
6711 468 : k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
6712 :
6713 468 : switch (x->ts.type)
6714 : {
6715 378 : case BT_REAL:
6716 : /* X may be IEEE infinity or NaN, but the representation of MOLD may not
6717 : support infinity or NaN. */
6718 378 : tree finite;
6719 378 : finite = build_call_expr_loc (input_location,
6720 : builtin_decl_explicit (BUILT_IN_ISFINITE),
6721 : 1, args[0]);
6722 378 : finite = convert (logical_type_node, finite);
6723 :
6724 378 : if (mold->ts.type == BT_REAL)
6725 : {
6726 24 : tmp1 = build1 (ABS_EXPR, type, args[0]);
6727 24 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6728 : mold->ts.kind, 0);
6729 24 : tmp = build2 (GT_EXPR, logical_type_node, tmp1,
6730 : convert (type, tmp2));
6731 :
6732 : /* Check if MOLD representation supports infinity or NaN. */
6733 24 : bool infnan = (HONOR_INFINITIES (TREE_TYPE (args[1]))
6734 24 : || HONOR_NANS (TREE_TYPE (args[1])));
6735 24 : tmp = build3 (COND_EXPR, logical_type_node, finite, tmp,
6736 : infnan ? logical_false_node : logical_true_node);
6737 : }
6738 : else
6739 : {
6740 354 : tree rounded;
6741 354 : tree decl;
6742 :
6743 354 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, x->ts.kind);
6744 354 : gcc_assert (decl != NULL_TREE);
6745 :
6746 : /* Round or truncate argument X, depending on the optional argument
6747 : ROUND (default: .false.). */
6748 354 : tmp1 = build_round_expr (args[0], type);
6749 354 : tmp2 = build_call_expr_loc (input_location, decl, 1, args[0]);
6750 354 : rounded = build3 (COND_EXPR, type, rnd_se.expr, tmp1, tmp2);
6751 :
6752 354 : if (mold->ts.type == BT_INTEGER)
6753 : {
6754 180 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6755 : x->ts.kind);
6756 180 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6757 : x->ts.kind);
6758 : }
6759 174 : else if (mold->ts.type == BT_UNSIGNED)
6760 : {
6761 174 : tmp1 = build_real_from_int_cst (type, integer_zero_node);
6762 174 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6763 : x->ts.kind);
6764 : }
6765 : else
6766 0 : gcc_unreachable ();
6767 :
6768 354 : tmp1 = build2 (LT_EXPR, logical_type_node, rounded,
6769 : convert (type, tmp1));
6770 354 : tmp2 = build2 (GT_EXPR, logical_type_node, rounded,
6771 : convert (type, tmp2));
6772 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6773 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node,
6774 : build1 (TRUTH_NOT_EXPR, logical_type_node, finite),
6775 : tmp);
6776 : }
6777 : break;
6778 :
6779 48 : case BT_INTEGER:
6780 48 : if (mold->ts.type == BT_INTEGER)
6781 : {
6782 12 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6783 : x->ts.kind);
6784 12 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6785 : x->ts.kind);
6786 12 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6787 : convert (type, tmp1));
6788 12 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6789 : convert (type, tmp2));
6790 12 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6791 : }
6792 36 : else if (mold->ts.type == BT_UNSIGNED)
6793 : {
6794 36 : int i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6795 36 : tmp = build_int_cst (type, 0);
6796 36 : tmp = build2 (LT_EXPR, logical_type_node, args[0], tmp);
6797 36 : if (mpz_cmp (gfc_integer_kinds[i].huge,
6798 36 : gfc_unsigned_kinds[k].huge) > 0)
6799 : {
6800 0 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6801 : x->ts.kind);
6802 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6803 : convert (type, tmp2));
6804 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp, tmp2);
6805 : }
6806 : }
6807 0 : else if (mold->ts.type == BT_REAL)
6808 : {
6809 0 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6810 : mold->ts.kind, 0);
6811 0 : tmp1 = build1 (NEGATE_EXPR, TREE_TYPE (tmp2), tmp2);
6812 0 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6813 : convert (type, tmp1));
6814 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6815 : convert (type, tmp2));
6816 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6817 : }
6818 : else
6819 0 : gcc_unreachable ();
6820 : break;
6821 :
6822 42 : case BT_UNSIGNED:
6823 42 : if (mold->ts.type == BT_UNSIGNED)
6824 : {
6825 12 : tmp = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6826 : x->ts.kind);
6827 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6828 : convert (type, tmp));
6829 : }
6830 30 : else if (mold->ts.type == BT_INTEGER)
6831 : {
6832 18 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6833 : x->ts.kind);
6834 18 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6835 : convert (type, tmp));
6836 : }
6837 12 : else if (mold->ts.type == BT_REAL)
6838 : {
6839 12 : tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6840 : mold->ts.kind, 0);
6841 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6842 : convert (type, tmp));
6843 : }
6844 : else
6845 0 : gcc_unreachable ();
6846 : break;
6847 :
6848 0 : default:
6849 0 : gcc_unreachable ();
6850 : }
6851 :
6852 468 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6853 468 : }
6854 :
6855 :
6856 : /* Set or clear a single bit. */
6857 : static void
6858 306 : gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6859 : {
6860 306 : tree args[2];
6861 306 : tree type;
6862 306 : tree tmp;
6863 306 : enum tree_code op;
6864 :
6865 306 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6866 306 : type = TREE_TYPE (args[0]);
6867 :
6868 : /* Optionally generate code for runtime argument check. */
6869 306 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6870 : {
6871 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6872 : logical_type_node, args[1],
6873 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6874 12 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6875 12 : tree above = fold_build2_loc (input_location, GE_EXPR,
6876 : logical_type_node, args[1], nbits);
6877 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6878 : logical_type_node, below, above);
6879 12 : size_t len_name = strlen (expr->value.function.isym->name);
6880 12 : char *name = XALLOCAVEC (char, len_name + 1);
6881 72 : for (size_t i = 0; i < len_name; i++)
6882 60 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
6883 12 : name[len_name] = '\0';
6884 12 : tree iname = gfc_build_addr_expr (pchar_type_node,
6885 : gfc_build_cstring_const (name));
6886 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6887 : "POS argument (%ld) out of range 0:%ld "
6888 : "in intrinsic %s",
6889 : fold_convert (long_integer_type_node, args[1]),
6890 : fold_convert (long_integer_type_node, nbits),
6891 : iname);
6892 : }
6893 :
6894 306 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6895 : build_int_cst (type, 1), args[1]);
6896 306 : if (set)
6897 : op = BIT_IOR_EXPR;
6898 : else
6899 : {
6900 168 : op = BIT_AND_EXPR;
6901 168 : tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6902 : }
6903 306 : se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6904 306 : }
6905 :
6906 : /* Extract a sequence of bits.
6907 : IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6908 : static void
6909 27 : gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6910 : {
6911 27 : tree args[3];
6912 27 : tree type;
6913 27 : tree tmp;
6914 27 : tree mask;
6915 27 : tree num_bits, cond;
6916 :
6917 27 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
6918 27 : type = TREE_TYPE (args[0]);
6919 :
6920 : /* Optionally generate code for runtime argument check. */
6921 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6922 : {
6923 12 : tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6924 12 : tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6925 12 : tree nbits = build_int_cst (long_integer_type_node,
6926 12 : TYPE_PRECISION (type));
6927 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6928 : logical_type_node, args[1],
6929 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6930 12 : tree above = fold_build2_loc (input_location, GT_EXPR,
6931 : logical_type_node, tmp1, nbits);
6932 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6933 : logical_type_node, below, above);
6934 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6935 : "POS argument (%ld) out of range 0:%ld "
6936 : "in intrinsic IBITS", tmp1, nbits);
6937 12 : below = fold_build2_loc (input_location, LT_EXPR,
6938 : logical_type_node, args[2],
6939 12 : build_int_cst (TREE_TYPE (args[2]), 0));
6940 12 : above = fold_build2_loc (input_location, GT_EXPR,
6941 : logical_type_node, tmp2, nbits);
6942 12 : scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6943 : logical_type_node, below, above);
6944 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6945 : "LEN argument (%ld) out of range 0:%ld "
6946 : "in intrinsic IBITS", tmp2, nbits);
6947 12 : above = fold_build2_loc (input_location, PLUS_EXPR,
6948 : long_integer_type_node, tmp1, tmp2);
6949 12 : scond = fold_build2_loc (input_location, GT_EXPR,
6950 : logical_type_node, above, nbits);
6951 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6952 : "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6953 : "in intrinsic IBITS", tmp1, tmp2, nbits);
6954 : }
6955 :
6956 : /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6957 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6958 : special case. See also gfc_conv_intrinsic_ishft (). */
6959 27 : num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
6960 :
6961 27 : mask = build_int_cst (type, -1);
6962 27 : mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6963 27 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
6964 : num_bits);
6965 27 : mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
6966 : build_int_cst (type, 0), mask);
6967 27 : mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6968 :
6969 27 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6970 :
6971 27 : se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6972 27 : }
6973 :
6974 : static void
6975 492 : gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6976 : bool arithmetic)
6977 : {
6978 492 : tree args[2], type, num_bits, cond;
6979 492 : tree bigshift;
6980 492 : bool do_convert = false;
6981 :
6982 492 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6983 :
6984 492 : args[0] = gfc_evaluate_now (args[0], &se->pre);
6985 492 : args[1] = gfc_evaluate_now (args[1], &se->pre);
6986 492 : type = TREE_TYPE (args[0]);
6987 :
6988 492 : if (!arithmetic)
6989 : {
6990 390 : args[0] = fold_convert (unsigned_type_for (type), args[0]);
6991 390 : do_convert = true;
6992 : }
6993 : else
6994 102 : gcc_assert (right_shift);
6995 :
6996 492 : if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED)
6997 : {
6998 30 : do_convert = true;
6999 30 : args[0] = fold_convert (signed_type_for (type), args[0]);
7000 : }
7001 :
7002 816 : se->expr = fold_build2_loc (input_location,
7003 : right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
7004 492 : TREE_TYPE (args[0]), args[0], args[1]);
7005 :
7006 492 : if (do_convert)
7007 420 : se->expr = fold_convert (type, se->expr);
7008 :
7009 492 : if (!arithmetic)
7010 390 : bigshift = build_int_cst (type, 0);
7011 : else
7012 : {
7013 102 : tree nonneg = fold_build2_loc (input_location, GE_EXPR,
7014 : logical_type_node, args[0],
7015 102 : build_int_cst (TREE_TYPE (args[0]), 0));
7016 102 : bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
7017 : build_int_cst (type, 0),
7018 : build_int_cst (type, -1));
7019 : }
7020 :
7021 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7022 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7023 : special case. */
7024 492 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7025 :
7026 : /* Optionally generate code for runtime argument check. */
7027 492 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7028 : {
7029 30 : tree below = fold_build2_loc (input_location, LT_EXPR,
7030 : logical_type_node, args[1],
7031 30 : build_int_cst (TREE_TYPE (args[1]), 0));
7032 30 : tree above = fold_build2_loc (input_location, GT_EXPR,
7033 : logical_type_node, args[1], num_bits);
7034 30 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7035 : logical_type_node, below, above);
7036 30 : size_t len_name = strlen (expr->value.function.isym->name);
7037 30 : char *name = XALLOCAVEC (char, len_name + 1);
7038 210 : for (size_t i = 0; i < len_name; i++)
7039 180 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
7040 30 : name[len_name] = '\0';
7041 30 : tree iname = gfc_build_addr_expr (pchar_type_node,
7042 : gfc_build_cstring_const (name));
7043 30 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7044 : "SHIFT argument (%ld) out of range 0:%ld "
7045 : "in intrinsic %s",
7046 : fold_convert (long_integer_type_node, args[1]),
7047 : fold_convert (long_integer_type_node, num_bits),
7048 : iname);
7049 : }
7050 :
7051 492 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7052 : args[1], num_bits);
7053 :
7054 492 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7055 : bigshift, se->expr);
7056 492 : }
7057 :
7058 : /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
7059 : ? 0
7060 : : ((shift >= 0) ? i << shift : i >> -shift)
7061 : where all shifts are logical shifts. */
7062 : static void
7063 318 : gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
7064 : {
7065 318 : tree args[2];
7066 318 : tree type;
7067 318 : tree utype;
7068 318 : tree tmp;
7069 318 : tree width;
7070 318 : tree num_bits;
7071 318 : tree cond;
7072 318 : tree lshift;
7073 318 : tree rshift;
7074 :
7075 318 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7076 :
7077 318 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7078 318 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7079 :
7080 318 : type = TREE_TYPE (args[0]);
7081 318 : utype = unsigned_type_for (type);
7082 :
7083 318 : width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
7084 : args[1]);
7085 :
7086 : /* Left shift if positive. */
7087 318 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
7088 :
7089 : /* Right shift if negative.
7090 : We convert to an unsigned type because we want a logical shift.
7091 : The standard doesn't define the case of shifting negative
7092 : numbers, and we try to be compatible with other compilers, most
7093 : notably g77, here. */
7094 318 : rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
7095 : utype, convert (utype, args[0]), width));
7096 :
7097 318 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
7098 318 : build_int_cst (TREE_TYPE (args[1]), 0));
7099 318 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
7100 :
7101 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7102 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7103 : special case. */
7104 318 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7105 :
7106 : /* Optionally generate code for runtime argument check. */
7107 318 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7108 : {
7109 24 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7110 : logical_type_node, width, num_bits);
7111 24 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7112 : "SHIFT argument (%ld) out of range -%ld:%ld "
7113 : "in intrinsic ISHFT",
7114 : fold_convert (long_integer_type_node, args[1]),
7115 : fold_convert (long_integer_type_node, num_bits),
7116 : fold_convert (long_integer_type_node, num_bits));
7117 : }
7118 :
7119 318 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
7120 : num_bits);
7121 318 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7122 : build_int_cst (type, 0), tmp);
7123 318 : }
7124 :
7125 :
7126 : /* Circular shift. AKA rotate or barrel shift. */
7127 :
7128 : static void
7129 658 : gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
7130 : {
7131 658 : tree *args;
7132 658 : tree type;
7133 658 : tree tmp;
7134 658 : tree lrot;
7135 658 : tree rrot;
7136 658 : tree zero;
7137 658 : tree nbits;
7138 658 : unsigned int num_args;
7139 :
7140 658 : num_args = gfc_intrinsic_argument_list_length (expr);
7141 658 : args = XALLOCAVEC (tree, num_args);
7142 :
7143 658 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7144 :
7145 658 : type = TREE_TYPE (args[0]);
7146 658 : nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
7147 :
7148 658 : if (num_args == 3)
7149 : {
7150 550 : gfc_expr *size = expr->value.function.actual->next->next->expr;
7151 :
7152 : /* Use a library function for the 3 parameter version. */
7153 550 : tree int4type = gfc_get_int_type (4);
7154 :
7155 : /* Treat optional SIZE argument when it is passed as an optional
7156 : dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
7157 550 : if (size->expr_type == EXPR_VARIABLE
7158 438 : && size->symtree->n.sym->attr.dummy
7159 36 : && size->symtree->n.sym->attr.optional)
7160 : {
7161 36 : tree type_of_size = TREE_TYPE (args[2]);
7162 72 : args[2] = build3_loc (input_location, COND_EXPR, type_of_size,
7163 36 : gfc_conv_expr_present (size->symtree->n.sym),
7164 : args[2], fold_convert (type_of_size, nbits));
7165 : }
7166 :
7167 : /* We convert the first argument to at least 4 bytes, and
7168 : convert back afterwards. This removes the need for library
7169 : functions for all argument sizes, and function will be
7170 : aligned to at least 32 bits, so there's no loss. */
7171 550 : if (expr->ts.kind < 4)
7172 242 : args[0] = convert (int4type, args[0]);
7173 :
7174 : /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
7175 : need loads of library functions. They cannot have values >
7176 : BIT_SIZE (I) so the conversion is safe. */
7177 550 : args[1] = convert (int4type, args[1]);
7178 550 : args[2] = convert (int4type, args[2]);
7179 :
7180 : /* Optionally generate code for runtime argument check. */
7181 550 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7182 : {
7183 18 : tree size = fold_convert (long_integer_type_node, args[2]);
7184 18 : tree below = fold_build2_loc (input_location, LE_EXPR,
7185 : logical_type_node, size,
7186 18 : build_int_cst (TREE_TYPE (args[1]), 0));
7187 18 : tree above = fold_build2_loc (input_location, GT_EXPR,
7188 : logical_type_node, size, nbits);
7189 18 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7190 : logical_type_node, below, above);
7191 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7192 : "SIZE argument (%ld) out of range 1:%ld "
7193 : "in intrinsic ISHFTC", size, nbits);
7194 18 : tree width = fold_convert (long_integer_type_node, args[1]);
7195 18 : width = fold_build1_loc (input_location, ABS_EXPR,
7196 : long_integer_type_node, width);
7197 18 : scond = fold_build2_loc (input_location, GT_EXPR,
7198 : logical_type_node, width, size);
7199 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7200 : "SHIFT argument (%ld) out of range -%ld:%ld "
7201 : "in intrinsic ISHFTC",
7202 : fold_convert (long_integer_type_node, args[1]),
7203 : size, size);
7204 : }
7205 :
7206 550 : switch (expr->ts.kind)
7207 : {
7208 426 : case 1:
7209 426 : case 2:
7210 426 : case 4:
7211 426 : tmp = gfor_fndecl_math_ishftc4;
7212 426 : break;
7213 124 : case 8:
7214 124 : tmp = gfor_fndecl_math_ishftc8;
7215 124 : break;
7216 0 : case 16:
7217 0 : tmp = gfor_fndecl_math_ishftc16;
7218 0 : break;
7219 0 : default:
7220 0 : gcc_unreachable ();
7221 : }
7222 550 : se->expr = build_call_expr_loc (input_location,
7223 : tmp, 3, args[0], args[1], args[2]);
7224 : /* Convert the result back to the original type, if we extended
7225 : the first argument's width above. */
7226 550 : if (expr->ts.kind < 4)
7227 242 : se->expr = convert (type, se->expr);
7228 :
7229 550 : return;
7230 : }
7231 :
7232 : /* Evaluate arguments only once. */
7233 108 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7234 108 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7235 :
7236 : /* Optionally generate code for runtime argument check. */
7237 108 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7238 : {
7239 12 : tree width = fold_convert (long_integer_type_node, args[1]);
7240 12 : width = fold_build1_loc (input_location, ABS_EXPR,
7241 : long_integer_type_node, width);
7242 12 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7243 : logical_type_node, width, nbits);
7244 12 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7245 : "SHIFT argument (%ld) out of range -%ld:%ld "
7246 : "in intrinsic ISHFTC",
7247 : fold_convert (long_integer_type_node, args[1]),
7248 : nbits, nbits);
7249 : }
7250 :
7251 : /* Rotate left if positive. */
7252 108 : lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
7253 :
7254 : /* Rotate right if negative. */
7255 108 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
7256 : args[1]);
7257 108 : rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
7258 :
7259 108 : zero = build_int_cst (TREE_TYPE (args[1]), 0);
7260 108 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
7261 : zero);
7262 108 : rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
7263 :
7264 : /* Do nothing if shift == 0. */
7265 108 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
7266 : zero);
7267 108 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
7268 : rrot);
7269 : }
7270 :
7271 :
7272 : /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7273 : : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7274 :
7275 : The conditional expression is necessary because the result of LEADZ(0)
7276 : is defined, but the result of __builtin_clz(0) is undefined for most
7277 : targets.
7278 :
7279 : For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7280 : difference in bit size between the argument of LEADZ and the C int. */
7281 :
7282 : static void
7283 270 : gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7284 : {
7285 270 : tree arg;
7286 270 : tree arg_type;
7287 270 : tree cond;
7288 270 : tree result_type;
7289 270 : tree leadz;
7290 270 : tree bit_size;
7291 270 : tree tmp;
7292 270 : tree func;
7293 270 : int s, argsize;
7294 :
7295 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7296 270 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7297 :
7298 : /* Which variant of __builtin_clz* should we call? */
7299 270 : if (argsize <= INT_TYPE_SIZE)
7300 : {
7301 183 : arg_type = unsigned_type_node;
7302 183 : func = builtin_decl_explicit (BUILT_IN_CLZ);
7303 : }
7304 87 : else if (argsize <= LONG_TYPE_SIZE)
7305 : {
7306 57 : arg_type = long_unsigned_type_node;
7307 57 : func = builtin_decl_explicit (BUILT_IN_CLZL);
7308 : }
7309 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7310 : {
7311 0 : arg_type = long_long_unsigned_type_node;
7312 0 : func = builtin_decl_explicit (BUILT_IN_CLZLL);
7313 : }
7314 : else
7315 : {
7316 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7317 30 : arg_type = gfc_build_uint_type (argsize);
7318 30 : func = NULL_TREE;
7319 : }
7320 :
7321 : /* Convert the actual argument twice: first, to the unsigned type of the
7322 : same size; then, to the proper argument type for the built-in
7323 : function. But the return type is of the default INTEGER kind. */
7324 270 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7325 270 : arg = fold_convert (arg_type, arg);
7326 270 : arg = gfc_evaluate_now (arg, &se->pre);
7327 270 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7328 :
7329 : /* Compute LEADZ for the case i .ne. 0. */
7330 270 : if (func)
7331 : {
7332 240 : s = TYPE_PRECISION (arg_type) - argsize;
7333 240 : tmp = fold_convert (result_type,
7334 : build_call_expr_loc (input_location, func,
7335 : 1, arg));
7336 240 : leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7337 240 : tmp, build_int_cst (result_type, s));
7338 : }
7339 : else
7340 : {
7341 : /* We end up here if the argument type is larger than 'long long'.
7342 : We generate this code:
7343 :
7344 : if (x & (ULL_MAX << ULL_SIZE) != 0)
7345 : return clzll ((unsigned long long) (x >> ULLSIZE));
7346 : else
7347 : return ULL_SIZE + clzll ((unsigned long long) x);
7348 : where ULL_MAX is the largest value that a ULL_MAX can hold
7349 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7350 : is the bit-size of the long long type (64 in this example). */
7351 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7352 :
7353 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7354 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7355 : long_long_unsigned_type_node,
7356 : build_int_cst (long_long_unsigned_type_node,
7357 : 0));
7358 :
7359 30 : cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7360 : fold_convert (arg_type, ullmax), ullsize);
7361 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7362 : arg, cond);
7363 30 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7364 : cond, build_int_cst (arg_type, 0));
7365 :
7366 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7367 : arg, ullsize);
7368 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7369 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7370 30 : tmp1 = fold_convert (result_type,
7371 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7372 :
7373 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7374 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7375 30 : tmp2 = fold_convert (result_type,
7376 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7377 30 : tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7378 : tmp2, ullsize);
7379 :
7380 30 : leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7381 : cond, tmp1, tmp2);
7382 : }
7383 :
7384 : /* Build BIT_SIZE. */
7385 270 : bit_size = build_int_cst (result_type, argsize);
7386 :
7387 270 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7388 : arg, build_int_cst (arg_type, 0));
7389 270 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7390 : bit_size, leadz);
7391 270 : }
7392 :
7393 :
7394 : /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7395 :
7396 : The conditional expression is necessary because the result of TRAILZ(0)
7397 : is defined, but the result of __builtin_ctz(0) is undefined for most
7398 : targets. */
7399 :
7400 : static void
7401 282 : gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7402 : {
7403 282 : tree arg;
7404 282 : tree arg_type;
7405 282 : tree cond;
7406 282 : tree result_type;
7407 282 : tree trailz;
7408 282 : tree bit_size;
7409 282 : tree func;
7410 282 : int argsize;
7411 :
7412 282 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7413 282 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7414 :
7415 : /* Which variant of __builtin_ctz* should we call? */
7416 282 : if (argsize <= INT_TYPE_SIZE)
7417 : {
7418 195 : arg_type = unsigned_type_node;
7419 195 : func = builtin_decl_explicit (BUILT_IN_CTZ);
7420 : }
7421 87 : else if (argsize <= LONG_TYPE_SIZE)
7422 : {
7423 57 : arg_type = long_unsigned_type_node;
7424 57 : func = builtin_decl_explicit (BUILT_IN_CTZL);
7425 : }
7426 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7427 : {
7428 0 : arg_type = long_long_unsigned_type_node;
7429 0 : func = builtin_decl_explicit (BUILT_IN_CTZLL);
7430 : }
7431 : else
7432 : {
7433 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7434 30 : arg_type = gfc_build_uint_type (argsize);
7435 30 : func = NULL_TREE;
7436 : }
7437 :
7438 : /* Convert the actual argument twice: first, to the unsigned type of the
7439 : same size; then, to the proper argument type for the built-in
7440 : function. But the return type is of the default INTEGER kind. */
7441 282 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7442 282 : arg = fold_convert (arg_type, arg);
7443 282 : arg = gfc_evaluate_now (arg, &se->pre);
7444 282 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7445 :
7446 : /* Compute TRAILZ for the case i .ne. 0. */
7447 282 : if (func)
7448 252 : trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7449 : func, 1, arg));
7450 : else
7451 : {
7452 : /* We end up here if the argument type is larger than 'long long'.
7453 : We generate this code:
7454 :
7455 : if ((x & ULL_MAX) == 0)
7456 : return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7457 : else
7458 : return ctzll ((unsigned long long) x);
7459 :
7460 : where ULL_MAX is the largest value that a ULL_MAX can hold
7461 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7462 : is the bit-size of the long long type (64 in this example). */
7463 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7464 :
7465 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7466 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7467 : long_long_unsigned_type_node,
7468 : build_int_cst (long_long_unsigned_type_node, 0));
7469 :
7470 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7471 : fold_convert (arg_type, ullmax));
7472 30 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7473 : build_int_cst (arg_type, 0));
7474 :
7475 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7476 : arg, ullsize);
7477 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7478 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7479 30 : tmp1 = fold_convert (result_type,
7480 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7481 30 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7482 : tmp1, ullsize);
7483 :
7484 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7485 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7486 30 : tmp2 = fold_convert (result_type,
7487 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7488 :
7489 30 : trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7490 : cond, tmp1, tmp2);
7491 : }
7492 :
7493 : /* Build BIT_SIZE. */
7494 282 : bit_size = build_int_cst (result_type, argsize);
7495 :
7496 282 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7497 : arg, build_int_cst (arg_type, 0));
7498 282 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7499 : bit_size, trailz);
7500 282 : }
7501 :
7502 : /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7503 : for types larger than "long long", we call the long long built-in for
7504 : the lower and higher bits and combine the result. */
7505 :
7506 : static void
7507 134 : gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7508 : {
7509 134 : tree arg;
7510 134 : tree arg_type;
7511 134 : tree result_type;
7512 134 : tree func;
7513 134 : int argsize;
7514 :
7515 134 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7516 134 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7517 134 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7518 :
7519 : /* Which variant of the builtin should we call? */
7520 134 : if (argsize <= INT_TYPE_SIZE)
7521 : {
7522 108 : arg_type = unsigned_type_node;
7523 198 : func = builtin_decl_explicit (parity
7524 : ? BUILT_IN_PARITY
7525 : : BUILT_IN_POPCOUNT);
7526 : }
7527 26 : else if (argsize <= LONG_TYPE_SIZE)
7528 : {
7529 12 : arg_type = long_unsigned_type_node;
7530 18 : func = builtin_decl_explicit (parity
7531 : ? BUILT_IN_PARITYL
7532 : : BUILT_IN_POPCOUNTL);
7533 : }
7534 14 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7535 : {
7536 0 : arg_type = long_long_unsigned_type_node;
7537 0 : func = builtin_decl_explicit (parity
7538 : ? BUILT_IN_PARITYLL
7539 : : BUILT_IN_POPCOUNTLL);
7540 : }
7541 : else
7542 : {
7543 : /* Our argument type is larger than 'long long', which mean none
7544 : of the POPCOUNT builtins covers it. We thus call the 'long long'
7545 : variant multiple times, and add the results. */
7546 14 : tree utype, arg2, call1, call2;
7547 :
7548 : /* For now, we only cover the case where argsize is twice as large
7549 : as 'long long'. */
7550 14 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7551 :
7552 21 : func = builtin_decl_explicit (parity
7553 : ? BUILT_IN_PARITYLL
7554 : : BUILT_IN_POPCOUNTLL);
7555 :
7556 : /* Convert it to an integer, and store into a variable. */
7557 14 : utype = gfc_build_uint_type (argsize);
7558 14 : arg = fold_convert (utype, arg);
7559 14 : arg = gfc_evaluate_now (arg, &se->pre);
7560 :
7561 : /* Call the builtin twice. */
7562 14 : call1 = build_call_expr_loc (input_location, func, 1,
7563 : fold_convert (long_long_unsigned_type_node,
7564 : arg));
7565 :
7566 14 : arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7567 : build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7568 14 : call2 = build_call_expr_loc (input_location, func, 1,
7569 : fold_convert (long_long_unsigned_type_node,
7570 : arg2));
7571 :
7572 : /* Combine the results. */
7573 14 : if (parity)
7574 7 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7575 : integer_type_node, call1, call2);
7576 : else
7577 7 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7578 : integer_type_node, call1, call2);
7579 :
7580 14 : se->expr = convert (result_type, se->expr);
7581 14 : return;
7582 : }
7583 :
7584 : /* Convert the actual argument twice: first, to the unsigned type of the
7585 : same size; then, to the proper argument type for the built-in
7586 : function. */
7587 120 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7588 120 : arg = fold_convert (arg_type, arg);
7589 :
7590 120 : se->expr = fold_convert (result_type,
7591 : build_call_expr_loc (input_location, func, 1, arg));
7592 : }
7593 :
7594 :
7595 : /* Process an intrinsic with unspecified argument-types that has an optional
7596 : argument (which could be of type character), e.g. EOSHIFT. For those, we
7597 : need to append the string length of the optional argument if it is not
7598 : present and the type is really character.
7599 : primary specifies the position (starting at 1) of the non-optional argument
7600 : specifying the type and optional gives the position of the optional
7601 : argument in the arglist. */
7602 :
7603 : static void
7604 5825 : conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7605 : unsigned primary, unsigned optional)
7606 : {
7607 5825 : gfc_actual_arglist* prim_arg;
7608 5825 : gfc_actual_arglist* opt_arg;
7609 5825 : unsigned cur_pos;
7610 5825 : gfc_actual_arglist* arg;
7611 5825 : gfc_symbol* sym;
7612 5825 : vec<tree, va_gc> *append_args;
7613 :
7614 : /* Find the two arguments given as position. */
7615 5825 : cur_pos = 0;
7616 5825 : prim_arg = NULL;
7617 5825 : opt_arg = NULL;
7618 17475 : for (arg = expr->value.function.actual; arg; arg = arg->next)
7619 : {
7620 17475 : ++cur_pos;
7621 :
7622 17475 : if (cur_pos == primary)
7623 5825 : prim_arg = arg;
7624 17475 : if (cur_pos == optional)
7625 5825 : opt_arg = arg;
7626 :
7627 17475 : if (cur_pos >= primary && cur_pos >= optional)
7628 : break;
7629 : }
7630 5825 : gcc_assert (prim_arg);
7631 5825 : gcc_assert (prim_arg->expr);
7632 5825 : gcc_assert (opt_arg);
7633 :
7634 : /* If we do have type CHARACTER and the optional argument is really absent,
7635 : append a dummy 0 as string length. */
7636 5825 : append_args = NULL;
7637 5825 : if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7638 : {
7639 608 : tree dummy;
7640 :
7641 608 : dummy = build_int_cst (gfc_charlen_type_node, 0);
7642 608 : vec_alloc (append_args, 1);
7643 608 : append_args->quick_push (dummy);
7644 : }
7645 :
7646 : /* Build the call itself. */
7647 5825 : gcc_assert (!se->ignore_optional);
7648 5825 : sym = gfc_get_symbol_for_expr (expr, false);
7649 5825 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7650 : append_args);
7651 5825 : gfc_free_symbol (sym);
7652 5825 : }
7653 :
7654 : /* The length of a character string. */
7655 : static void
7656 5765 : gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7657 : {
7658 5765 : tree len;
7659 5765 : tree type;
7660 5765 : tree decl;
7661 5765 : gfc_symbol *sym;
7662 5765 : gfc_se argse;
7663 5765 : gfc_expr *arg;
7664 :
7665 5765 : gcc_assert (!se->ss);
7666 :
7667 5765 : arg = expr->value.function.actual->expr;
7668 :
7669 5765 : type = gfc_typenode_for_spec (&expr->ts);
7670 5765 : switch (arg->expr_type)
7671 : {
7672 0 : case EXPR_CONSTANT:
7673 0 : len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7674 0 : break;
7675 :
7676 2 : case EXPR_ARRAY:
7677 : /* If there is an explicit type-spec, use it. */
7678 2 : if (arg->ts.u.cl->length && arg->ts.u.cl->length_from_typespec)
7679 : {
7680 0 : gfc_conv_string_length (arg->ts.u.cl, arg, &se->pre);
7681 0 : len = arg->ts.u.cl->backend_decl;
7682 0 : break;
7683 : }
7684 :
7685 : /* Obtain the string length from the function used by
7686 : trans-array.cc(gfc_trans_array_constructor). */
7687 2 : len = NULL_TREE;
7688 2 : get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7689 2 : break;
7690 :
7691 5178 : case EXPR_VARIABLE:
7692 5178 : if (arg->ref == NULL
7693 2385 : || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7694 : {
7695 : /* This doesn't catch all cases.
7696 : See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7697 : and the surrounding thread. */
7698 4646 : sym = arg->symtree->n.sym;
7699 4646 : decl = gfc_get_symbol_decl (sym);
7700 4646 : if (decl == current_function_decl && sym->attr.function
7701 55 : && (sym->result == sym))
7702 55 : decl = gfc_get_fake_result_decl (sym, 0);
7703 :
7704 4646 : len = sym->ts.u.cl->backend_decl;
7705 4646 : gcc_assert (len);
7706 : break;
7707 : }
7708 :
7709 : /* Fall through. */
7710 :
7711 1117 : default:
7712 1117 : gfc_init_se (&argse, se);
7713 1117 : if (arg->rank == 0)
7714 995 : gfc_conv_expr (&argse, arg);
7715 : else
7716 122 : gfc_conv_expr_descriptor (&argse, arg);
7717 1117 : gfc_add_block_to_block (&se->pre, &argse.pre);
7718 1117 : gfc_add_block_to_block (&se->post, &argse.post);
7719 1117 : len = argse.string_length;
7720 1117 : break;
7721 : }
7722 5765 : se->expr = convert (type, len);
7723 5765 : }
7724 :
7725 : /* The length of a character string not including trailing blanks. */
7726 : static void
7727 2333 : gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7728 : {
7729 2333 : int kind = expr->value.function.actual->expr->ts.kind;
7730 2333 : tree args[2], type, fndecl;
7731 :
7732 2333 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7733 2333 : type = gfc_typenode_for_spec (&expr->ts);
7734 :
7735 2333 : if (kind == 1)
7736 1931 : fndecl = gfor_fndecl_string_len_trim;
7737 402 : else if (kind == 4)
7738 402 : fndecl = gfor_fndecl_string_len_trim_char4;
7739 : else
7740 0 : gcc_unreachable ();
7741 :
7742 2333 : se->expr = build_call_expr_loc (input_location,
7743 : fndecl, 2, args[0], args[1]);
7744 2333 : se->expr = convert (type, se->expr);
7745 2333 : }
7746 :
7747 :
7748 : /* Returns the starting position of a substring within a string. */
7749 :
7750 : static void
7751 751 : gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7752 : tree function)
7753 : {
7754 751 : tree logical4_type_node = gfc_get_logical_type (4);
7755 751 : tree type;
7756 751 : tree fndecl;
7757 751 : tree *args;
7758 751 : unsigned int num_args;
7759 :
7760 751 : args = XALLOCAVEC (tree, 5);
7761 :
7762 : /* Get number of arguments; characters count double due to the
7763 : string length argument. Kind= is not passed to the library
7764 : and thus ignored. */
7765 751 : if (expr->value.function.actual->next->next->expr == NULL)
7766 : num_args = 4;
7767 : else
7768 304 : num_args = 5;
7769 :
7770 751 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7771 751 : type = gfc_typenode_for_spec (&expr->ts);
7772 :
7773 751 : if (num_args == 4)
7774 447 : args[4] = build_int_cst (logical4_type_node, 0);
7775 : else
7776 304 : args[4] = convert (logical4_type_node, args[4]);
7777 :
7778 751 : fndecl = build_addr (function);
7779 751 : se->expr = build_call_array_loc (input_location,
7780 751 : TREE_TYPE (TREE_TYPE (function)), fndecl,
7781 : 5, args);
7782 751 : se->expr = convert (type, se->expr);
7783 :
7784 751 : }
7785 :
7786 : /* The ascii value for a single character. */
7787 : static void
7788 2033 : gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7789 : {
7790 2033 : tree args[3], type, pchartype;
7791 2033 : int nargs;
7792 :
7793 2033 : nargs = gfc_intrinsic_argument_list_length (expr);
7794 2033 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7795 2033 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7796 2033 : pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7797 2033 : args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7798 2033 : type = gfc_typenode_for_spec (&expr->ts);
7799 :
7800 2033 : se->expr = build_fold_indirect_ref_loc (input_location,
7801 : args[1]);
7802 2033 : se->expr = convert (type, se->expr);
7803 2033 : }
7804 :
7805 :
7806 : /* Intrinsic ISNAN calls __builtin_isnan. */
7807 :
7808 : static void
7809 432 : gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7810 : {
7811 432 : tree arg;
7812 :
7813 432 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7814 432 : se->expr = build_call_expr_loc (input_location,
7815 : builtin_decl_explicit (BUILT_IN_ISNAN),
7816 : 1, arg);
7817 864 : STRIP_TYPE_NOPS (se->expr);
7818 432 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7819 432 : }
7820 :
7821 :
7822 : /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7823 : their argument against a constant integer value. */
7824 :
7825 : static void
7826 24 : gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7827 : {
7828 24 : tree arg;
7829 :
7830 24 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7831 24 : se->expr = fold_build2_loc (input_location, EQ_EXPR,
7832 : gfc_typenode_for_spec (&expr->ts),
7833 24 : arg, build_int_cst (TREE_TYPE (arg), value));
7834 24 : }
7835 :
7836 :
7837 :
7838 : /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7839 :
7840 : static void
7841 949 : gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7842 : {
7843 949 : tree tsource;
7844 949 : tree fsource;
7845 949 : tree mask;
7846 949 : tree type;
7847 949 : tree len, len2;
7848 949 : tree *args;
7849 949 : unsigned int num_args;
7850 :
7851 949 : num_args = gfc_intrinsic_argument_list_length (expr);
7852 949 : args = XALLOCAVEC (tree, num_args);
7853 :
7854 949 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7855 949 : if (expr->ts.type != BT_CHARACTER)
7856 : {
7857 422 : tsource = args[0];
7858 422 : fsource = args[1];
7859 422 : mask = args[2];
7860 : }
7861 : else
7862 : {
7863 : /* We do the same as in the non-character case, but the argument
7864 : list is different because of the string length arguments. We
7865 : also have to set the string length for the result. */
7866 527 : len = args[0];
7867 527 : tsource = args[1];
7868 527 : len2 = args[2];
7869 527 : fsource = args[3];
7870 527 : mask = args[4];
7871 :
7872 527 : gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7873 : &se->pre);
7874 527 : se->string_length = len;
7875 : }
7876 949 : tsource = gfc_evaluate_now (tsource, &se->pre);
7877 949 : fsource = gfc_evaluate_now (fsource, &se->pre);
7878 949 : mask = gfc_evaluate_now (mask, &se->pre);
7879 949 : type = TREE_TYPE (tsource);
7880 949 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7881 : fold_convert (type, fsource));
7882 949 : }
7883 :
7884 :
7885 : /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7886 :
7887 : static void
7888 42 : gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7889 : {
7890 42 : tree args[3], mask, type;
7891 :
7892 42 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
7893 42 : mask = gfc_evaluate_now (args[2], &se->pre);
7894 :
7895 42 : type = TREE_TYPE (args[0]);
7896 42 : gcc_assert (TREE_TYPE (args[1]) == type);
7897 42 : gcc_assert (TREE_TYPE (mask) == type);
7898 :
7899 42 : args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7900 42 : args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7901 : fold_build1_loc (input_location, BIT_NOT_EXPR,
7902 : type, mask));
7903 42 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7904 : args[0], args[1]);
7905 42 : }
7906 :
7907 :
7908 : /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7909 : MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7910 :
7911 : static void
7912 64 : gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7913 : {
7914 64 : tree arg, allones, type, utype, res, cond, bitsize;
7915 64 : int i;
7916 :
7917 64 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7918 64 : arg = gfc_evaluate_now (arg, &se->pre);
7919 :
7920 64 : type = gfc_get_int_type (expr->ts.kind);
7921 64 : utype = unsigned_type_for (type);
7922 :
7923 64 : i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7924 64 : bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7925 :
7926 64 : allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7927 : build_int_cst (utype, 0));
7928 :
7929 64 : if (left)
7930 : {
7931 : /* Left-justified mask. */
7932 32 : res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7933 : bitsize, arg);
7934 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7935 : fold_convert (utype, res));
7936 :
7937 : /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7938 : smaller than type width. */
7939 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7940 32 : build_int_cst (TREE_TYPE (arg), 0));
7941 32 : res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7942 : build_int_cst (utype, 0), res);
7943 : }
7944 : else
7945 : {
7946 : /* Right-justified mask. */
7947 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7948 : fold_convert (utype, arg));
7949 32 : res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7950 :
7951 : /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7952 : strictly smaller than type width. */
7953 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7954 : arg, bitsize);
7955 32 : res = fold_build3_loc (input_location, COND_EXPR, utype,
7956 : cond, allones, res);
7957 : }
7958 :
7959 64 : se->expr = fold_convert (type, res);
7960 64 : }
7961 :
7962 :
7963 : /* FRACTION (s) is translated into:
7964 : isfinite (s) ? frexp (s, &dummy_int) : NaN */
7965 : static void
7966 60 : gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7967 : {
7968 60 : tree arg, type, tmp, res, frexp, cond;
7969 :
7970 60 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7971 :
7972 60 : type = gfc_typenode_for_spec (&expr->ts);
7973 60 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7974 60 : arg = gfc_evaluate_now (arg, &se->pre);
7975 :
7976 60 : cond = build_call_expr_loc (input_location,
7977 : builtin_decl_explicit (BUILT_IN_ISFINITE),
7978 : 1, arg);
7979 :
7980 60 : tmp = gfc_create_var (integer_type_node, NULL);
7981 60 : res = build_call_expr_loc (input_location, frexp, 2,
7982 : fold_convert (type, arg),
7983 : gfc_build_addr_expr (NULL_TREE, tmp));
7984 60 : res = fold_convert (type, res);
7985 :
7986 60 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7987 : cond, res, gfc_build_nan (type, ""));
7988 60 : }
7989 :
7990 :
7991 : /* NEAREST (s, dir) is translated into
7992 : tmp = copysign (HUGE_VAL, dir);
7993 : return nextafter (s, tmp);
7994 : */
7995 : static void
7996 1595 : gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
7997 : {
7998 1595 : tree args[2], type, tmp, nextafter, copysign, huge_val;
7999 :
8000 1595 : nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
8001 1595 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
8002 :
8003 1595 : type = gfc_typenode_for_spec (&expr->ts);
8004 1595 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8005 :
8006 1595 : huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
8007 1595 : tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
8008 : fold_convert (type, args[1]));
8009 1595 : se->expr = build_call_expr_loc (input_location, nextafter, 2,
8010 : fold_convert (type, args[0]), tmp);
8011 1595 : se->expr = fold_convert (type, se->expr);
8012 1595 : }
8013 :
8014 :
8015 : /* SPACING (s) is translated into
8016 : int e;
8017 : if (!isfinite (s))
8018 : res = NaN;
8019 : else if (s == 0)
8020 : res = tiny;
8021 : else
8022 : {
8023 : frexp (s, &e);
8024 : e = e - prec;
8025 : e = MAX_EXPR (e, emin);
8026 : res = scalbn (1., e);
8027 : }
8028 : return res;
8029 :
8030 : where prec is the precision of s, gfc_real_kinds[k].digits,
8031 : emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
8032 : and tiny is tiny(s), gfc_real_kinds[k].tiny. */
8033 :
8034 : static void
8035 70 : gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
8036 : {
8037 70 : tree arg, type, prec, emin, tiny, res, e;
8038 70 : tree cond, nan, tmp, frexp, scalbn;
8039 70 : int k;
8040 70 : stmtblock_t block;
8041 :
8042 70 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8043 70 : prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
8044 70 : emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
8045 70 : tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
8046 :
8047 70 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8048 70 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8049 :
8050 70 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8051 70 : arg = gfc_evaluate_now (arg, &se->pre);
8052 :
8053 70 : type = gfc_typenode_for_spec (&expr->ts);
8054 70 : e = gfc_create_var (integer_type_node, NULL);
8055 70 : res = gfc_create_var (type, NULL);
8056 :
8057 :
8058 : /* Build the block for s /= 0. */
8059 70 : gfc_start_block (&block);
8060 70 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8061 : gfc_build_addr_expr (NULL_TREE, e));
8062 70 : gfc_add_expr_to_block (&block, tmp);
8063 :
8064 70 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
8065 : prec);
8066 70 : gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
8067 : integer_type_node, tmp, emin));
8068 :
8069 70 : tmp = build_call_expr_loc (input_location, scalbn, 2,
8070 70 : build_real_from_int_cst (type, integer_one_node), e);
8071 70 : gfc_add_modify (&block, res, tmp);
8072 :
8073 : /* Finish by building the IF statement for value zero. */
8074 70 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8075 70 : build_real_from_int_cst (type, integer_zero_node));
8076 70 : tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
8077 : gfc_finish_block (&block));
8078 :
8079 : /* And deal with infinities and NaNs. */
8080 70 : cond = build_call_expr_loc (input_location,
8081 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8082 : 1, arg);
8083 70 : nan = gfc_build_nan (type, "");
8084 70 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
8085 :
8086 70 : gfc_add_expr_to_block (&se->pre, tmp);
8087 70 : se->expr = res;
8088 70 : }
8089 :
8090 :
8091 : /* RRSPACING (s) is translated into
8092 : int e;
8093 : real x;
8094 : x = fabs (s);
8095 : if (isfinite (x))
8096 : {
8097 : if (x != 0)
8098 : {
8099 : frexp (s, &e);
8100 : x = scalbn (x, precision - e);
8101 : }
8102 : }
8103 : else
8104 : x = NaN;
8105 : return x;
8106 :
8107 : where precision is gfc_real_kinds[k].digits. */
8108 :
8109 : static void
8110 48 : gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
8111 : {
8112 48 : tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
8113 48 : int prec, k;
8114 48 : stmtblock_t block;
8115 :
8116 48 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8117 48 : prec = gfc_real_kinds[k].digits;
8118 :
8119 48 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8120 48 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8121 48 : fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
8122 :
8123 48 : type = gfc_typenode_for_spec (&expr->ts);
8124 48 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8125 48 : arg = gfc_evaluate_now (arg, &se->pre);
8126 :
8127 48 : e = gfc_create_var (integer_type_node, NULL);
8128 48 : x = gfc_create_var (type, NULL);
8129 48 : gfc_add_modify (&se->pre, x,
8130 : build_call_expr_loc (input_location, fabs, 1, arg));
8131 :
8132 :
8133 48 : gfc_start_block (&block);
8134 48 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8135 : gfc_build_addr_expr (NULL_TREE, e));
8136 48 : gfc_add_expr_to_block (&block, tmp);
8137 :
8138 48 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
8139 48 : build_int_cst (integer_type_node, prec), e);
8140 48 : tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
8141 48 : gfc_add_modify (&block, x, tmp);
8142 48 : stmt = gfc_finish_block (&block);
8143 :
8144 : /* if (x != 0) */
8145 48 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
8146 48 : build_real_from_int_cst (type, integer_zero_node));
8147 48 : tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
8148 :
8149 : /* And deal with infinities and NaNs. */
8150 48 : cond = build_call_expr_loc (input_location,
8151 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8152 : 1, x);
8153 48 : nan = gfc_build_nan (type, "");
8154 48 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
8155 :
8156 48 : gfc_add_expr_to_block (&se->pre, tmp);
8157 48 : se->expr = fold_convert (type, x);
8158 48 : }
8159 :
8160 :
8161 : /* SCALE (s, i) is translated into scalbn (s, i). */
8162 : static void
8163 72 : gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
8164 : {
8165 72 : tree args[2], type, scalbn;
8166 :
8167 72 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8168 :
8169 72 : type = gfc_typenode_for_spec (&expr->ts);
8170 72 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8171 72 : se->expr = build_call_expr_loc (input_location, scalbn, 2,
8172 : fold_convert (type, args[0]),
8173 : fold_convert (integer_type_node, args[1]));
8174 72 : se->expr = fold_convert (type, se->expr);
8175 72 : }
8176 :
8177 :
8178 : /* SET_EXPONENT (s, i) is translated into
8179 : isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
8180 : static void
8181 262 : gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
8182 : {
8183 262 : tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
8184 :
8185 262 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8186 262 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8187 :
8188 262 : type = gfc_typenode_for_spec (&expr->ts);
8189 262 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8190 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
8191 :
8192 262 : tmp = gfc_create_var (integer_type_node, NULL);
8193 262 : tmp = build_call_expr_loc (input_location, frexp, 2,
8194 : fold_convert (type, args[0]),
8195 : gfc_build_addr_expr (NULL_TREE, tmp));
8196 262 : res = build_call_expr_loc (input_location, scalbn, 2, tmp,
8197 : fold_convert (integer_type_node, args[1]));
8198 262 : res = fold_convert (type, res);
8199 :
8200 : /* Call to isfinite */
8201 262 : cond = build_call_expr_loc (input_location,
8202 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8203 : 1, args[0]);
8204 262 : nan = gfc_build_nan (type, "");
8205 :
8206 262 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
8207 : res, nan);
8208 262 : }
8209 :
8210 :
8211 : static void
8212 15020 : gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
8213 : {
8214 15020 : gfc_actual_arglist *actual;
8215 15020 : tree arg1;
8216 15020 : tree type;
8217 15020 : tree size;
8218 15020 : gfc_se argse;
8219 15020 : gfc_expr *e;
8220 15020 : gfc_symbol *sym = NULL;
8221 :
8222 15020 : gfc_init_se (&argse, NULL);
8223 15020 : actual = expr->value.function.actual;
8224 :
8225 15020 : if (actual->expr->ts.type == BT_CLASS)
8226 579 : gfc_add_class_array_ref (actual->expr);
8227 :
8228 15020 : e = actual->expr;
8229 :
8230 : /* These are emerging from the interface mapping, when a class valued
8231 : function appears as the rhs in a realloc on assign statement, where
8232 : the size of the result is that of one of the actual arguments. */
8233 15020 : if (e->expr_type == EXPR_VARIABLE
8234 14544 : && e->symtree->n.sym->ns == NULL /* This is distinctive! */
8235 555 : && e->symtree->n.sym->ts.type == BT_CLASS
8236 44 : && e->ref && e->ref->type == REF_COMPONENT
8237 26 : && strcmp (e->ref->u.c.component->name, "_data") == 0)
8238 15020 : sym = e->symtree->n.sym;
8239 :
8240 15020 : if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
8241 : && e
8242 854 : && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
8243 : {
8244 854 : symbol_attribute attr;
8245 854 : char *msg;
8246 854 : tree temp;
8247 854 : tree cond;
8248 :
8249 854 : if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
8250 : {
8251 33 : attr = CLASS_DATA (e->symtree->n.sym)->attr;
8252 33 : attr.pointer = attr.class_pointer;
8253 : }
8254 : else
8255 821 : attr = gfc_expr_attr (e);
8256 :
8257 854 : if (attr.allocatable)
8258 100 : msg = xasprintf ("Allocatable argument '%s' is not allocated",
8259 100 : e->symtree->n.sym->name);
8260 754 : else if (attr.pointer)
8261 46 : msg = xasprintf ("Pointer argument '%s' is not associated",
8262 46 : e->symtree->n.sym->name);
8263 : else
8264 708 : goto end_arg_check;
8265 :
8266 146 : if (sym)
8267 : {
8268 0 : temp = gfc_class_data_get (sym->backend_decl);
8269 0 : temp = gfc_conv_descriptor_data_get (temp);
8270 : }
8271 : else
8272 : {
8273 146 : argse.descriptor_only = 1;
8274 146 : gfc_conv_expr_descriptor (&argse, actual->expr);
8275 146 : temp = gfc_conv_descriptor_data_get (argse.expr);
8276 : }
8277 :
8278 146 : cond = fold_build2_loc (input_location, EQ_EXPR,
8279 : logical_type_node, temp,
8280 146 : fold_convert (TREE_TYPE (temp),
8281 : null_pointer_node));
8282 146 : gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
8283 :
8284 146 : free (msg);
8285 : }
8286 14166 : end_arg_check:
8287 :
8288 15020 : argse.data_not_needed = 1;
8289 15020 : if (gfc_is_class_array_function (e))
8290 : {
8291 : /* For functions that return a class array conv_expr_descriptor is not
8292 : able to get the descriptor right. Therefore this special case. */
8293 7 : gfc_conv_expr_reference (&argse, e);
8294 7 : argse.expr = gfc_class_data_get (argse.expr);
8295 : }
8296 15013 : else if (sym && sym->backend_decl)
8297 : {
8298 14 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8299 14 : argse.expr = gfc_class_data_get (sym->backend_decl);
8300 : }
8301 : else
8302 14999 : gfc_conv_expr_descriptor (&argse, actual->expr);
8303 15020 : gfc_add_block_to_block (&se->pre, &argse.pre);
8304 15020 : gfc_add_block_to_block (&se->post, &argse.post);
8305 15020 : arg1 = argse.expr;
8306 :
8307 15020 : actual = actual->next;
8308 15020 : if (actual->expr)
8309 : {
8310 8970 : stmtblock_t block;
8311 8970 : gfc_init_block (&block);
8312 8970 : gfc_init_se (&argse, NULL);
8313 8970 : gfc_conv_expr_type (&argse, actual->expr,
8314 : gfc_array_index_type);
8315 8970 : gfc_add_block_to_block (&block, &argse.pre);
8316 8970 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8317 : argse.expr, gfc_index_one_node);
8318 8970 : size = gfc_tree_array_size (&block, arg1, e, tmp);
8319 :
8320 : /* Unusually, for an intrinsic, size does not exclude
8321 : an optional arg2, so we must test for it. */
8322 8970 : if (actual->expr->expr_type == EXPR_VARIABLE
8323 2335 : && actual->expr->symtree->n.sym->attr.dummy
8324 31 : && actual->expr->symtree->n.sym->attr.optional)
8325 : {
8326 31 : tree cond;
8327 31 : stmtblock_t block2;
8328 31 : gfc_init_block (&block2);
8329 31 : gfc_init_se (&argse, NULL);
8330 31 : argse.want_pointer = 1;
8331 31 : argse.data_not_needed = 1;
8332 31 : gfc_conv_expr (&argse, actual->expr);
8333 31 : gfc_add_block_to_block (&se->pre, &argse.pre);
8334 : /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8335 : case; size_var can be used in both blocks. */
8336 31 : tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8337 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8338 31 : TREE_TYPE (size_var), size_var, size);
8339 31 : gfc_add_expr_to_block (&block, tmp);
8340 31 : size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8341 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8342 31 : TREE_TYPE (size_var), size_var, size);
8343 31 : gfc_add_expr_to_block (&block2, tmp);
8344 31 : cond = gfc_conv_expr_present (actual->expr->symtree->n.sym);
8345 31 : tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8346 : gfc_finish_block (&block2));
8347 31 : gfc_add_expr_to_block (&se->pre, tmp);
8348 31 : size = size_var;
8349 31 : }
8350 : else
8351 8939 : gfc_add_block_to_block (&se->pre, &block);
8352 : }
8353 : else
8354 6050 : size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8355 15020 : type = gfc_typenode_for_spec (&expr->ts);
8356 15020 : se->expr = convert (type, size);
8357 15020 : }
8358 :
8359 :
8360 : /* Helper function to compute the size of a character variable,
8361 : excluding the terminating null characters. The result has
8362 : gfc_array_index_type type. */
8363 :
8364 : tree
8365 1863 : size_of_string_in_bytes (int kind, tree string_length)
8366 : {
8367 1863 : tree bytesize;
8368 1863 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8369 :
8370 3726 : bytesize = build_int_cst (gfc_array_index_type,
8371 1863 : gfc_character_kinds[i].bit_size / 8);
8372 :
8373 1863 : return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8374 : bytesize,
8375 1863 : fold_convert (gfc_array_index_type, string_length));
8376 : }
8377 :
8378 :
8379 : static void
8380 1309 : gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8381 : {
8382 1309 : gfc_expr *arg;
8383 1309 : gfc_se argse;
8384 1309 : tree source_bytes;
8385 1309 : tree tmp;
8386 1309 : tree lower;
8387 1309 : tree upper;
8388 1309 : tree byte_size;
8389 1309 : tree field;
8390 1309 : int n;
8391 :
8392 1309 : gfc_init_se (&argse, NULL);
8393 1309 : arg = expr->value.function.actual->expr;
8394 :
8395 1309 : if (arg->rank || arg->ts.type == BT_ASSUMED)
8396 1012 : gfc_conv_expr_descriptor (&argse, arg);
8397 : else
8398 297 : gfc_conv_expr_reference (&argse, arg);
8399 :
8400 1309 : if (arg->ts.type == BT_ASSUMED)
8401 : {
8402 : /* This only works if an array descriptor has been passed; thus, extract
8403 : the size from the descriptor. */
8404 172 : gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8405 : == TYPE_PRECISION (size_type_node));
8406 172 : tmp = arg->symtree->n.sym->backend_decl;
8407 172 : tmp = DECL_LANG_SPECIFIC (tmp)
8408 60 : && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8409 226 : ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8410 172 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8411 172 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8412 :
8413 172 : tmp = gfc_conv_descriptor_dtype (tmp);
8414 172 : field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8415 : GFC_DTYPE_ELEM_LEN);
8416 172 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8417 : tmp, field, NULL_TREE);
8418 :
8419 172 : byte_size = fold_convert (gfc_array_index_type, tmp);
8420 : }
8421 1137 : else if (arg->ts.type == BT_CLASS)
8422 : {
8423 : /* Conv_expr_descriptor returns a component_ref to _data component of the
8424 : class object. The class object may be a non-pointer object, e.g.
8425 : located on the stack, or a memory location pointed to, e.g. a
8426 : parameter, i.e., an indirect_ref. */
8427 959 : if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8428 589 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8429 198 : byte_size
8430 198 : = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8431 391 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8432 0 : byte_size = gfc_class_vtab_size_get (argse.expr);
8433 391 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8434 391 : && TREE_CODE (argse.expr) == COMPONENT_REF)
8435 328 : byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8436 63 : else if (arg->rank > 0
8437 21 : || (arg->rank == 0
8438 21 : && arg->ref && arg->ref->type == REF_COMPONENT))
8439 : {
8440 : /* The scalarizer added an additional temp. To get the class' vptr
8441 : one has to look at the original backend_decl. */
8442 63 : if (argse.class_container)
8443 21 : byte_size = gfc_class_vtab_size_get (argse.class_container);
8444 42 : else if (DECL_LANG_SPECIFIC (arg->symtree->n.sym->backend_decl))
8445 84 : byte_size = gfc_class_vtab_size_get (
8446 42 : GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8447 : else
8448 0 : gcc_unreachable ();
8449 : }
8450 : else
8451 0 : gcc_unreachable ();
8452 : }
8453 : else
8454 : {
8455 548 : if (arg->ts.type == BT_CHARACTER)
8456 84 : byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8457 : else
8458 : {
8459 464 : if (arg->rank == 0)
8460 0 : byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8461 : argse.expr));
8462 : else
8463 464 : byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8464 464 : byte_size = fold_convert (gfc_array_index_type,
8465 : size_in_bytes (byte_size));
8466 : }
8467 : }
8468 :
8469 1309 : if (arg->rank == 0)
8470 297 : se->expr = byte_size;
8471 : else
8472 : {
8473 1012 : source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8474 1012 : gfc_add_modify (&argse.pre, source_bytes, byte_size);
8475 :
8476 1012 : if (arg->rank == -1)
8477 : {
8478 365 : tree cond, loop_var, exit_label;
8479 365 : stmtblock_t body;
8480 :
8481 365 : tmp = fold_convert (gfc_array_index_type,
8482 : gfc_conv_descriptor_rank (argse.expr));
8483 365 : loop_var = gfc_create_var (gfc_array_index_type, "i");
8484 365 : gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
8485 365 : exit_label = gfc_build_label_decl (NULL_TREE);
8486 :
8487 : /* Create loop:
8488 : for (;;)
8489 : {
8490 : if (i >= rank)
8491 : goto exit;
8492 : source_bytes = source_bytes * array.dim[i].extent;
8493 : i = i + 1;
8494 : }
8495 : exit: */
8496 365 : gfc_start_block (&body);
8497 365 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8498 : loop_var, tmp);
8499 365 : tmp = build1_v (GOTO_EXPR, exit_label);
8500 365 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8501 : cond, tmp, build_empty_stmt (input_location));
8502 365 : gfc_add_expr_to_block (&body, tmp);
8503 :
8504 365 : lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8505 365 : upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8506 365 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8507 365 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8508 : gfc_array_index_type, tmp, source_bytes);
8509 365 : gfc_add_modify (&body, source_bytes, tmp);
8510 :
8511 365 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8512 : gfc_array_index_type, loop_var,
8513 : gfc_index_one_node);
8514 365 : gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8515 :
8516 365 : tmp = gfc_finish_block (&body);
8517 :
8518 365 : tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8519 : tmp);
8520 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8521 :
8522 365 : tmp = build1_v (LABEL_EXPR, exit_label);
8523 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8524 : }
8525 : else
8526 : {
8527 : /* Obtain the size of the array in bytes. */
8528 1834 : for (n = 0; n < arg->rank; n++)
8529 : {
8530 1187 : tree idx;
8531 1187 : idx = gfc_rank_cst[n];
8532 1187 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8533 1187 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8534 1187 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8535 1187 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8536 : gfc_array_index_type, tmp, source_bytes);
8537 1187 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8538 : }
8539 : }
8540 1012 : se->expr = source_bytes;
8541 : }
8542 :
8543 1309 : gfc_add_block_to_block (&se->pre, &argse.pre);
8544 1309 : }
8545 :
8546 :
8547 : static void
8548 834 : gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8549 : {
8550 834 : gfc_expr *arg;
8551 834 : gfc_se argse;
8552 834 : tree type, result_type, tmp, class_decl = NULL;
8553 834 : gfc_symbol *sym;
8554 834 : bool unlimited = false;
8555 :
8556 834 : arg = expr->value.function.actual->expr;
8557 :
8558 834 : gfc_init_se (&argse, NULL);
8559 834 : result_type = gfc_get_int_type (expr->ts.kind);
8560 :
8561 834 : if (arg->rank == 0)
8562 : {
8563 224 : if (arg->ts.type == BT_CLASS)
8564 : {
8565 86 : unlimited = UNLIMITED_POLY (arg);
8566 86 : gfc_add_vptr_component (arg);
8567 86 : gfc_add_size_component (arg);
8568 86 : gfc_conv_expr (&argse, arg);
8569 86 : tmp = fold_convert (result_type, argse.expr);
8570 86 : class_decl = gfc_get_class_from_expr (argse.expr);
8571 86 : goto done;
8572 : }
8573 :
8574 138 : gfc_conv_expr_reference (&argse, arg);
8575 138 : type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8576 : argse.expr));
8577 : }
8578 : else
8579 : {
8580 610 : argse.want_pointer = 0;
8581 610 : gfc_conv_expr_descriptor (&argse, arg);
8582 610 : sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
8583 610 : if (arg->ts.type == BT_CLASS)
8584 : {
8585 60 : unlimited = UNLIMITED_POLY (arg);
8586 60 : if (TREE_CODE (argse.expr) == COMPONENT_REF)
8587 54 : tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8588 6 : else if (arg->rank > 0 && sym
8589 12 : && DECL_LANG_SPECIFIC (sym->backend_decl))
8590 12 : tmp = gfc_class_vtab_size_get (
8591 6 : GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
8592 : else
8593 0 : gcc_unreachable ();
8594 60 : tmp = fold_convert (result_type, tmp);
8595 60 : class_decl = gfc_get_class_from_expr (argse.expr);
8596 60 : goto done;
8597 : }
8598 550 : type = gfc_get_element_type (TREE_TYPE (argse.expr));
8599 : }
8600 :
8601 : /* Obtain the argument's word length. */
8602 688 : if (arg->ts.type == BT_CHARACTER)
8603 241 : tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8604 : else
8605 447 : tmp = size_in_bytes (type);
8606 688 : tmp = fold_convert (result_type, tmp);
8607 :
8608 834 : done:
8609 834 : if (unlimited && class_decl)
8610 68 : tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
8611 :
8612 834 : se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8613 : build_int_cst (result_type, BITS_PER_UNIT));
8614 834 : gfc_add_block_to_block (&se->pre, &argse.pre);
8615 834 : }
8616 :
8617 :
8618 : /* Intrinsic string comparison functions. */
8619 :
8620 : static void
8621 99 : gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8622 : {
8623 99 : tree args[4];
8624 :
8625 99 : gfc_conv_intrinsic_function_args (se, expr, args, 4);
8626 :
8627 99 : se->expr
8628 198 : = gfc_build_compare_string (args[0], args[1], args[2], args[3],
8629 99 : expr->value.function.actual->expr->ts.kind,
8630 : op);
8631 99 : se->expr = fold_build2_loc (input_location, op,
8632 : gfc_typenode_for_spec (&expr->ts), se->expr,
8633 99 : build_int_cst (TREE_TYPE (se->expr), 0));
8634 99 : }
8635 :
8636 : /* Generate a call to the adjustl/adjustr library function. */
8637 : static void
8638 474 : gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8639 : {
8640 474 : tree args[3];
8641 474 : tree len;
8642 474 : tree type;
8643 474 : tree var;
8644 474 : tree tmp;
8645 :
8646 474 : gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
8647 474 : len = args[1];
8648 :
8649 474 : type = TREE_TYPE (args[2]);
8650 474 : var = gfc_conv_string_tmp (se, type, len);
8651 474 : args[0] = var;
8652 :
8653 474 : tmp = build_call_expr_loc (input_location,
8654 : fndecl, 3, args[0], args[1], args[2]);
8655 474 : gfc_add_expr_to_block (&se->pre, tmp);
8656 474 : se->expr = var;
8657 474 : se->string_length = len;
8658 474 : }
8659 :
8660 :
8661 : /* Generate code for the TRANSFER intrinsic:
8662 : For scalar results:
8663 : DEST = TRANSFER (SOURCE, MOLD)
8664 : where:
8665 : typeof<DEST> = typeof<MOLD>
8666 : and:
8667 : MOLD is scalar.
8668 :
8669 : For array results:
8670 : DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8671 : where:
8672 : typeof<DEST> = typeof<MOLD>
8673 : and:
8674 : N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8675 : sizeof (DEST(0) * SIZE). */
8676 : static void
8677 3673 : gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8678 : {
8679 3673 : tree tmp;
8680 3673 : tree tmpdecl;
8681 3673 : tree ptr;
8682 3673 : tree extent;
8683 3673 : tree source;
8684 3673 : tree source_type;
8685 3673 : tree source_bytes;
8686 3673 : tree mold_type;
8687 3673 : tree dest_word_len;
8688 3673 : tree size_words;
8689 3673 : tree size_bytes;
8690 3673 : tree upper;
8691 3673 : tree lower;
8692 3673 : tree stmt;
8693 3673 : tree class_ref = NULL_TREE;
8694 3673 : gfc_actual_arglist *arg;
8695 3673 : gfc_se argse;
8696 3673 : gfc_array_info *info;
8697 3673 : stmtblock_t block;
8698 3673 : int n;
8699 3673 : bool scalar_mold;
8700 3673 : gfc_expr *source_expr, *mold_expr, *class_expr;
8701 :
8702 3673 : info = NULL;
8703 3673 : if (se->loop)
8704 472 : info = &se->ss->info->data.array;
8705 :
8706 : /* Convert SOURCE. The output from this stage is:-
8707 : source_bytes = length of the source in bytes
8708 : source = pointer to the source data. */
8709 3673 : arg = expr->value.function.actual;
8710 3673 : source_expr = arg->expr;
8711 :
8712 : /* Ensure double transfer through LOGICAL preserves all
8713 : the needed bits. */
8714 3673 : if (arg->expr->expr_type == EXPR_FUNCTION
8715 2681 : && arg->expr->value.function.esym == NULL
8716 2663 : && arg->expr->value.function.isym != NULL
8717 2663 : && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8718 12 : && arg->expr->ts.type == BT_LOGICAL
8719 12 : && expr->ts.type != arg->expr->ts.type)
8720 12 : arg->expr->value.function.name = "__transfer_in_transfer";
8721 :
8722 3673 : gfc_init_se (&argse, NULL);
8723 :
8724 3673 : source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8725 :
8726 : /* Obtain the pointer to source and the length of source in bytes. */
8727 3673 : if (arg->expr->rank == 0)
8728 : {
8729 3317 : gfc_conv_expr_reference (&argse, arg->expr);
8730 3317 : if (arg->expr->ts.type == BT_CLASS)
8731 : {
8732 37 : tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8733 37 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8734 : {
8735 19 : source = gfc_class_data_get (tmp);
8736 19 : class_ref = tmp;
8737 : }
8738 : else
8739 : {
8740 : /* Array elements are evaluated as a reference to the data.
8741 : To obtain the vptr for the element size, the argument
8742 : expression must be stripped to the class reference and
8743 : re-evaluated. The pre and post blocks are not needed. */
8744 18 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8745 18 : source = argse.expr;
8746 18 : class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8747 18 : gfc_init_se (&argse, NULL);
8748 18 : gfc_conv_expr (&argse, class_expr);
8749 18 : class_ref = argse.expr;
8750 : }
8751 : }
8752 : else
8753 3280 : source = argse.expr;
8754 :
8755 : /* Obtain the source word length. */
8756 3317 : switch (arg->expr->ts.type)
8757 : {
8758 294 : case BT_CHARACTER:
8759 294 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8760 : argse.string_length);
8761 294 : break;
8762 37 : case BT_CLASS:
8763 37 : if (class_ref != NULL_TREE)
8764 : {
8765 37 : tmp = gfc_class_vtab_size_get (class_ref);
8766 37 : if (UNLIMITED_POLY (source_expr))
8767 30 : tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
8768 : }
8769 : else
8770 : {
8771 0 : tmp = gfc_class_vtab_size_get (argse.expr);
8772 0 : if (UNLIMITED_POLY (source_expr))
8773 0 : tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
8774 : }
8775 : break;
8776 2986 : default:
8777 2986 : source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8778 : source));
8779 2986 : tmp = fold_convert (gfc_array_index_type,
8780 : size_in_bytes (source_type));
8781 2986 : break;
8782 : }
8783 : }
8784 : else
8785 : {
8786 356 : bool simply_contiguous = gfc_is_simply_contiguous (arg->expr,
8787 : false, true);
8788 356 : argse.want_pointer = 0;
8789 : /* A non-contiguous SOURCE needs packing. */
8790 356 : if (!simply_contiguous)
8791 74 : argse.force_tmp = 1;
8792 356 : gfc_conv_expr_descriptor (&argse, arg->expr);
8793 356 : source = gfc_conv_descriptor_data_get (argse.expr);
8794 356 : source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8795 :
8796 : /* Repack the source if not simply contiguous. */
8797 356 : if (!simply_contiguous)
8798 : {
8799 74 : tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8800 :
8801 74 : if (warn_array_temporaries)
8802 0 : gfc_warning (OPT_Warray_temporaries,
8803 : "Creating array temporary at %L", &expr->where);
8804 :
8805 74 : source = build_call_expr_loc (input_location,
8806 : gfor_fndecl_in_pack, 1, tmp);
8807 74 : source = gfc_evaluate_now (source, &argse.pre);
8808 :
8809 : /* Free the temporary. */
8810 74 : gfc_start_block (&block);
8811 74 : tmp = gfc_call_free (source);
8812 74 : gfc_add_expr_to_block (&block, tmp);
8813 74 : stmt = gfc_finish_block (&block);
8814 :
8815 : /* Clean up if it was repacked. */
8816 74 : gfc_init_block (&block);
8817 74 : tmp = gfc_conv_array_data (argse.expr);
8818 74 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8819 : source, tmp);
8820 74 : tmp = build3_v (COND_EXPR, tmp, stmt,
8821 : build_empty_stmt (input_location));
8822 74 : gfc_add_expr_to_block (&block, tmp);
8823 74 : gfc_add_block_to_block (&block, &se->post);
8824 74 : gfc_init_block (&se->post);
8825 74 : gfc_add_block_to_block (&se->post, &block);
8826 : }
8827 :
8828 : /* Obtain the source word length. */
8829 356 : if (arg->expr->ts.type == BT_CHARACTER)
8830 144 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8831 : argse.string_length);
8832 212 : else if (arg->expr->ts.type == BT_CLASS)
8833 : {
8834 54 : if (UNLIMITED_POLY (source_expr)
8835 54 : && DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl))
8836 12 : class_ref = GFC_DECL_SAVED_DESCRIPTOR
8837 : (source_expr->symtree->n.sym->backend_decl);
8838 : else
8839 42 : class_ref = TREE_OPERAND (argse.expr, 0);
8840 54 : tmp = gfc_class_vtab_size_get (class_ref);
8841 54 : if (UNLIMITED_POLY (arg->expr))
8842 54 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8843 : }
8844 : else
8845 158 : tmp = fold_convert (gfc_array_index_type,
8846 : size_in_bytes (source_type));
8847 :
8848 : /* Obtain the size of the array in bytes. */
8849 356 : extent = gfc_create_var (gfc_array_index_type, NULL);
8850 742 : for (n = 0; n < arg->expr->rank; n++)
8851 : {
8852 386 : tree idx;
8853 386 : idx = gfc_rank_cst[n];
8854 386 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8855 386 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8856 386 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8857 386 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8858 : gfc_array_index_type, upper, lower);
8859 386 : gfc_add_modify (&argse.pre, extent, tmp);
8860 386 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8861 : gfc_array_index_type, extent,
8862 : gfc_index_one_node);
8863 386 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8864 : gfc_array_index_type, tmp, source_bytes);
8865 : }
8866 : }
8867 :
8868 3673 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8869 3673 : gfc_add_block_to_block (&se->pre, &argse.pre);
8870 3673 : gfc_add_block_to_block (&se->post, &argse.post);
8871 :
8872 : /* Now convert MOLD. The outputs are:
8873 : mold_type = the TREE type of MOLD
8874 : dest_word_len = destination word length in bytes. */
8875 3673 : arg = arg->next;
8876 3673 : mold_expr = arg->expr;
8877 :
8878 3673 : gfc_init_se (&argse, NULL);
8879 :
8880 3673 : scalar_mold = arg->expr->rank == 0;
8881 :
8882 3673 : if (arg->expr->rank == 0)
8883 : {
8884 3350 : gfc_conv_expr_reference (&argse, mold_expr);
8885 3350 : mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8886 : argse.expr));
8887 : }
8888 : else
8889 : {
8890 323 : argse.want_pointer = 0;
8891 323 : gfc_conv_expr_descriptor (&argse, mold_expr);
8892 323 : mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8893 : }
8894 :
8895 3673 : gfc_add_block_to_block (&se->pre, &argse.pre);
8896 3673 : gfc_add_block_to_block (&se->post, &argse.post);
8897 :
8898 3673 : if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8899 : {
8900 : /* If this TRANSFER is nested in another TRANSFER, use a type
8901 : that preserves all bits. */
8902 12 : if (mold_expr->ts.type == BT_LOGICAL)
8903 12 : mold_type = gfc_get_int_type (mold_expr->ts.kind);
8904 : }
8905 :
8906 : /* Obtain the destination word length. */
8907 3673 : switch (mold_expr->ts.type)
8908 : {
8909 467 : case BT_CHARACTER:
8910 467 : tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length);
8911 467 : mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
8912 : argse.string_length);
8913 467 : break;
8914 6 : case BT_CLASS:
8915 6 : if (scalar_mold)
8916 6 : class_ref = argse.expr;
8917 : else
8918 0 : class_ref = TREE_OPERAND (argse.expr, 0);
8919 6 : tmp = gfc_class_vtab_size_get (class_ref);
8920 6 : if (UNLIMITED_POLY (arg->expr))
8921 0 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8922 : break;
8923 3200 : default:
8924 3200 : tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8925 3200 : break;
8926 : }
8927 :
8928 : /* Do not fix dest_word_len if it is a variable, since the temporary can wind
8929 : up being used before the assignment. */
8930 3673 : if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
8931 : dest_word_len = tmp;
8932 : else
8933 : {
8934 3619 : dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8935 3619 : gfc_add_modify (&se->pre, dest_word_len, tmp);
8936 : }
8937 :
8938 : /* Finally convert SIZE, if it is present. */
8939 3673 : arg = arg->next;
8940 3673 : size_words = gfc_create_var (gfc_array_index_type, NULL);
8941 :
8942 3673 : if (arg->expr)
8943 : {
8944 222 : gfc_init_se (&argse, NULL);
8945 222 : gfc_conv_expr_reference (&argse, arg->expr);
8946 222 : tmp = convert (gfc_array_index_type,
8947 : build_fold_indirect_ref_loc (input_location,
8948 : argse.expr));
8949 222 : gfc_add_block_to_block (&se->pre, &argse.pre);
8950 222 : gfc_add_block_to_block (&se->post, &argse.post);
8951 : }
8952 : else
8953 : tmp = NULL_TREE;
8954 :
8955 : /* Separate array and scalar results. */
8956 3673 : if (scalar_mold && tmp == NULL_TREE)
8957 3201 : goto scalar_transfer;
8958 :
8959 472 : size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8960 472 : if (tmp != NULL_TREE)
8961 222 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8962 : tmp, dest_word_len);
8963 : else
8964 : tmp = source_bytes;
8965 :
8966 472 : gfc_add_modify (&se->pre, size_bytes, tmp);
8967 472 : gfc_add_modify (&se->pre, size_words,
8968 : fold_build2_loc (input_location, CEIL_DIV_EXPR,
8969 : gfc_array_index_type,
8970 : size_bytes, dest_word_len));
8971 :
8972 : /* Evaluate the bounds of the result. If the loop range exists, we have
8973 : to check if it is too large. If so, we modify loop->to be consistent
8974 : with min(size, size(source)). Otherwise, size is made consistent with
8975 : the loop range, so that the right number of bytes is transferred.*/
8976 472 : n = se->loop->order[0];
8977 472 : if (se->loop->to[n] != NULL_TREE)
8978 : {
8979 205 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8980 : se->loop->to[n], se->loop->from[n]);
8981 205 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8982 : tmp, gfc_index_one_node);
8983 205 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8984 : tmp, size_words);
8985 205 : gfc_add_modify (&se->pre, size_words, tmp);
8986 205 : gfc_add_modify (&se->pre, size_bytes,
8987 : fold_build2_loc (input_location, MULT_EXPR,
8988 : gfc_array_index_type,
8989 : size_words, dest_word_len));
8990 410 : upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8991 205 : size_words, se->loop->from[n]);
8992 205 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8993 : upper, gfc_index_one_node);
8994 : }
8995 : else
8996 : {
8997 267 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8998 : size_words, gfc_index_one_node);
8999 267 : se->loop->from[n] = gfc_index_zero_node;
9000 : }
9001 :
9002 472 : se->loop->to[n] = upper;
9003 :
9004 : /* Build a destination descriptor, using the pointer, source, as the
9005 : data field. */
9006 472 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
9007 : NULL_TREE, false, true, false, &expr->where);
9008 :
9009 : /* Cast the pointer to the result. */
9010 472 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9011 472 : tmp = fold_convert (pvoid_type_node, tmp);
9012 :
9013 : /* Use memcpy to do the transfer. */
9014 472 : tmp
9015 472 : = build_call_expr_loc (input_location,
9016 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
9017 : fold_convert (pvoid_type_node, source),
9018 : fold_convert (size_type_node,
9019 : fold_build2_loc (input_location,
9020 : MIN_EXPR,
9021 : gfc_array_index_type,
9022 : size_bytes,
9023 : source_bytes)));
9024 472 : gfc_add_expr_to_block (&se->pre, tmp);
9025 :
9026 472 : se->expr = info->descriptor;
9027 472 : if (expr->ts.type == BT_CHARACTER)
9028 : {
9029 275 : tmp = fold_convert (gfc_charlen_type_node,
9030 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9031 275 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9032 : gfc_charlen_type_node,
9033 : dest_word_len, tmp);
9034 : }
9035 :
9036 472 : return;
9037 :
9038 : /* Deal with scalar results. */
9039 3201 : scalar_transfer:
9040 3201 : extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9041 : dest_word_len, source_bytes);
9042 3201 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9043 : extent, gfc_index_zero_node);
9044 :
9045 3201 : if (expr->ts.type == BT_CHARACTER)
9046 : {
9047 192 : tree direct, indirect, free;
9048 :
9049 192 : ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
9050 192 : tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
9051 : "transfer");
9052 :
9053 : /* If source is longer than the destination, use a pointer to
9054 : the source directly. */
9055 192 : gfc_init_block (&block);
9056 192 : gfc_add_modify (&block, tmpdecl, ptr);
9057 192 : direct = gfc_finish_block (&block);
9058 :
9059 : /* Otherwise, allocate a string with the length of the destination
9060 : and copy the source into it. */
9061 192 : gfc_init_block (&block);
9062 192 : tmp = gfc_get_pchar_type (expr->ts.kind);
9063 192 : tmp = gfc_call_malloc (&block, tmp, dest_word_len);
9064 192 : gfc_add_modify (&block, tmpdecl,
9065 192 : fold_convert (TREE_TYPE (ptr), tmp));
9066 192 : tmp = build_call_expr_loc (input_location,
9067 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9068 : fold_convert (pvoid_type_node, tmpdecl),
9069 : fold_convert (pvoid_type_node, ptr),
9070 : fold_convert (size_type_node, extent));
9071 192 : gfc_add_expr_to_block (&block, tmp);
9072 192 : indirect = gfc_finish_block (&block);
9073 :
9074 : /* Wrap it up with the condition. */
9075 192 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
9076 : dest_word_len, source_bytes);
9077 192 : tmp = build3_v (COND_EXPR, tmp, direct, indirect);
9078 192 : gfc_add_expr_to_block (&se->pre, tmp);
9079 :
9080 : /* Free the temporary string, if necessary. */
9081 192 : free = gfc_call_free (tmpdecl);
9082 192 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9083 : dest_word_len, source_bytes);
9084 192 : tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
9085 192 : gfc_add_expr_to_block (&se->post, tmp);
9086 :
9087 192 : se->expr = tmpdecl;
9088 192 : tmp = fold_convert (gfc_charlen_type_node,
9089 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9090 192 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9091 : gfc_charlen_type_node,
9092 : dest_word_len, tmp);
9093 : }
9094 : else
9095 : {
9096 3009 : tmpdecl = gfc_create_var (mold_type, "transfer");
9097 :
9098 3009 : ptr = convert (build_pointer_type (mold_type), source);
9099 :
9100 : /* For CLASS results, allocate the needed memory first. */
9101 3009 : if (mold_expr->ts.type == BT_CLASS)
9102 : {
9103 6 : tree cdata;
9104 6 : cdata = gfc_class_data_get (tmpdecl);
9105 6 : tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
9106 6 : gfc_add_modify (&se->pre, cdata, tmp);
9107 : }
9108 :
9109 : /* Use memcpy to do the transfer. */
9110 3009 : if (mold_expr->ts.type == BT_CLASS)
9111 6 : tmp = gfc_class_data_get (tmpdecl);
9112 : else
9113 3003 : tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
9114 :
9115 3009 : tmp = build_call_expr_loc (input_location,
9116 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9117 : fold_convert (pvoid_type_node, tmp),
9118 : fold_convert (pvoid_type_node, ptr),
9119 : fold_convert (size_type_node, extent));
9120 3009 : gfc_add_expr_to_block (&se->pre, tmp);
9121 :
9122 : /* For CLASS results, set the _vptr. */
9123 3009 : if (mold_expr->ts.type == BT_CLASS)
9124 6 : gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
9125 :
9126 3009 : se->expr = tmpdecl;
9127 : }
9128 : }
9129 :
9130 :
9131 : /* Generate code for the ALLOCATED intrinsic.
9132 : Generate inline code that directly check the address of the argument. */
9133 :
9134 : static void
9135 7288 : gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
9136 : {
9137 7288 : gfc_se arg1se;
9138 7288 : tree tmp;
9139 7288 : gfc_expr *e = expr->value.function.actual->expr;
9140 :
9141 7288 : gfc_init_se (&arg1se, NULL);
9142 7288 : if (e->ts.type == BT_CLASS)
9143 : {
9144 : /* Make sure that class array expressions have both a _data
9145 : component reference and an array reference.... */
9146 899 : if (CLASS_DATA (e)->attr.dimension)
9147 418 : gfc_add_class_array_ref (e);
9148 : /* .... whilst scalars only need the _data component. */
9149 : else
9150 481 : gfc_add_data_component (e);
9151 : }
9152 :
9153 7288 : gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
9154 :
9155 7288 : if (e->rank == 0)
9156 : {
9157 : /* Allocatable scalar. */
9158 2863 : arg1se.want_pointer = 1;
9159 2863 : gfc_conv_expr (&arg1se, e);
9160 2863 : tmp = arg1se.expr;
9161 : }
9162 : else
9163 : {
9164 : /* Allocatable array. */
9165 4425 : arg1se.descriptor_only = 1;
9166 4425 : gfc_conv_expr_descriptor (&arg1se, e);
9167 4425 : tmp = gfc_conv_descriptor_data_get (arg1se.expr);
9168 : }
9169 :
9170 7288 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
9171 7288 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9172 :
9173 : /* Components of pointer array references sometimes come back with a pre block. */
9174 7288 : if (arg1se.pre.head)
9175 327 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9176 :
9177 7288 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9178 7288 : }
9179 :
9180 :
9181 : /* Generate code for the ASSOCIATED intrinsic.
9182 : If both POINTER and TARGET are arrays, generate a call to library function
9183 : _gfor_associated, and pass descriptors of POINTER and TARGET to it.
9184 : In other cases, generate inline code that directly compare the address of
9185 : POINTER with the address of TARGET. */
9186 :
9187 : static void
9188 9343 : gfc_conv_associated (gfc_se *se, gfc_expr *expr)
9189 : {
9190 9343 : gfc_actual_arglist *arg1;
9191 9343 : gfc_actual_arglist *arg2;
9192 9343 : gfc_se arg1se;
9193 9343 : gfc_se arg2se;
9194 9343 : tree tmp2;
9195 9343 : tree tmp;
9196 9343 : tree nonzero_arraylen = NULL_TREE;
9197 9343 : gfc_ss *ss;
9198 9343 : bool scalar;
9199 :
9200 9343 : gfc_init_se (&arg1se, NULL);
9201 9343 : gfc_init_se (&arg2se, NULL);
9202 9343 : arg1 = expr->value.function.actual;
9203 9343 : arg2 = arg1->next;
9204 :
9205 : /* Check whether the expression is a scalar or not; we cannot use
9206 : arg1->expr->rank as it can be nonzero for proc pointers. */
9207 9343 : ss = gfc_walk_expr (arg1->expr);
9208 9343 : scalar = ss == gfc_ss_terminator;
9209 9343 : if (!scalar)
9210 3889 : gfc_free_ss_chain (ss);
9211 :
9212 9343 : if (!arg2->expr)
9213 : {
9214 : /* No optional target. */
9215 7008 : if (scalar)
9216 : {
9217 : /* A pointer to a scalar. */
9218 4571 : arg1se.want_pointer = 1;
9219 4571 : gfc_conv_expr (&arg1se, arg1->expr);
9220 4571 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9221 185 : && arg1->expr->symtree->n.sym->attr.dummy)
9222 78 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9223 : arg1se.expr);
9224 4571 : if (arg1->expr->ts.type == BT_CLASS)
9225 : {
9226 384 : tmp2 = gfc_class_data_get (arg1se.expr);
9227 384 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9228 0 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
9229 : }
9230 : else
9231 4187 : tmp2 = arg1se.expr;
9232 : }
9233 : else
9234 : {
9235 : /* A pointer to an array. */
9236 2437 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9237 2437 : tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
9238 : }
9239 7008 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9240 7008 : gfc_add_block_to_block (&se->post, &arg1se.post);
9241 7008 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9242 7008 : fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9243 7008 : se->expr = tmp;
9244 : }
9245 : else
9246 : {
9247 : /* An optional target. */
9248 2335 : if (arg2->expr->ts.type == BT_CLASS
9249 24 : && arg2->expr->expr_type != EXPR_FUNCTION)
9250 18 : gfc_add_data_component (arg2->expr);
9251 :
9252 2335 : if (scalar)
9253 : {
9254 : /* A pointer to a scalar. */
9255 883 : arg1se.want_pointer = 1;
9256 883 : gfc_conv_expr (&arg1se, arg1->expr);
9257 883 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9258 92 : && arg1->expr->symtree->n.sym->attr.dummy)
9259 42 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9260 : arg1se.expr);
9261 883 : if (arg1->expr->ts.type == BT_CLASS)
9262 246 : arg1se.expr = gfc_class_data_get (arg1se.expr);
9263 :
9264 883 : arg2se.want_pointer = 1;
9265 883 : gfc_conv_expr (&arg2se, arg2->expr);
9266 883 : if (arg2->expr->symtree->n.sym->attr.proc_pointer
9267 0 : && arg2->expr->symtree->n.sym->attr.dummy)
9268 0 : arg2se.expr = build_fold_indirect_ref_loc (input_location,
9269 : arg2se.expr);
9270 883 : if (arg2->expr->ts.type == BT_CLASS)
9271 : {
9272 6 : arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
9273 6 : arg2se.expr = gfc_class_data_get (arg2se.expr);
9274 : }
9275 883 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9276 883 : gfc_add_block_to_block (&se->post, &arg1se.post);
9277 883 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9278 883 : gfc_add_block_to_block (&se->post, &arg2se.post);
9279 883 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9280 : arg1se.expr, arg2se.expr);
9281 883 : tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9282 : arg1se.expr, null_pointer_node);
9283 883 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9284 : logical_type_node, tmp, tmp2);
9285 : }
9286 : else
9287 : {
9288 : /* An array pointer of zero length is not associated if target is
9289 : present. */
9290 1452 : arg1se.descriptor_only = 1;
9291 1452 : gfc_conv_expr_lhs (&arg1se, arg1->expr);
9292 1452 : if (arg1->expr->rank == -1)
9293 : {
9294 84 : tmp = gfc_conv_descriptor_rank (arg1se.expr);
9295 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9296 84 : TREE_TYPE (tmp), tmp,
9297 84 : build_int_cst (TREE_TYPE (tmp), 1));
9298 : }
9299 : else
9300 1368 : tmp = gfc_rank_cst[arg1->expr->rank - 1];
9301 1452 : tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9302 1452 : if (arg2->expr->rank != 0)
9303 1422 : nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9304 : logical_type_node, tmp,
9305 1422 : build_int_cst (TREE_TYPE (tmp), 0));
9306 :
9307 : /* A pointer to an array, call library function _gfor_associated. */
9308 1452 : arg1se.want_pointer = 1;
9309 1452 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9310 1452 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9311 1452 : gfc_add_block_to_block (&se->post, &arg1se.post);
9312 :
9313 1452 : arg2se.want_pointer = 1;
9314 1452 : arg2se.force_no_tmp = 1;
9315 1452 : if (arg2->expr->rank != 0)
9316 1422 : gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9317 : else
9318 : {
9319 30 : gfc_conv_expr (&arg2se, arg2->expr);
9320 30 : arg2se.expr
9321 30 : = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9322 30 : gfc_expr_attr (arg2->expr));
9323 30 : arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9324 : }
9325 1452 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9326 1452 : gfc_add_block_to_block (&se->post, &arg2se.post);
9327 1452 : se->expr = build_call_expr_loc (input_location,
9328 : gfor_fndecl_associated, 2,
9329 : arg1se.expr, arg2se.expr);
9330 1452 : se->expr = convert (logical_type_node, se->expr);
9331 1452 : if (arg2->expr->rank != 0)
9332 1422 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9333 : logical_type_node, se->expr,
9334 : nonzero_arraylen);
9335 : }
9336 :
9337 : /* If target is present zero character length pointers cannot
9338 : be associated. */
9339 2335 : if (arg1->expr->ts.type == BT_CHARACTER)
9340 : {
9341 631 : tmp = arg1se.string_length;
9342 631 : tmp = fold_build2_loc (input_location, NE_EXPR,
9343 : logical_type_node, tmp,
9344 631 : build_zero_cst (TREE_TYPE (tmp)));
9345 631 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9346 : logical_type_node, se->expr, tmp);
9347 : }
9348 : }
9349 :
9350 9343 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9351 9343 : }
9352 :
9353 :
9354 : /* Generate code for the SAME_TYPE_AS intrinsic.
9355 : Generate inline code that directly checks the vindices. */
9356 :
9357 : static void
9358 409 : gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9359 : {
9360 409 : gfc_expr *a, *b;
9361 409 : gfc_se se1, se2;
9362 409 : tree tmp;
9363 409 : tree conda = NULL_TREE, condb = NULL_TREE;
9364 :
9365 409 : gfc_init_se (&se1, NULL);
9366 409 : gfc_init_se (&se2, NULL);
9367 :
9368 409 : a = expr->value.function.actual->expr;
9369 409 : b = expr->value.function.actual->next->expr;
9370 :
9371 409 : bool unlimited_poly_a = UNLIMITED_POLY (a);
9372 409 : bool unlimited_poly_b = UNLIMITED_POLY (b);
9373 409 : if (unlimited_poly_a)
9374 : {
9375 111 : se1.want_pointer = 1;
9376 111 : gfc_add_vptr_component (a);
9377 : }
9378 298 : else if (a->ts.type == BT_CLASS)
9379 : {
9380 256 : gfc_add_vptr_component (a);
9381 256 : gfc_add_hash_component (a);
9382 : }
9383 42 : else if (a->ts.type == BT_DERIVED)
9384 42 : a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9385 42 : a->ts.u.derived->hash_value);
9386 :
9387 409 : if (unlimited_poly_b)
9388 : {
9389 72 : se2.want_pointer = 1;
9390 72 : gfc_add_vptr_component (b);
9391 : }
9392 337 : else if (b->ts.type == BT_CLASS)
9393 : {
9394 169 : gfc_add_vptr_component (b);
9395 169 : gfc_add_hash_component (b);
9396 : }
9397 168 : else if (b->ts.type == BT_DERIVED)
9398 168 : b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9399 168 : b->ts.u.derived->hash_value);
9400 :
9401 409 : gfc_conv_expr (&se1, a);
9402 409 : gfc_conv_expr (&se2, b);
9403 :
9404 409 : if (unlimited_poly_a)
9405 : {
9406 111 : conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9407 : se1.expr,
9408 111 : build_int_cst (TREE_TYPE (se1.expr), 0));
9409 111 : se1.expr = gfc_vptr_hash_get (se1.expr);
9410 : }
9411 :
9412 409 : if (unlimited_poly_b)
9413 : {
9414 72 : condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9415 : se2.expr,
9416 72 : build_int_cst (TREE_TYPE (se2.expr), 0));
9417 72 : se2.expr = gfc_vptr_hash_get (se2.expr);
9418 : }
9419 :
9420 409 : tmp = fold_build2_loc (input_location, EQ_EXPR,
9421 : logical_type_node, se1.expr,
9422 409 : fold_convert (TREE_TYPE (se1.expr), se2.expr));
9423 :
9424 409 : if (conda)
9425 111 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9426 : logical_type_node, conda, tmp);
9427 :
9428 409 : if (condb)
9429 72 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9430 : logical_type_node, condb, tmp);
9431 :
9432 409 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9433 409 : }
9434 :
9435 :
9436 : /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9437 :
9438 : static void
9439 42 : gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9440 : {
9441 42 : tree args[2];
9442 :
9443 42 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
9444 42 : se->expr = build_call_expr_loc (input_location,
9445 : gfor_fndecl_sc_kind, 2, args[0], args[1]);
9446 42 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9447 42 : }
9448 :
9449 :
9450 : /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9451 :
9452 : static void
9453 45 : gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9454 : {
9455 45 : tree arg, type;
9456 :
9457 45 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9458 :
9459 : /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9460 45 : type = gfc_get_int_type (4);
9461 45 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9462 :
9463 : /* Convert it to the required type. */
9464 45 : type = gfc_typenode_for_spec (&expr->ts);
9465 45 : se->expr = build_call_expr_loc (input_location,
9466 : gfor_fndecl_si_kind, 1, arg);
9467 45 : se->expr = fold_convert (type, se->expr);
9468 45 : }
9469 :
9470 :
9471 : /* Generate code for SELECTED_LOGICAL_KIND (BITS) intrinsic function. */
9472 :
9473 : static void
9474 6 : gfc_conv_intrinsic_sl_kind (gfc_se *se, gfc_expr *expr)
9475 : {
9476 6 : tree arg, type;
9477 :
9478 6 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9479 :
9480 : /* The argument to SELECTED_LOGICAL_KIND is INTEGER(4). */
9481 6 : type = gfc_get_int_type (4);
9482 6 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9483 :
9484 : /* Convert it to the required type. */
9485 6 : type = gfc_typenode_for_spec (&expr->ts);
9486 6 : se->expr = build_call_expr_loc (input_location,
9487 : gfor_fndecl_sl_kind, 1, arg);
9488 6 : se->expr = fold_convert (type, se->expr);
9489 6 : }
9490 :
9491 :
9492 : /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9493 :
9494 : static void
9495 82 : gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9496 : {
9497 82 : gfc_actual_arglist *actual;
9498 82 : tree type;
9499 82 : gfc_se argse;
9500 82 : vec<tree, va_gc> *args = NULL;
9501 :
9502 328 : for (actual = expr->value.function.actual; actual; actual = actual->next)
9503 : {
9504 246 : gfc_init_se (&argse, se);
9505 :
9506 : /* Pass a NULL pointer for an absent arg. */
9507 246 : if (actual->expr == NULL)
9508 96 : argse.expr = null_pointer_node;
9509 : else
9510 : {
9511 150 : gfc_typespec ts;
9512 150 : gfc_clear_ts (&ts);
9513 :
9514 150 : if (actual->expr->ts.kind != gfc_c_int_kind)
9515 : {
9516 : /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9517 0 : ts.type = BT_INTEGER;
9518 0 : ts.kind = gfc_c_int_kind;
9519 0 : gfc_convert_type (actual->expr, &ts, 2);
9520 : }
9521 150 : gfc_conv_expr_reference (&argse, actual->expr);
9522 : }
9523 :
9524 246 : gfc_add_block_to_block (&se->pre, &argse.pre);
9525 246 : gfc_add_block_to_block (&se->post, &argse.post);
9526 246 : vec_safe_push (args, argse.expr);
9527 : }
9528 :
9529 : /* Convert it to the required type. */
9530 82 : type = gfc_typenode_for_spec (&expr->ts);
9531 82 : se->expr = build_call_expr_loc_vec (input_location,
9532 : gfor_fndecl_sr_kind, args);
9533 82 : se->expr = fold_convert (type, se->expr);
9534 82 : }
9535 :
9536 :
9537 : /* Generate code for TRIM (A) intrinsic function. */
9538 :
9539 : static void
9540 574 : gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9541 : {
9542 574 : tree var;
9543 574 : tree len;
9544 574 : tree addr;
9545 574 : tree tmp;
9546 574 : tree cond;
9547 574 : tree fndecl;
9548 574 : tree function;
9549 574 : tree *args;
9550 574 : unsigned int num_args;
9551 :
9552 574 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9553 574 : args = XALLOCAVEC (tree, num_args);
9554 :
9555 574 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9556 574 : addr = gfc_build_addr_expr (ppvoid_type_node, var);
9557 574 : len = gfc_create_var (gfc_charlen_type_node, "len");
9558 :
9559 574 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
9560 574 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
9561 574 : args[1] = addr;
9562 :
9563 574 : if (expr->ts.kind == 1)
9564 542 : function = gfor_fndecl_string_trim;
9565 32 : else if (expr->ts.kind == 4)
9566 32 : function = gfor_fndecl_string_trim_char4;
9567 : else
9568 0 : gcc_unreachable ();
9569 :
9570 574 : fndecl = build_addr (function);
9571 574 : tmp = build_call_array_loc (input_location,
9572 574 : TREE_TYPE (TREE_TYPE (function)), fndecl,
9573 : num_args, args);
9574 574 : gfc_add_expr_to_block (&se->pre, tmp);
9575 :
9576 : /* Free the temporary afterwards, if necessary. */
9577 574 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9578 574 : len, build_int_cst (TREE_TYPE (len), 0));
9579 574 : tmp = gfc_call_free (var);
9580 574 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9581 574 : gfc_add_expr_to_block (&se->post, tmp);
9582 :
9583 574 : se->expr = var;
9584 574 : se->string_length = len;
9585 574 : }
9586 :
9587 :
9588 : /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9589 :
9590 : static void
9591 529 : gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9592 : {
9593 529 : tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9594 529 : tree type, cond, tmp, count, exit_label, n, max, largest;
9595 529 : tree size;
9596 529 : stmtblock_t block, body;
9597 529 : int i;
9598 :
9599 : /* We store in charsize the size of a character. */
9600 529 : i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9601 529 : size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9602 :
9603 : /* Get the arguments. */
9604 529 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
9605 529 : slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9606 529 : src = args[1];
9607 529 : ncopies = gfc_evaluate_now (args[2], &se->pre);
9608 529 : ncopies_type = TREE_TYPE (ncopies);
9609 :
9610 : /* Check that NCOPIES is not negative. */
9611 529 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9612 : build_int_cst (ncopies_type, 0));
9613 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9614 : "Argument NCOPIES of REPEAT intrinsic is negative "
9615 : "(its value is %ld)",
9616 : fold_convert (long_integer_type_node, ncopies));
9617 :
9618 : /* If the source length is zero, any non negative value of NCOPIES
9619 : is valid, and nothing happens. */
9620 529 : n = gfc_create_var (ncopies_type, "ncopies");
9621 529 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9622 : size_zero_node);
9623 529 : tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9624 : build_int_cst (ncopies_type, 0), ncopies);
9625 529 : gfc_add_modify (&se->pre, n, tmp);
9626 529 : ncopies = n;
9627 :
9628 : /* Check that ncopies is not too large: ncopies should be less than
9629 : (or equal to) MAX / slen, where MAX is the maximal integer of
9630 : the gfc_charlen_type_node type. If slen == 0, we need a special
9631 : case to avoid the division by zero. */
9632 529 : max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9633 529 : fold_convert (sizetype,
9634 : TYPE_MAX_VALUE (gfc_charlen_type_node)),
9635 : slen);
9636 1054 : largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9637 529 : ? sizetype : ncopies_type;
9638 529 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9639 : fold_convert (largest, ncopies),
9640 : fold_convert (largest, max));
9641 529 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9642 : size_zero_node);
9643 529 : cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9644 : logical_false_node, cond);
9645 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9646 : "Argument NCOPIES of REPEAT intrinsic is too large");
9647 :
9648 : /* Compute the destination length. */
9649 529 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9650 : fold_convert (gfc_charlen_type_node, slen),
9651 : fold_convert (gfc_charlen_type_node, ncopies));
9652 529 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9653 529 : dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9654 :
9655 : /* Generate the code to do the repeat operation:
9656 : for (i = 0; i < ncopies; i++)
9657 : memmove (dest + (i * slen * size), src, slen*size); */
9658 529 : gfc_start_block (&block);
9659 529 : count = gfc_create_var (sizetype, "count");
9660 529 : gfc_add_modify (&block, count, size_zero_node);
9661 529 : exit_label = gfc_build_label_decl (NULL_TREE);
9662 :
9663 : /* Start the loop body. */
9664 529 : gfc_start_block (&body);
9665 :
9666 : /* Exit the loop if count >= ncopies. */
9667 529 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9668 : fold_convert (sizetype, ncopies));
9669 529 : tmp = build1_v (GOTO_EXPR, exit_label);
9670 529 : TREE_USED (exit_label) = 1;
9671 529 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9672 : build_empty_stmt (input_location));
9673 529 : gfc_add_expr_to_block (&body, tmp);
9674 :
9675 : /* Call memmove (dest + (i*slen*size), src, slen*size). */
9676 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9677 : count);
9678 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9679 : size);
9680 529 : tmp = fold_build_pointer_plus_loc (input_location,
9681 : fold_convert (pvoid_type_node, dest), tmp);
9682 529 : tmp = build_call_expr_loc (input_location,
9683 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9684 : 3, tmp, src,
9685 : fold_build2_loc (input_location, MULT_EXPR,
9686 : size_type_node, slen, size));
9687 529 : gfc_add_expr_to_block (&body, tmp);
9688 :
9689 : /* Increment count. */
9690 529 : tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9691 : count, size_one_node);
9692 529 : gfc_add_modify (&body, count, tmp);
9693 :
9694 : /* Build the loop. */
9695 529 : tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9696 529 : gfc_add_expr_to_block (&block, tmp);
9697 :
9698 : /* Add the exit label. */
9699 529 : tmp = build1_v (LABEL_EXPR, exit_label);
9700 529 : gfc_add_expr_to_block (&block, tmp);
9701 :
9702 : /* Finish the block. */
9703 529 : tmp = gfc_finish_block (&block);
9704 529 : gfc_add_expr_to_block (&se->pre, tmp);
9705 :
9706 : /* Set the result value. */
9707 529 : se->expr = dest;
9708 529 : se->string_length = dlen;
9709 529 : }
9710 :
9711 :
9712 : /* Generate code for the IARGC intrinsic. */
9713 :
9714 : static void
9715 12 : gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9716 : {
9717 12 : tree tmp;
9718 12 : tree fndecl;
9719 12 : tree type;
9720 :
9721 : /* Call the library function. This always returns an INTEGER(4). */
9722 12 : fndecl = gfor_fndecl_iargc;
9723 12 : tmp = build_call_expr_loc (input_location,
9724 : fndecl, 0);
9725 :
9726 : /* Convert it to the required type. */
9727 12 : type = gfc_typenode_for_spec (&expr->ts);
9728 12 : tmp = fold_convert (type, tmp);
9729 :
9730 12 : se->expr = tmp;
9731 12 : }
9732 :
9733 :
9734 : /* Generate code for the KILL intrinsic. */
9735 :
9736 : static void
9737 8 : conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9738 : {
9739 8 : tree *args;
9740 8 : tree int4_type_node = gfc_get_int_type (4);
9741 8 : tree pid;
9742 8 : tree sig;
9743 8 : tree tmp;
9744 8 : unsigned int num_args;
9745 :
9746 8 : num_args = gfc_intrinsic_argument_list_length (expr);
9747 8 : args = XALLOCAVEC (tree, num_args);
9748 8 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
9749 :
9750 : /* Convert PID to a INTEGER(4) entity. */
9751 8 : pid = convert (int4_type_node, args[0]);
9752 :
9753 : /* Convert SIG to a INTEGER(4) entity. */
9754 8 : sig = convert (int4_type_node, args[1]);
9755 :
9756 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9757 :
9758 8 : se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9759 8 : }
9760 :
9761 :
9762 : static tree
9763 15 : conv_intrinsic_kill_sub (gfc_code *code)
9764 : {
9765 15 : stmtblock_t block;
9766 15 : gfc_se se, se_stat;
9767 15 : tree int4_type_node = gfc_get_int_type (4);
9768 15 : tree pid;
9769 15 : tree sig;
9770 15 : tree statp;
9771 15 : tree tmp;
9772 :
9773 : /* Make the function call. */
9774 15 : gfc_init_block (&block);
9775 15 : gfc_init_se (&se, NULL);
9776 :
9777 : /* Convert PID to a INTEGER(4) entity. */
9778 15 : gfc_conv_expr (&se, code->ext.actual->expr);
9779 15 : gfc_add_block_to_block (&block, &se.pre);
9780 15 : pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9781 15 : gfc_add_block_to_block (&block, &se.post);
9782 :
9783 : /* Convert SIG to a INTEGER(4) entity. */
9784 15 : gfc_conv_expr (&se, code->ext.actual->next->expr);
9785 15 : gfc_add_block_to_block (&block, &se.pre);
9786 15 : sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9787 15 : gfc_add_block_to_block (&block, &se.post);
9788 :
9789 : /* Deal with an optional STATUS. */
9790 15 : if (code->ext.actual->next->next->expr)
9791 : {
9792 10 : gfc_init_se (&se_stat, NULL);
9793 10 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
9794 10 : statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9795 : }
9796 : else
9797 : statp = NULL_TREE;
9798 :
9799 25 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9800 10 : statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9801 :
9802 15 : gfc_add_expr_to_block (&block, tmp);
9803 :
9804 15 : if (statp && statp != se_stat.expr)
9805 10 : gfc_add_modify (&block, se_stat.expr,
9806 10 : fold_convert (TREE_TYPE (se_stat.expr), statp));
9807 :
9808 15 : return gfc_finish_block (&block);
9809 : }
9810 :
9811 :
9812 :
9813 : /* The loc intrinsic returns the address of its argument as
9814 : gfc_index_integer_kind integer. */
9815 :
9816 : static void
9817 8786 : gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9818 : {
9819 8786 : tree temp_var;
9820 8786 : gfc_expr *arg_expr;
9821 :
9822 8786 : gcc_assert (!se->ss);
9823 :
9824 8786 : arg_expr = expr->value.function.actual->expr;
9825 8786 : if (arg_expr->rank == 0)
9826 : {
9827 6371 : if (arg_expr->ts.type == BT_CLASS)
9828 18 : gfc_add_data_component (arg_expr);
9829 6371 : gfc_conv_expr_reference (se, arg_expr);
9830 : }
9831 : else
9832 2415 : gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9833 8786 : se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9834 :
9835 : /* Create a temporary variable for loc return value. Without this,
9836 : we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9837 8786 : temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9838 8786 : gfc_add_modify (&se->pre, temp_var, se->expr);
9839 8786 : se->expr = temp_var;
9840 8786 : }
9841 :
9842 :
9843 : /* Specialized trim for f_c_string. */
9844 :
9845 : static void
9846 42 : conv_trim (gfc_se *tse, gfc_se *str)
9847 : {
9848 42 : tree cond, plen, pvar, tlen, ttmp, tvar;
9849 :
9850 42 : tlen = gfc_create_var (gfc_charlen_type_node, "tlen");
9851 42 : plen = gfc_build_addr_expr (NULL_TREE, tlen);
9852 :
9853 42 : tvar = gfc_create_var (pchar_type_node, "tstr");
9854 42 : pvar = gfc_build_addr_expr (ppvoid_type_node, tvar);
9855 :
9856 42 : ttmp = build_call_expr_loc (input_location, gfor_fndecl_string_trim, 4,
9857 : plen, pvar, str->string_length, str->expr);
9858 :
9859 42 : gfc_add_expr_to_block (&tse->pre, ttmp);
9860 :
9861 : /* Free the temporary afterwards, if necessary. */
9862 42 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9863 42 : tlen, build_int_cst (TREE_TYPE (tlen), 0));
9864 42 : ttmp = gfc_call_free (tvar);
9865 42 : ttmp = build3_v (COND_EXPR, cond, ttmp, build_empty_stmt (input_location));
9866 42 : gfc_add_expr_to_block (&tse->post, ttmp);
9867 :
9868 42 : tse->expr = tvar;
9869 42 : tse->string_length = tlen;
9870 42 : }
9871 :
9872 :
9873 : /* The following routine generates code for the intrinsic functions from
9874 : the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
9875 : F_C_STRING. */
9876 :
9877 : static void
9878 9481 : conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9879 : {
9880 9481 : gfc_actual_arglist *arg = expr->value.function.actual;
9881 :
9882 9481 : if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9883 : {
9884 7177 : if (arg->expr->rank == 0)
9885 1982 : gfc_conv_expr_reference (se, arg->expr);
9886 5195 : else if (gfc_is_simply_contiguous (arg->expr, false, false))
9887 4159 : gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9888 : else
9889 : {
9890 1036 : gfc_conv_expr_descriptor (se, arg->expr);
9891 1036 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9892 : }
9893 :
9894 : /* TODO -- the following two lines shouldn't be necessary, but if
9895 : they're removed, a bug is exposed later in the code path.
9896 : This workaround was thus introduced, but will have to be
9897 : removed; please see PR 35150 for details about the issue. */
9898 7177 : se->expr = convert (pvoid_type_node, se->expr);
9899 7177 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9900 : }
9901 2304 : else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9902 : {
9903 232 : gfc_conv_expr_reference (se, arg->expr);
9904 : /* The code below is necessary to create a reference from the calling
9905 : subprogram to the argument of C_FUNLOC() in the call graph.
9906 : Please see PR 117303 for more details. */
9907 232 : se->expr = convert (pvoid_type_node, se->expr);
9908 232 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9909 : }
9910 2072 : else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9911 : {
9912 2030 : gfc_se arg1se;
9913 2030 : gfc_se arg2se;
9914 :
9915 : /* Build the addr_expr for the first argument. The argument is
9916 : already an *address* so we don't need to set want_pointer in
9917 : the gfc_se. */
9918 2030 : gfc_init_se (&arg1se, NULL);
9919 2030 : gfc_conv_expr (&arg1se, arg->expr);
9920 2030 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9921 2030 : gfc_add_block_to_block (&se->post, &arg1se.post);
9922 :
9923 : /* See if we were given two arguments. */
9924 2030 : if (arg->next->expr == NULL)
9925 : /* Only given one arg so generate a null and do a
9926 : not-equal comparison against the first arg. */
9927 1675 : se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9928 : arg1se.expr,
9929 1675 : fold_convert (TREE_TYPE (arg1se.expr),
9930 : null_pointer_node));
9931 : else
9932 : {
9933 355 : tree eq_expr;
9934 355 : tree not_null_expr;
9935 :
9936 : /* Given two arguments so build the arg2se from second arg. */
9937 355 : gfc_init_se (&arg2se, NULL);
9938 355 : gfc_conv_expr (&arg2se, arg->next->expr);
9939 355 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9940 355 : gfc_add_block_to_block (&se->post, &arg2se.post);
9941 :
9942 : /* Generate test to compare that the two args are equal. */
9943 355 : eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9944 : arg1se.expr, arg2se.expr);
9945 : /* Generate test to ensure that the first arg is not null. */
9946 355 : not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9947 : logical_type_node,
9948 : arg1se.expr, null_pointer_node);
9949 :
9950 : /* Finally, the generated test must check that both arg1 is not
9951 : NULL and that it is equal to the second arg. */
9952 355 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9953 : logical_type_node,
9954 : not_null_expr, eq_expr);
9955 : }
9956 : }
9957 42 : else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
9958 : {
9959 : /* There are three cases:
9960 : f_c_string(string) -> trim(string) // c_null_char
9961 : f_c_string(string, .false.) -> trim(string) // c_null_char
9962 : f_c_string(string, .true.) -> string // c_null_char */
9963 :
9964 42 : gfc_se lse, rse, tse;
9965 42 : tree len, tmp, var;
9966 42 : gfc_expr *string = arg->expr;
9967 42 : gfc_expr *asis = arg->next->expr;
9968 42 : gfc_expr *cnc;
9969 :
9970 : /* Convert string. */
9971 42 : gfc_init_se (&lse, se);
9972 42 : gfc_conv_expr (&lse, string);
9973 42 : gfc_conv_string_parameter (&lse);
9974 :
9975 : /* Create a string for C_NULL_CHAR and convert it. */
9976 42 : cnc = gfc_get_character_expr (gfc_default_character_kind,
9977 : &string->where, "\0", 1);
9978 42 : gfc_init_se (&rse, se);
9979 42 : gfc_conv_expr (&rse, cnc);
9980 42 : gfc_conv_string_parameter (&rse);
9981 42 : gfc_free_expr (cnc);
9982 :
9983 : #ifdef cnode
9984 : #undef cnode
9985 : #endif
9986 : #define cnode gfc_charlen_type_node
9987 42 : if (asis)
9988 : {
9989 30 : stmtblock_t block;
9990 30 : gfc_se asis_se, vse;
9991 30 : tree elen, evar, tlen, tvar;
9992 30 : tree else_branch, then_branch;
9993 :
9994 30 : elen = evar = tlen = tvar = NULL_TREE;
9995 :
9996 : /* f_c_string(string, .true.) -> string // c_null_char */
9997 :
9998 30 : gfc_init_block (&block);
9999 :
10000 30 : gfc_add_block_to_block (&block, &lse.pre);
10001 30 : gfc_add_block_to_block (&block, &rse.pre);
10002 :
10003 30 : tlen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
10004 : fold_convert (cnode, lse.string_length),
10005 : fold_convert (cnode, rse.string_length));
10006 :
10007 30 : gfc_init_se (&vse, se);
10008 30 : tvar = gfc_conv_string_tmp (&vse, pchar_type_node, tlen);
10009 30 : gfc_add_block_to_block (&block, &vse.pre);
10010 :
10011 30 : tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
10012 : 6, tlen, tvar,
10013 : lse.string_length, lse.expr,
10014 : rse.string_length, rse.expr);
10015 30 : gfc_add_expr_to_block (&block, tmp);
10016 :
10017 30 : then_branch = gfc_finish_block (&block);
10018 :
10019 : /* f_c_string(string, .false.) = trim(string) // c_null_char */
10020 :
10021 30 : gfc_init_block (&block);
10022 :
10023 30 : gfc_init_se (&tse, se);
10024 30 : conv_trim (&tse, &lse);
10025 30 : gfc_add_block_to_block (&block, &tse.pre);
10026 30 : gfc_add_block_to_block (&block, &rse.pre);
10027 :
10028 30 : elen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
10029 : fold_convert (cnode, tse.string_length),
10030 : fold_convert (cnode, rse.string_length));
10031 :
10032 30 : gfc_init_se (&vse, se);
10033 30 : evar = gfc_conv_string_tmp (&vse, pchar_type_node, elen);
10034 30 : gfc_add_block_to_block (&block, &vse.pre);
10035 :
10036 30 : tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
10037 : 6, elen, evar,
10038 : tse.string_length, tse.expr,
10039 : rse.string_length, rse.expr);
10040 30 : gfc_add_expr_to_block (&block, tmp);
10041 :
10042 30 : else_branch = gfc_finish_block (&block);
10043 :
10044 30 : gfc_init_se (&asis_se, se);
10045 30 : gfc_conv_expr (&asis_se, asis);
10046 30 : if (asis->expr_type == EXPR_VARIABLE
10047 18 : && asis->symtree->n.sym->attr.dummy
10048 6 : && asis->symtree->n.sym->attr.optional)
10049 : {
10050 6 : tree present = gfc_conv_expr_present (asis->symtree->n.sym);
10051 6 : asis_se.expr = build3_loc (input_location, COND_EXPR,
10052 : logical_type_node, present,
10053 : asis_se.expr,
10054 : build_int_cst (logical_type_node, 0));
10055 : }
10056 30 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10057 30 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10058 : asis_se.expr, then_branch, else_branch);
10059 :
10060 30 : gfc_add_expr_to_block (&se->pre, tmp);
10061 :
10062 30 : var = fold_build3_loc (input_location, COND_EXPR, pchar_type_node,
10063 : asis_se.expr, tvar, evar);
10064 30 : gfc_add_expr_to_block (&se->pre, var);
10065 :
10066 30 : len = fold_build3_loc (input_location, COND_EXPR, cnode,
10067 : asis_se.expr, tlen, elen);
10068 30 : gfc_add_expr_to_block (&se->pre, len);
10069 : }
10070 : else
10071 : {
10072 : /* f_c_string(string) = trim(string) // c_null_char */
10073 :
10074 12 : gfc_add_block_to_block (&se->pre, &lse.pre);
10075 12 : gfc_add_block_to_block (&se->pre, &rse.pre);
10076 :
10077 12 : gfc_init_se (&tse, se);
10078 12 : conv_trim (&tse, &lse);
10079 12 : gfc_add_block_to_block (&se->pre, &tse.pre);
10080 12 : gfc_add_block_to_block (&se->post, &tse.post);
10081 :
10082 12 : len = fold_build2_loc (input_location, PLUS_EXPR, cnode,
10083 : fold_convert (cnode, tse.string_length),
10084 : fold_convert (cnode, rse.string_length));
10085 :
10086 12 : var = gfc_conv_string_tmp (se, pchar_type_node, len);
10087 :
10088 12 : tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
10089 : 6, len, var,
10090 : tse.string_length, tse.expr,
10091 : rse.string_length, rse.expr);
10092 12 : gfc_add_expr_to_block (&se->pre, tmp);
10093 : }
10094 :
10095 42 : se->expr = var;
10096 42 : se->string_length = len;
10097 :
10098 : #undef cnode
10099 : }
10100 : else
10101 0 : gcc_unreachable ();
10102 9481 : }
10103 :
10104 :
10105 : /* The following routine generates code for the intrinsic
10106 : subroutines from the ISO_C_BINDING module:
10107 : * C_F_POINTER
10108 : * C_F_PROCPOINTER. */
10109 :
10110 : static tree
10111 3084 : conv_isocbinding_subroutine (gfc_code *code)
10112 : {
10113 3084 : gfc_expr *cptr, *fptr, *shape, *lower;
10114 3084 : gfc_se se, cptrse, fptrse, shapese, lowerse;
10115 3084 : gfc_ss *shape_ss, *lower_ss;
10116 3084 : tree desc, dim, tmp, stride, offset, lbound, ubound;
10117 3084 : stmtblock_t body, block;
10118 3084 : gfc_loopinfo loop;
10119 3084 : gfc_actual_arglist *arg;
10120 :
10121 3084 : arg = code->ext.actual;
10122 3084 : cptr = arg->expr;
10123 3084 : fptr = arg->next->expr;
10124 3084 : shape = arg->next->next ? arg->next->next->expr : NULL;
10125 3026 : lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
10126 :
10127 3084 : gfc_init_se (&se, NULL);
10128 3084 : gfc_init_se (&cptrse, NULL);
10129 3084 : gfc_conv_expr (&cptrse, cptr);
10130 3084 : gfc_add_block_to_block (&se.pre, &cptrse.pre);
10131 3084 : gfc_add_block_to_block (&se.post, &cptrse.post);
10132 :
10133 3084 : gfc_init_se (&fptrse, NULL);
10134 3084 : if (fptr->rank == 0)
10135 : {
10136 2599 : fptrse.want_pointer = 1;
10137 2599 : gfc_conv_expr (&fptrse, fptr);
10138 2599 : gfc_add_block_to_block (&se.pre, &fptrse.pre);
10139 2599 : gfc_add_block_to_block (&se.post, &fptrse.post);
10140 2599 : if (fptr->symtree->n.sym->attr.proc_pointer
10141 57 : && fptr->symtree->n.sym->attr.dummy)
10142 7 : fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
10143 2599 : se.expr
10144 2599 : = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
10145 : fptrse.expr,
10146 2599 : fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
10147 2599 : gfc_add_expr_to_block (&se.pre, se.expr);
10148 2599 : gfc_add_block_to_block (&se.pre, &se.post);
10149 2599 : return gfc_finish_block (&se.pre);
10150 : }
10151 :
10152 485 : gfc_start_block (&block);
10153 :
10154 : /* Get the descriptor of the Fortran pointer. */
10155 485 : fptrse.descriptor_only = 1;
10156 485 : gfc_conv_expr_descriptor (&fptrse, fptr);
10157 485 : gfc_add_block_to_block (&block, &fptrse.pre);
10158 485 : desc = fptrse.expr;
10159 :
10160 : /* Set the span field. */
10161 485 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
10162 485 : tmp = fold_convert (gfc_array_index_type, tmp);
10163 485 : gfc_conv_descriptor_span_set (&block, desc, tmp);
10164 :
10165 : /* Set data value, dtype, and offset. */
10166 485 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
10167 485 : gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
10168 485 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
10169 485 : gfc_get_dtype (TREE_TYPE (desc)));
10170 :
10171 : /* Start scalarization of the bounds, using the shape argument. */
10172 :
10173 485 : shape_ss = gfc_walk_expr (shape);
10174 485 : gcc_assert (shape_ss != gfc_ss_terminator);
10175 485 : gfc_init_se (&shapese, NULL);
10176 485 : if (lower)
10177 : {
10178 12 : lower_ss = gfc_walk_expr (lower);
10179 12 : gcc_assert (lower_ss != gfc_ss_terminator);
10180 12 : gfc_init_se (&lowerse, NULL);
10181 : }
10182 :
10183 485 : gfc_init_loopinfo (&loop);
10184 485 : gfc_add_ss_to_loop (&loop, shape_ss);
10185 485 : if (lower)
10186 12 : gfc_add_ss_to_loop (&loop, lower_ss);
10187 485 : gfc_conv_ss_startstride (&loop);
10188 485 : gfc_conv_loop_setup (&loop, &fptr->where);
10189 485 : gfc_mark_ss_chain_used (shape_ss, 1);
10190 485 : if (lower)
10191 12 : gfc_mark_ss_chain_used (lower_ss, 1);
10192 :
10193 485 : gfc_copy_loopinfo_to_se (&shapese, &loop);
10194 485 : shapese.ss = shape_ss;
10195 485 : if (lower)
10196 : {
10197 12 : gfc_copy_loopinfo_to_se (&lowerse, &loop);
10198 12 : lowerse.ss = lower_ss;
10199 : }
10200 :
10201 485 : stride = gfc_create_var (gfc_array_index_type, "stride");
10202 485 : offset = gfc_create_var (gfc_array_index_type, "offset");
10203 485 : gfc_add_modify (&block, stride, gfc_index_one_node);
10204 485 : gfc_add_modify (&block, offset, gfc_index_zero_node);
10205 :
10206 : /* Loop body. */
10207 485 : gfc_start_scalarized_body (&loop, &body);
10208 :
10209 485 : dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10210 : loop.loopvar[0], loop.from[0]);
10211 :
10212 485 : if (lower)
10213 : {
10214 12 : gfc_conv_expr (&lowerse, lower);
10215 12 : gfc_add_block_to_block (&body, &lowerse.pre);
10216 12 : lbound = fold_convert (gfc_array_index_type, lowerse.expr);
10217 12 : gfc_add_block_to_block (&body, &lowerse.post);
10218 : }
10219 : else
10220 473 : lbound = gfc_index_one_node;
10221 :
10222 : /* Set bounds and stride. */
10223 485 : gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
10224 485 : gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
10225 :
10226 485 : gfc_conv_expr (&shapese, shape);
10227 485 : gfc_add_block_to_block (&body, &shapese.pre);
10228 485 : ubound = fold_build2_loc (
10229 : input_location, MINUS_EXPR, gfc_array_index_type,
10230 : fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
10231 : fold_convert (gfc_array_index_type, shapese.expr)),
10232 : gfc_index_one_node);
10233 485 : gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
10234 485 : gfc_add_block_to_block (&body, &shapese.post);
10235 :
10236 : /* Calculate offset. */
10237 485 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10238 : stride, lbound);
10239 485 : gfc_add_modify (&body, offset,
10240 : fold_build2_loc (input_location, PLUS_EXPR,
10241 : gfc_array_index_type, offset, tmp));
10242 :
10243 : /* Update stride. */
10244 485 : gfc_add_modify (
10245 : &body, stride,
10246 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
10247 : fold_convert (gfc_array_index_type, shapese.expr)));
10248 : /* Finish scalarization loop. */
10249 485 : gfc_trans_scalarizing_loops (&loop, &body);
10250 485 : gfc_add_block_to_block (&block, &loop.pre);
10251 485 : gfc_add_block_to_block (&block, &loop.post);
10252 485 : gfc_add_block_to_block (&block, &fptrse.post);
10253 485 : gfc_cleanup_loop (&loop);
10254 :
10255 485 : gfc_add_modify (&block, offset,
10256 : fold_build1_loc (input_location, NEGATE_EXPR,
10257 : gfc_array_index_type, offset));
10258 485 : gfc_conv_descriptor_offset_set (&block, desc, offset);
10259 :
10260 485 : gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
10261 485 : gfc_add_block_to_block (&se.pre, &se.post);
10262 485 : return gfc_finish_block (&se.pre);
10263 : }
10264 :
10265 :
10266 : /* Save and restore floating-point state. */
10267 :
10268 : tree
10269 947 : gfc_save_fp_state (stmtblock_t *block)
10270 : {
10271 947 : tree type, fpstate, tmp;
10272 :
10273 947 : type = build_array_type (char_type_node,
10274 : build_range_type (size_type_node, size_zero_node,
10275 : size_int (GFC_FPE_STATE_BUFFER_SIZE)));
10276 947 : fpstate = gfc_create_var (type, "fpstate");
10277 947 : fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
10278 :
10279 947 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
10280 : 1, fpstate);
10281 947 : gfc_add_expr_to_block (block, tmp);
10282 :
10283 947 : return fpstate;
10284 : }
10285 :
10286 :
10287 : void
10288 947 : gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
10289 : {
10290 947 : tree tmp;
10291 :
10292 947 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
10293 : 1, fpstate);
10294 947 : gfc_add_expr_to_block (block, tmp);
10295 947 : }
10296 :
10297 :
10298 : /* Generate code for arguments of IEEE functions. */
10299 :
10300 : static void
10301 12457 : conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
10302 : int nargs)
10303 : {
10304 12457 : gfc_actual_arglist *actual;
10305 12457 : gfc_expr *e;
10306 12457 : gfc_se argse;
10307 12457 : int arg;
10308 :
10309 12457 : actual = expr->value.function.actual;
10310 34461 : for (arg = 0; arg < nargs; arg++, actual = actual->next)
10311 : {
10312 22004 : gcc_assert (actual);
10313 22004 : e = actual->expr;
10314 :
10315 22004 : gfc_init_se (&argse, se);
10316 22004 : gfc_conv_expr_val (&argse, e);
10317 :
10318 22004 : gfc_add_block_to_block (&se->pre, &argse.pre);
10319 22004 : gfc_add_block_to_block (&se->post, &argse.post);
10320 22004 : argarray[arg] = argse.expr;
10321 : }
10322 12457 : }
10323 :
10324 :
10325 : /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
10326 : and IEEE_UNORDERED, which translate directly to GCC type-generic
10327 : built-ins. */
10328 :
10329 : static void
10330 1062 : conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
10331 : enum built_in_function code, int nargs)
10332 : {
10333 1062 : tree args[2];
10334 1062 : gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
10335 :
10336 1062 : conv_ieee_function_args (se, expr, args, nargs);
10337 1062 : se->expr = build_call_expr_loc_array (input_location,
10338 : builtin_decl_explicit (code),
10339 : nargs, args);
10340 2388 : STRIP_TYPE_NOPS (se->expr);
10341 1062 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10342 1062 : }
10343 :
10344 :
10345 : /* Generate code for intrinsics IEEE_SIGNBIT. */
10346 :
10347 : static void
10348 624 : conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
10349 : {
10350 624 : tree arg, signbit;
10351 :
10352 624 : conv_ieee_function_args (se, expr, &arg, 1);
10353 624 : signbit = build_call_expr_loc (input_location,
10354 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10355 : 1, arg);
10356 624 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10357 : signbit, integer_zero_node);
10358 624 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
10359 624 : }
10360 :
10361 :
10362 : /* Generate code for IEEE_IS_NORMAL intrinsic:
10363 : IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
10364 :
10365 : static void
10366 312 : conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
10367 : {
10368 312 : tree arg, isnormal, iszero;
10369 :
10370 : /* Convert arg, evaluate it only once. */
10371 312 : conv_ieee_function_args (se, expr, &arg, 1);
10372 312 : arg = gfc_evaluate_now (arg, &se->pre);
10373 :
10374 312 : isnormal = build_call_expr_loc (input_location,
10375 : builtin_decl_explicit (BUILT_IN_ISNORMAL),
10376 : 1, arg);
10377 312 : iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
10378 312 : build_real_from_int_cst (TREE_TYPE (arg),
10379 312 : integer_zero_node));
10380 312 : se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10381 : logical_type_node, isnormal, iszero);
10382 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10383 312 : }
10384 :
10385 :
10386 : /* Generate code for IEEE_IS_NEGATIVE intrinsic:
10387 : IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10388 :
10389 : static void
10390 312 : conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
10391 : {
10392 312 : tree arg, signbit, isnan;
10393 :
10394 : /* Convert arg, evaluate it only once. */
10395 312 : conv_ieee_function_args (se, expr, &arg, 1);
10396 312 : arg = gfc_evaluate_now (arg, &se->pre);
10397 :
10398 312 : isnan = build_call_expr_loc (input_location,
10399 : builtin_decl_explicit (BUILT_IN_ISNAN),
10400 : 1, arg);
10401 936 : STRIP_TYPE_NOPS (isnan);
10402 :
10403 312 : signbit = build_call_expr_loc (input_location,
10404 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10405 : 1, arg);
10406 312 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10407 : signbit, integer_zero_node);
10408 :
10409 312 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10410 : logical_type_node, signbit,
10411 : fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10412 312 : TREE_TYPE(isnan), isnan));
10413 :
10414 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10415 312 : }
10416 :
10417 :
10418 : /* Generate code for IEEE_LOGB and IEEE_RINT. */
10419 :
10420 : static void
10421 240 : conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
10422 : enum built_in_function code)
10423 : {
10424 240 : tree arg, decl, call, fpstate;
10425 240 : int argprec;
10426 :
10427 240 : conv_ieee_function_args (se, expr, &arg, 1);
10428 240 : argprec = TYPE_PRECISION (TREE_TYPE (arg));
10429 240 : decl = builtin_decl_for_precision (code, argprec);
10430 :
10431 : /* Save floating-point state. */
10432 240 : fpstate = gfc_save_fp_state (&se->pre);
10433 :
10434 : /* Make the function call. */
10435 240 : call = build_call_expr_loc (input_location, decl, 1, arg);
10436 240 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
10437 :
10438 : /* Restore floating-point state. */
10439 240 : gfc_restore_fp_state (&se->post, fpstate);
10440 240 : }
10441 :
10442 :
10443 : /* Generate code for IEEE_REM. */
10444 :
10445 : static void
10446 84 : conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
10447 : {
10448 84 : tree args[2], decl, call, fpstate;
10449 84 : int argprec;
10450 :
10451 84 : conv_ieee_function_args (se, expr, args, 2);
10452 :
10453 : /* If arguments have unequal size, convert them to the larger. */
10454 84 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
10455 84 : > TYPE_PRECISION (TREE_TYPE (args[1])))
10456 6 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10457 78 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
10458 78 : > TYPE_PRECISION (TREE_TYPE (args[0])))
10459 24 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
10460 :
10461 84 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10462 84 : decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
10463 :
10464 : /* Save floating-point state. */
10465 84 : fpstate = gfc_save_fp_state (&se->pre);
10466 :
10467 : /* Make the function call. */
10468 84 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10469 84 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10470 :
10471 : /* Restore floating-point state. */
10472 84 : gfc_restore_fp_state (&se->post, fpstate);
10473 84 : }
10474 :
10475 :
10476 : /* Generate code for IEEE_NEXT_AFTER. */
10477 :
10478 : static void
10479 180 : conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
10480 : {
10481 180 : tree args[2], decl, call, fpstate;
10482 180 : int argprec;
10483 :
10484 180 : conv_ieee_function_args (se, expr, args, 2);
10485 :
10486 : /* Result has the characteristics of first argument. */
10487 180 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10488 180 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10489 180 : decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
10490 :
10491 : /* Save floating-point state. */
10492 180 : fpstate = gfc_save_fp_state (&se->pre);
10493 :
10494 : /* Make the function call. */
10495 180 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10496 180 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10497 :
10498 : /* Restore floating-point state. */
10499 180 : gfc_restore_fp_state (&se->post, fpstate);
10500 180 : }
10501 :
10502 :
10503 : /* Generate code for IEEE_SCALB. */
10504 :
10505 : static void
10506 228 : conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10507 : {
10508 228 : tree args[2], decl, call, huge, type;
10509 228 : int argprec, n;
10510 :
10511 228 : conv_ieee_function_args (se, expr, args, 2);
10512 :
10513 : /* Result has the characteristics of first argument. */
10514 228 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10515 228 : decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10516 :
10517 228 : if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10518 : {
10519 : /* We need to fold the integer into the range of a C int. */
10520 18 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10521 18 : type = TREE_TYPE (args[1]);
10522 :
10523 18 : n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10524 18 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10525 : gfc_c_int_kind);
10526 18 : huge = fold_convert (type, huge);
10527 18 : args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10528 : huge);
10529 18 : args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10530 : fold_build1_loc (input_location, NEGATE_EXPR,
10531 : type, huge));
10532 : }
10533 :
10534 228 : args[1] = fold_convert (integer_type_node, args[1]);
10535 :
10536 : /* Make the function call. */
10537 228 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10538 228 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10539 228 : }
10540 :
10541 :
10542 : /* Generate code for IEEE_COPY_SIGN. */
10543 :
10544 : static void
10545 576 : conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10546 : {
10547 576 : tree args[2], decl, sign;
10548 576 : int argprec;
10549 :
10550 576 : conv_ieee_function_args (se, expr, args, 2);
10551 :
10552 : /* Get the sign of the second argument. */
10553 576 : sign = build_call_expr_loc (input_location,
10554 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10555 : 1, args[1]);
10556 576 : sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10557 : sign, integer_zero_node);
10558 :
10559 : /* Create a value of one, with the right sign. */
10560 576 : sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10561 : sign,
10562 : fold_build1_loc (input_location, NEGATE_EXPR,
10563 : integer_type_node,
10564 : integer_one_node),
10565 : integer_one_node);
10566 576 : args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10567 :
10568 576 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10569 576 : decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10570 :
10571 576 : se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10572 576 : }
10573 :
10574 :
10575 : /* Generate code for IEEE_CLASS. */
10576 :
10577 : static void
10578 648 : conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10579 : {
10580 648 : tree arg, c, t1, t2, t3, t4;
10581 :
10582 : /* Convert arg, evaluate it only once. */
10583 648 : conv_ieee_function_args (se, expr, &arg, 1);
10584 648 : arg = gfc_evaluate_now (arg, &se->pre);
10585 :
10586 648 : c = build_call_expr_loc (input_location,
10587 : builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
10588 : build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10589 : build_int_cst (integer_type_node,
10590 : IEEE_POSITIVE_INF),
10591 : build_int_cst (integer_type_node,
10592 : IEEE_POSITIVE_NORMAL),
10593 : build_int_cst (integer_type_node,
10594 : IEEE_POSITIVE_DENORMAL),
10595 : build_int_cst (integer_type_node,
10596 : IEEE_POSITIVE_ZERO),
10597 : arg);
10598 648 : c = gfc_evaluate_now (c, &se->pre);
10599 648 : t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10600 : c, build_int_cst (integer_type_node,
10601 : IEEE_QUIET_NAN));
10602 648 : t2 = build_call_expr_loc (input_location,
10603 : builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
10604 : arg);
10605 648 : t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10606 648 : t2, build_zero_cst (TREE_TYPE (t2)));
10607 648 : t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10608 : logical_type_node, t1, t2);
10609 648 : t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10610 : c, build_int_cst (integer_type_node,
10611 : IEEE_POSITIVE_ZERO));
10612 648 : t4 = build_call_expr_loc (input_location,
10613 : builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
10614 : arg);
10615 648 : t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10616 648 : t4, build_zero_cst (TREE_TYPE (t4)));
10617 648 : t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10618 : logical_type_node, t3, t4);
10619 648 : int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10620 648 : gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10621 648 : gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10622 648 : gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10623 648 : gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10624 648 : gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10625 648 : t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10626 648 : build_int_cst (TREE_TYPE (c), s), c);
10627 648 : t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10628 : t3, t4, c);
10629 648 : t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10630 648 : build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10631 : t3);
10632 648 : tree type = gfc_typenode_for_spec (&expr->ts);
10633 : /* Perform a quick sanity check that the return type is
10634 : IEEE_CLASS_TYPE derived type defined in
10635 : libgfortran/ieee/ieee_arithmetic.F90
10636 : Primarily check that it is a derived type with a single
10637 : member in it. */
10638 648 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10639 648 : tree field = NULL_TREE;
10640 1296 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10641 648 : if (TREE_CODE (f) == FIELD_DECL)
10642 : {
10643 648 : gcc_assert (field == NULL_TREE);
10644 : field = f;
10645 : }
10646 648 : gcc_assert (field);
10647 648 : t1 = fold_convert (TREE_TYPE (field), t1);
10648 648 : se->expr = build_constructor_single (type, field, t1);
10649 648 : }
10650 :
10651 :
10652 : /* Generate code for IEEE_VALUE. */
10653 :
10654 : static void
10655 1111 : conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10656 : {
10657 1111 : tree args[2], arg, ret, tmp;
10658 1111 : stmtblock_t body;
10659 :
10660 : /* Convert args, evaluate the second one only once. */
10661 1111 : conv_ieee_function_args (se, expr, args, 2);
10662 1111 : arg = gfc_evaluate_now (args[1], &se->pre);
10663 :
10664 1111 : tree type = TREE_TYPE (arg);
10665 : /* Perform a quick sanity check that the second argument's type is
10666 : IEEE_CLASS_TYPE derived type defined in
10667 : libgfortran/ieee/ieee_arithmetic.F90
10668 : Primarily check that it is a derived type with a single
10669 : member in it. */
10670 1111 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10671 1111 : tree field = NULL_TREE;
10672 2222 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10673 1111 : if (TREE_CODE (f) == FIELD_DECL)
10674 : {
10675 1111 : gcc_assert (field == NULL_TREE);
10676 : field = f;
10677 : }
10678 1111 : gcc_assert (field);
10679 1111 : arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10680 : arg, field, NULL_TREE);
10681 1111 : arg = gfc_evaluate_now (arg, &se->pre);
10682 :
10683 1111 : type = gfc_typenode_for_spec (&expr->ts);
10684 1111 : gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10685 1111 : ret = gfc_create_var (type, NULL);
10686 :
10687 1111 : gfc_init_block (&body);
10688 :
10689 1111 : tree end_label = gfc_build_label_decl (NULL_TREE);
10690 12221 : for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10691 : {
10692 11110 : tree label = gfc_build_label_decl (NULL_TREE);
10693 11110 : tree low = build_int_cst (TREE_TYPE (arg), c);
10694 11110 : tmp = build_case_label (low, low, label);
10695 11110 : gfc_add_expr_to_block (&body, tmp);
10696 :
10697 11110 : REAL_VALUE_TYPE real;
10698 11110 : int k;
10699 11110 : switch (c)
10700 : {
10701 1111 : case IEEE_SIGNALING_NAN:
10702 1111 : real_nan (&real, "", 0, TYPE_MODE (type));
10703 1111 : break;
10704 1111 : case IEEE_QUIET_NAN:
10705 1111 : real_nan (&real, "", 1, TYPE_MODE (type));
10706 1111 : break;
10707 1111 : case IEEE_NEGATIVE_INF:
10708 1111 : real_inf (&real);
10709 1111 : real = real_value_negate (&real);
10710 1111 : break;
10711 1111 : case IEEE_NEGATIVE_NORMAL:
10712 1111 : real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10713 1111 : break;
10714 1111 : case IEEE_NEGATIVE_DENORMAL:
10715 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10716 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10717 : type, GFC_RND_MODE);
10718 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10719 1111 : real = real_value_negate (&real);
10720 1111 : break;
10721 1111 : case IEEE_NEGATIVE_ZERO:
10722 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10723 1111 : real = real_value_negate (&real);
10724 1111 : break;
10725 1111 : case IEEE_POSITIVE_ZERO:
10726 : /* Make this also the default: label. The other possibility
10727 : would be to add a separate default: label followed by
10728 : __builtin_unreachable (). */
10729 1111 : label = gfc_build_label_decl (NULL_TREE);
10730 1111 : tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10731 1111 : gfc_add_expr_to_block (&body, tmp);
10732 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10733 1111 : break;
10734 1111 : case IEEE_POSITIVE_DENORMAL:
10735 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10736 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10737 : type, GFC_RND_MODE);
10738 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10739 1111 : break;
10740 1111 : case IEEE_POSITIVE_NORMAL:
10741 1111 : real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10742 1111 : break;
10743 1111 : case IEEE_POSITIVE_INF:
10744 1111 : real_inf (&real);
10745 1111 : break;
10746 : default:
10747 : gcc_unreachable ();
10748 : }
10749 :
10750 11110 : tree val = build_real (type, real);
10751 11110 : gfc_add_modify (&body, ret, val);
10752 :
10753 11110 : tmp = build1_v (GOTO_EXPR, end_label);
10754 11110 : gfc_add_expr_to_block (&body, tmp);
10755 : }
10756 :
10757 1111 : tmp = gfc_finish_block (&body);
10758 1111 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10759 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10760 :
10761 1111 : tmp = build1_v (LABEL_EXPR, end_label);
10762 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10763 :
10764 1111 : se->expr = ret;
10765 1111 : }
10766 :
10767 :
10768 : /* Generate code for IEEE_FMA. */
10769 :
10770 : static void
10771 120 : conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10772 : {
10773 120 : tree args[3], decl, call;
10774 120 : int argprec;
10775 :
10776 120 : conv_ieee_function_args (se, expr, args, 3);
10777 :
10778 : /* All three arguments should have the same type. */
10779 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10780 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10781 :
10782 : /* Call the type-generic FMA built-in. */
10783 120 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10784 120 : decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
10785 120 : call = build_call_expr_loc_array (input_location, decl, 3, args);
10786 :
10787 : /* Convert to the final type. */
10788 120 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10789 120 : }
10790 :
10791 :
10792 : /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10793 :
10794 : static void
10795 3072 : conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10796 : const char *name)
10797 : {
10798 3072 : tree args[2], func;
10799 3072 : built_in_function fn;
10800 :
10801 3072 : conv_ieee_function_args (se, expr, args, 2);
10802 3072 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10803 3072 : args[0] = gfc_evaluate_now (args[0], &se->pre);
10804 3072 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10805 :
10806 3072 : if (startswith (name, "mag"))
10807 : {
10808 : /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10809 : fminmag() and fmaxmag(), which do not exist as built-ins.
10810 :
10811 : Following glibc, we emit this:
10812 :
10813 : fminmag (x, y) {
10814 : ax = ABS (x);
10815 : ay = ABS (y);
10816 : if (isless (ax, ay))
10817 : return x;
10818 : else if (isgreater (ax, ay))
10819 : return y;
10820 : else if (ax == ay)
10821 : return x < y ? x : y;
10822 : else if (issignaling (x) || issignaling (y))
10823 : return x + y;
10824 : else
10825 : return isnan (y) ? x : y;
10826 : }
10827 :
10828 : fmaxmag (x, y) {
10829 : ax = ABS (x);
10830 : ay = ABS (y);
10831 : if (isgreater (ax, ay))
10832 : return x;
10833 : else if (isless (ax, ay))
10834 : return y;
10835 : else if (ax == ay)
10836 : return x > y ? x : y;
10837 : else if (issignaling (x) || issignaling (y))
10838 : return x + y;
10839 : else
10840 : return isnan (y) ? x : y;
10841 : }
10842 :
10843 : */
10844 :
10845 1536 : tree abs0, abs1, sig0, sig1;
10846 1536 : tree cond1, cond2, cond3, cond4, cond5;
10847 1536 : tree res;
10848 1536 : tree type = TREE_TYPE (args[0]);
10849 :
10850 1536 : func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
10851 1536 : abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
10852 1536 : abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
10853 1536 : abs0 = gfc_evaluate_now (abs0, &se->pre);
10854 1536 : abs1 = gfc_evaluate_now (abs1, &se->pre);
10855 :
10856 1536 : cond5 = build_call_expr_loc (input_location,
10857 : builtin_decl_explicit (BUILT_IN_ISNAN),
10858 : 1, args[1]);
10859 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
10860 : args[0], args[1]);
10861 :
10862 1536 : sig0 = build_call_expr_loc (input_location,
10863 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
10864 : 1, args[0]);
10865 1536 : sig1 = build_call_expr_loc (input_location,
10866 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
10867 : 1, args[1]);
10868 1536 : cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
10869 : logical_type_node, sig0, sig1);
10870 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
10871 : fold_build2_loc (input_location, PLUS_EXPR,
10872 : type, args[0], args[1]),
10873 : res);
10874 :
10875 1536 : cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10876 : abs0, abs1);
10877 2304 : res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
10878 : fold_build2_loc (input_location,
10879 : max ? MAX_EXPR : MIN_EXPR,
10880 : type, args[0], args[1]),
10881 : res);
10882 :
10883 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
10884 1536 : cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10885 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
10886 : args[1], res);
10887 :
10888 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
10889 1536 : cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10890 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
10891 : args[0], res);
10892 :
10893 1536 : se->expr = res;
10894 : }
10895 : else
10896 : {
10897 : /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
10898 1536 : fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
10899 1536 : func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind);
10900 1536 : se->expr = build_call_expr_loc_array (input_location, func, 2, args);
10901 : }
10902 3072 : }
10903 :
10904 :
10905 : /* Generate code for comparison functions IEEE_QUIET_* and
10906 : IEEE_SIGNALING_*. */
10907 :
10908 : static void
10909 3888 : conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
10910 : const char *name)
10911 : {
10912 3888 : tree args[2];
10913 3888 : tree arg1, arg2, res;
10914 :
10915 : /* Evaluate arguments only once. */
10916 3888 : conv_ieee_function_args (se, expr, args, 2);
10917 3888 : arg1 = gfc_evaluate_now (args[0], &se->pre);
10918 3888 : arg2 = gfc_evaluate_now (args[1], &se->pre);
10919 :
10920 3888 : if (startswith (name, "eq"))
10921 : {
10922 648 : if (signaling)
10923 324 : res = build_call_expr_loc (input_location,
10924 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
10925 : 2, arg1, arg2);
10926 : else
10927 324 : res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10928 : arg1, arg2);
10929 : }
10930 3240 : else if (startswith (name, "ne"))
10931 : {
10932 648 : if (signaling)
10933 : {
10934 324 : res = build_call_expr_loc (input_location,
10935 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
10936 : 2, arg1, arg2);
10937 324 : res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10938 : logical_type_node, res);
10939 : }
10940 : else
10941 324 : res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10942 : arg1, arg2);
10943 : }
10944 2592 : else if (startswith (name, "ge"))
10945 : {
10946 648 : if (signaling)
10947 324 : res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10948 : arg1, arg2);
10949 : else
10950 324 : res = build_call_expr_loc (input_location,
10951 : builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
10952 : 2, arg1, arg2);
10953 : }
10954 1944 : else if (startswith (name, "gt"))
10955 : {
10956 648 : if (signaling)
10957 324 : res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
10958 : arg1, arg2);
10959 : else
10960 324 : res = build_call_expr_loc (input_location,
10961 : builtin_decl_explicit (BUILT_IN_ISGREATER),
10962 : 2, arg1, arg2);
10963 : }
10964 1296 : else if (startswith (name, "le"))
10965 : {
10966 648 : if (signaling)
10967 324 : res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
10968 : arg1, arg2);
10969 : else
10970 324 : res = build_call_expr_loc (input_location,
10971 : builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
10972 : 2, arg1, arg2);
10973 : }
10974 648 : else if (startswith (name, "lt"))
10975 : {
10976 648 : if (signaling)
10977 324 : res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10978 : arg1, arg2);
10979 : else
10980 324 : res = build_call_expr_loc (input_location,
10981 : builtin_decl_explicit (BUILT_IN_ISLESS),
10982 : 2, arg1, arg2);
10983 : }
10984 : else
10985 0 : gcc_unreachable ();
10986 :
10987 3888 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
10988 3888 : }
10989 :
10990 :
10991 : /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
10992 : module. */
10993 :
10994 : bool
10995 13939 : gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
10996 : {
10997 13939 : const char *name = expr->value.function.name;
10998 :
10999 13939 : if (startswith (name, "_gfortran_ieee_is_nan"))
11000 522 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
11001 13417 : else if (startswith (name, "_gfortran_ieee_is_finite"))
11002 372 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
11003 13045 : else if (startswith (name, "_gfortran_ieee_unordered"))
11004 168 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
11005 12877 : else if (startswith (name, "_gfortran_ieee_signbit"))
11006 624 : conv_intrinsic_ieee_signbit (se, expr);
11007 12253 : else if (startswith (name, "_gfortran_ieee_is_normal"))
11008 312 : conv_intrinsic_ieee_is_normal (se, expr);
11009 11941 : else if (startswith (name, "_gfortran_ieee_is_negative"))
11010 312 : conv_intrinsic_ieee_is_negative (se, expr);
11011 11629 : else if (startswith (name, "_gfortran_ieee_copy_sign"))
11012 576 : conv_intrinsic_ieee_copy_sign (se, expr);
11013 11053 : else if (startswith (name, "_gfortran_ieee_scalb"))
11014 228 : conv_intrinsic_ieee_scalb (se, expr);
11015 10825 : else if (startswith (name, "_gfortran_ieee_next_after"))
11016 180 : conv_intrinsic_ieee_next_after (se, expr);
11017 10645 : else if (startswith (name, "_gfortran_ieee_rem"))
11018 84 : conv_intrinsic_ieee_rem (se, expr);
11019 10561 : else if (startswith (name, "_gfortran_ieee_logb"))
11020 144 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
11021 10417 : else if (startswith (name, "_gfortran_ieee_rint"))
11022 96 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
11023 10321 : else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
11024 648 : conv_intrinsic_ieee_class (se, expr);
11025 9673 : else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
11026 1111 : conv_intrinsic_ieee_value (se, expr);
11027 8562 : else if (startswith (name, "_gfortran_ieee_fma"))
11028 120 : conv_intrinsic_ieee_fma (se, expr);
11029 8442 : else if (startswith (name, "_gfortran_ieee_min_num_"))
11030 1536 : conv_intrinsic_ieee_minmax (se, expr, 0, name + 23);
11031 6906 : else if (startswith (name, "_gfortran_ieee_max_num_"))
11032 1536 : conv_intrinsic_ieee_minmax (se, expr, 1, name + 23);
11033 5370 : else if (startswith (name, "_gfortran_ieee_quiet_"))
11034 1944 : conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
11035 3426 : else if (startswith (name, "_gfortran_ieee_signaling_"))
11036 1944 : conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
11037 : else
11038 : /* It is not among the functions we translate directly. We return
11039 : false, so a library function call is emitted. */
11040 : return false;
11041 :
11042 : return true;
11043 : }
11044 :
11045 :
11046 : /* Generate a direct call to malloc() for the MALLOC intrinsic. */
11047 :
11048 : static void
11049 16 : gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
11050 : {
11051 16 : tree arg, res, restype;
11052 :
11053 16 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
11054 16 : arg = fold_convert (size_type_node, arg);
11055 16 : res = build_call_expr_loc (input_location,
11056 : builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
11057 16 : restype = gfc_typenode_for_spec (&expr->ts);
11058 16 : se->expr = fold_convert (restype, res);
11059 16 : }
11060 :
11061 :
11062 : /* Generate code for an intrinsic function. Some map directly to library
11063 : calls, others get special handling. In some cases the name of the function
11064 : used depends on the type specifiers. */
11065 :
11066 : void
11067 260595 : gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
11068 : {
11069 260595 : const char *name;
11070 260595 : int lib, kind;
11071 260595 : tree fndecl;
11072 :
11073 260595 : name = &expr->value.function.name[2];
11074 :
11075 260595 : if (expr->rank > 0)
11076 : {
11077 50072 : lib = gfc_is_intrinsic_libcall (expr);
11078 50072 : if (lib != 0)
11079 : {
11080 19064 : if (lib == 1)
11081 11680 : se->ignore_optional = 1;
11082 :
11083 19064 : switch (expr->value.function.isym->id)
11084 : {
11085 5825 : case GFC_ISYM_EOSHIFT:
11086 5825 : case GFC_ISYM_PACK:
11087 5825 : case GFC_ISYM_RESHAPE:
11088 5825 : case GFC_ISYM_REDUCE:
11089 : /* For all of those the first argument specifies the type and the
11090 : third is optional. */
11091 5825 : conv_generic_with_optional_char_arg (se, expr, 1, 3);
11092 5825 : break;
11093 :
11094 1116 : case GFC_ISYM_FINDLOC:
11095 1116 : gfc_conv_intrinsic_findloc (se, expr);
11096 1116 : break;
11097 :
11098 2935 : case GFC_ISYM_MINLOC:
11099 2935 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11100 2935 : break;
11101 :
11102 2439 : case GFC_ISYM_MAXLOC:
11103 2439 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11104 2439 : break;
11105 :
11106 6749 : default:
11107 6749 : gfc_conv_intrinsic_funcall (se, expr);
11108 6749 : break;
11109 : }
11110 :
11111 19064 : return;
11112 : }
11113 : }
11114 :
11115 241531 : switch (expr->value.function.isym->id)
11116 : {
11117 0 : case GFC_ISYM_NONE:
11118 0 : gcc_unreachable ();
11119 :
11120 529 : case GFC_ISYM_REPEAT:
11121 529 : gfc_conv_intrinsic_repeat (se, expr);
11122 529 : break;
11123 :
11124 574 : case GFC_ISYM_TRIM:
11125 574 : gfc_conv_intrinsic_trim (se, expr);
11126 574 : break;
11127 :
11128 42 : case GFC_ISYM_SC_KIND:
11129 42 : gfc_conv_intrinsic_sc_kind (se, expr);
11130 42 : break;
11131 :
11132 45 : case GFC_ISYM_SI_KIND:
11133 45 : gfc_conv_intrinsic_si_kind (se, expr);
11134 45 : break;
11135 :
11136 6 : case GFC_ISYM_SL_KIND:
11137 6 : gfc_conv_intrinsic_sl_kind (se, expr);
11138 6 : break;
11139 :
11140 82 : case GFC_ISYM_SR_KIND:
11141 82 : gfc_conv_intrinsic_sr_kind (se, expr);
11142 82 : break;
11143 :
11144 228 : case GFC_ISYM_EXPONENT:
11145 228 : gfc_conv_intrinsic_exponent (se, expr);
11146 228 : break;
11147 :
11148 316 : case GFC_ISYM_SCAN:
11149 316 : kind = expr->value.function.actual->expr->ts.kind;
11150 316 : if (kind == 1)
11151 250 : fndecl = gfor_fndecl_string_scan;
11152 66 : else if (kind == 4)
11153 66 : fndecl = gfor_fndecl_string_scan_char4;
11154 : else
11155 0 : gcc_unreachable ();
11156 :
11157 316 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11158 316 : break;
11159 :
11160 94 : case GFC_ISYM_VERIFY:
11161 94 : kind = expr->value.function.actual->expr->ts.kind;
11162 94 : if (kind == 1)
11163 70 : fndecl = gfor_fndecl_string_verify;
11164 24 : else if (kind == 4)
11165 24 : fndecl = gfor_fndecl_string_verify_char4;
11166 : else
11167 0 : gcc_unreachable ();
11168 :
11169 94 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11170 94 : break;
11171 :
11172 7288 : case GFC_ISYM_ALLOCATED:
11173 7288 : gfc_conv_allocated (se, expr);
11174 7288 : break;
11175 :
11176 9343 : case GFC_ISYM_ASSOCIATED:
11177 9343 : gfc_conv_associated(se, expr);
11178 9343 : break;
11179 :
11180 409 : case GFC_ISYM_SAME_TYPE_AS:
11181 409 : gfc_conv_same_type_as (se, expr);
11182 409 : break;
11183 :
11184 7818 : case GFC_ISYM_ABS:
11185 7818 : gfc_conv_intrinsic_abs (se, expr);
11186 7818 : break;
11187 :
11188 351 : case GFC_ISYM_ADJUSTL:
11189 351 : if (expr->ts.kind == 1)
11190 297 : fndecl = gfor_fndecl_adjustl;
11191 54 : else if (expr->ts.kind == 4)
11192 54 : fndecl = gfor_fndecl_adjustl_char4;
11193 : else
11194 0 : gcc_unreachable ();
11195 :
11196 351 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11197 351 : break;
11198 :
11199 123 : case GFC_ISYM_ADJUSTR:
11200 123 : if (expr->ts.kind == 1)
11201 68 : fndecl = gfor_fndecl_adjustr;
11202 55 : else if (expr->ts.kind == 4)
11203 55 : fndecl = gfor_fndecl_adjustr_char4;
11204 : else
11205 0 : gcc_unreachable ();
11206 :
11207 123 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11208 123 : break;
11209 :
11210 428 : case GFC_ISYM_AIMAG:
11211 428 : gfc_conv_intrinsic_imagpart (se, expr);
11212 428 : break;
11213 :
11214 146 : case GFC_ISYM_AINT:
11215 146 : gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
11216 146 : break;
11217 :
11218 420 : case GFC_ISYM_ALL:
11219 420 : gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
11220 420 : break;
11221 :
11222 74 : case GFC_ISYM_ANINT:
11223 74 : gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
11224 74 : break;
11225 :
11226 90 : case GFC_ISYM_AND:
11227 90 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11228 90 : break;
11229 :
11230 37366 : case GFC_ISYM_ANY:
11231 37366 : gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
11232 37366 : break;
11233 :
11234 216 : case GFC_ISYM_ACOSD:
11235 216 : case GFC_ISYM_ASIND:
11236 216 : case GFC_ISYM_ATAND:
11237 216 : gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
11238 216 : break;
11239 :
11240 102 : case GFC_ISYM_COTAN:
11241 102 : gfc_conv_intrinsic_cotan (se, expr);
11242 102 : break;
11243 :
11244 108 : case GFC_ISYM_COTAND:
11245 108 : gfc_conv_intrinsic_cotand (se, expr);
11246 108 : break;
11247 :
11248 120 : case GFC_ISYM_ATAN2D:
11249 120 : gfc_conv_intrinsic_atan2d (se, expr);
11250 120 : break;
11251 :
11252 145 : case GFC_ISYM_BTEST:
11253 145 : gfc_conv_intrinsic_btest (se, expr);
11254 145 : break;
11255 :
11256 54 : case GFC_ISYM_BGE:
11257 54 : gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
11258 54 : break;
11259 :
11260 54 : case GFC_ISYM_BGT:
11261 54 : gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
11262 54 : break;
11263 :
11264 54 : case GFC_ISYM_BLE:
11265 54 : gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
11266 54 : break;
11267 :
11268 54 : case GFC_ISYM_BLT:
11269 54 : gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
11270 54 : break;
11271 :
11272 9481 : case GFC_ISYM_C_ASSOCIATED:
11273 9481 : case GFC_ISYM_C_FUNLOC:
11274 9481 : case GFC_ISYM_C_LOC:
11275 9481 : case GFC_ISYM_F_C_STRING:
11276 9481 : conv_isocbinding_function (se, expr);
11277 9481 : break;
11278 :
11279 2020 : case GFC_ISYM_ACHAR:
11280 2020 : case GFC_ISYM_CHAR:
11281 2020 : gfc_conv_intrinsic_char (se, expr);
11282 2020 : break;
11283 :
11284 39278 : case GFC_ISYM_CONVERSION:
11285 39278 : case GFC_ISYM_DBLE:
11286 39278 : case GFC_ISYM_DFLOAT:
11287 39278 : case GFC_ISYM_FLOAT:
11288 39278 : case GFC_ISYM_LOGICAL:
11289 39278 : case GFC_ISYM_REAL:
11290 39278 : case GFC_ISYM_REALPART:
11291 39278 : case GFC_ISYM_SNGL:
11292 39278 : gfc_conv_intrinsic_conversion (se, expr);
11293 39278 : break;
11294 :
11295 : /* Integer conversions are handled separately to make sure we get the
11296 : correct rounding mode. */
11297 2806 : case GFC_ISYM_INT:
11298 2806 : case GFC_ISYM_INT2:
11299 2806 : case GFC_ISYM_INT8:
11300 2806 : case GFC_ISYM_LONG:
11301 2806 : case GFC_ISYM_UINT:
11302 2806 : gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
11303 2806 : break;
11304 :
11305 162 : case GFC_ISYM_NINT:
11306 162 : gfc_conv_intrinsic_int (se, expr, RND_ROUND);
11307 162 : break;
11308 :
11309 16 : case GFC_ISYM_CEILING:
11310 16 : gfc_conv_intrinsic_int (se, expr, RND_CEIL);
11311 16 : break;
11312 :
11313 116 : case GFC_ISYM_FLOOR:
11314 116 : gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
11315 116 : break;
11316 :
11317 3133 : case GFC_ISYM_MOD:
11318 3133 : gfc_conv_intrinsic_mod (se, expr, 0);
11319 3133 : break;
11320 :
11321 440 : case GFC_ISYM_MODULO:
11322 440 : gfc_conv_intrinsic_mod (se, expr, 1);
11323 440 : break;
11324 :
11325 999 : case GFC_ISYM_CAF_GET:
11326 999 : gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL);
11327 999 : break;
11328 :
11329 167 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
11330 167 : gfc_conv_intrinsic_caf_is_present_remote (se, expr);
11331 167 : break;
11332 :
11333 485 : case GFC_ISYM_CMPLX:
11334 485 : gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
11335 485 : break;
11336 :
11337 10 : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
11338 10 : gfc_conv_intrinsic_iargc (se, expr);
11339 10 : break;
11340 :
11341 6 : case GFC_ISYM_COMPLEX:
11342 6 : gfc_conv_intrinsic_cmplx (se, expr, 1);
11343 6 : break;
11344 :
11345 257 : case GFC_ISYM_CONJG:
11346 257 : gfc_conv_intrinsic_conjg (se, expr);
11347 257 : break;
11348 :
11349 4 : case GFC_ISYM_COSHAPE:
11350 4 : conv_intrinsic_cobound (se, expr);
11351 4 : break;
11352 :
11353 143 : case GFC_ISYM_COUNT:
11354 143 : gfc_conv_intrinsic_count (se, expr);
11355 143 : break;
11356 :
11357 0 : case GFC_ISYM_CTIME:
11358 0 : gfc_conv_intrinsic_ctime (se, expr);
11359 0 : break;
11360 :
11361 96 : case GFC_ISYM_DIM:
11362 96 : gfc_conv_intrinsic_dim (se, expr);
11363 96 : break;
11364 :
11365 113 : case GFC_ISYM_DOT_PRODUCT:
11366 113 : gfc_conv_intrinsic_dot_product (se, expr);
11367 113 : break;
11368 :
11369 13 : case GFC_ISYM_DPROD:
11370 13 : gfc_conv_intrinsic_dprod (se, expr);
11371 13 : break;
11372 :
11373 66 : case GFC_ISYM_DSHIFTL:
11374 66 : gfc_conv_intrinsic_dshift (se, expr, true);
11375 66 : break;
11376 :
11377 66 : case GFC_ISYM_DSHIFTR:
11378 66 : gfc_conv_intrinsic_dshift (se, expr, false);
11379 66 : break;
11380 :
11381 0 : case GFC_ISYM_FDATE:
11382 0 : gfc_conv_intrinsic_fdate (se, expr);
11383 0 : break;
11384 :
11385 60 : case GFC_ISYM_FRACTION:
11386 60 : gfc_conv_intrinsic_fraction (se, expr);
11387 60 : break;
11388 :
11389 24 : case GFC_ISYM_IALL:
11390 24 : gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
11391 24 : break;
11392 :
11393 606 : case GFC_ISYM_IAND:
11394 606 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11395 606 : break;
11396 :
11397 12 : case GFC_ISYM_IANY:
11398 12 : gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
11399 12 : break;
11400 :
11401 168 : case GFC_ISYM_IBCLR:
11402 168 : gfc_conv_intrinsic_singlebitop (se, expr, 0);
11403 168 : break;
11404 :
11405 27 : case GFC_ISYM_IBITS:
11406 27 : gfc_conv_intrinsic_ibits (se, expr);
11407 27 : break;
11408 :
11409 138 : case GFC_ISYM_IBSET:
11410 138 : gfc_conv_intrinsic_singlebitop (se, expr, 1);
11411 138 : break;
11412 :
11413 2033 : case GFC_ISYM_IACHAR:
11414 2033 : case GFC_ISYM_ICHAR:
11415 : /* We assume ASCII character sequence. */
11416 2033 : gfc_conv_intrinsic_ichar (se, expr);
11417 2033 : break;
11418 :
11419 2 : case GFC_ISYM_IARGC:
11420 2 : gfc_conv_intrinsic_iargc (se, expr);
11421 2 : break;
11422 :
11423 694 : case GFC_ISYM_IEOR:
11424 694 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11425 694 : break;
11426 :
11427 341 : case GFC_ISYM_INDEX:
11428 341 : kind = expr->value.function.actual->expr->ts.kind;
11429 341 : if (kind == 1)
11430 275 : fndecl = gfor_fndecl_string_index;
11431 66 : else if (kind == 4)
11432 66 : fndecl = gfor_fndecl_string_index_char4;
11433 : else
11434 0 : gcc_unreachable ();
11435 :
11436 341 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11437 341 : break;
11438 :
11439 495 : case GFC_ISYM_IOR:
11440 495 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11441 495 : break;
11442 :
11443 12 : case GFC_ISYM_IPARITY:
11444 12 : gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
11445 12 : break;
11446 :
11447 6 : case GFC_ISYM_IS_IOSTAT_END:
11448 6 : gfc_conv_has_intvalue (se, expr, LIBERROR_END);
11449 6 : break;
11450 :
11451 18 : case GFC_ISYM_IS_IOSTAT_EOR:
11452 18 : gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
11453 18 : break;
11454 :
11455 735 : case GFC_ISYM_IS_CONTIGUOUS:
11456 735 : gfc_conv_intrinsic_is_contiguous (se, expr);
11457 735 : break;
11458 :
11459 432 : case GFC_ISYM_ISNAN:
11460 432 : gfc_conv_intrinsic_isnan (se, expr);
11461 432 : break;
11462 :
11463 8 : case GFC_ISYM_KILL:
11464 8 : conv_intrinsic_kill (se, expr);
11465 8 : break;
11466 :
11467 90 : case GFC_ISYM_LSHIFT:
11468 90 : gfc_conv_intrinsic_shift (se, expr, false, false);
11469 90 : break;
11470 :
11471 24 : case GFC_ISYM_RSHIFT:
11472 24 : gfc_conv_intrinsic_shift (se, expr, true, true);
11473 24 : break;
11474 :
11475 78 : case GFC_ISYM_SHIFTA:
11476 78 : gfc_conv_intrinsic_shift (se, expr, true, true);
11477 78 : break;
11478 :
11479 234 : case GFC_ISYM_SHIFTL:
11480 234 : gfc_conv_intrinsic_shift (se, expr, false, false);
11481 234 : break;
11482 :
11483 66 : case GFC_ISYM_SHIFTR:
11484 66 : gfc_conv_intrinsic_shift (se, expr, true, false);
11485 66 : break;
11486 :
11487 318 : case GFC_ISYM_ISHFT:
11488 318 : gfc_conv_intrinsic_ishft (se, expr);
11489 318 : break;
11490 :
11491 658 : case GFC_ISYM_ISHFTC:
11492 658 : gfc_conv_intrinsic_ishftc (se, expr);
11493 658 : break;
11494 :
11495 270 : case GFC_ISYM_LEADZ:
11496 270 : gfc_conv_intrinsic_leadz (se, expr);
11497 270 : break;
11498 :
11499 282 : case GFC_ISYM_TRAILZ:
11500 282 : gfc_conv_intrinsic_trailz (se, expr);
11501 282 : break;
11502 :
11503 103 : case GFC_ISYM_POPCNT:
11504 103 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
11505 103 : break;
11506 :
11507 31 : case GFC_ISYM_POPPAR:
11508 31 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
11509 31 : break;
11510 :
11511 5503 : case GFC_ISYM_LBOUND:
11512 5503 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
11513 5503 : break;
11514 :
11515 210 : case GFC_ISYM_LCOBOUND:
11516 210 : conv_intrinsic_cobound (se, expr);
11517 210 : break;
11518 :
11519 744 : case GFC_ISYM_TRANSPOSE:
11520 : /* The scalarizer has already been set up for reversed dimension access
11521 : order ; now we just get the argument value normally. */
11522 744 : gfc_conv_expr (se, expr->value.function.actual->expr);
11523 744 : break;
11524 :
11525 5765 : case GFC_ISYM_LEN:
11526 5765 : gfc_conv_intrinsic_len (se, expr);
11527 5765 : break;
11528 :
11529 2333 : case GFC_ISYM_LEN_TRIM:
11530 2333 : gfc_conv_intrinsic_len_trim (se, expr);
11531 2333 : break;
11532 :
11533 18 : case GFC_ISYM_LGE:
11534 18 : gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
11535 18 : break;
11536 :
11537 36 : case GFC_ISYM_LGT:
11538 36 : gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
11539 36 : break;
11540 :
11541 18 : case GFC_ISYM_LLE:
11542 18 : gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
11543 18 : break;
11544 :
11545 27 : case GFC_ISYM_LLT:
11546 27 : gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
11547 27 : break;
11548 :
11549 16 : case GFC_ISYM_MALLOC:
11550 16 : gfc_conv_intrinsic_malloc (se, expr);
11551 16 : break;
11552 :
11553 32 : case GFC_ISYM_MASKL:
11554 32 : gfc_conv_intrinsic_mask (se, expr, 1);
11555 32 : break;
11556 :
11557 32 : case GFC_ISYM_MASKR:
11558 32 : gfc_conv_intrinsic_mask (se, expr, 0);
11559 32 : break;
11560 :
11561 1049 : case GFC_ISYM_MAX:
11562 1049 : if (expr->ts.type == BT_CHARACTER)
11563 138 : gfc_conv_intrinsic_minmax_char (se, expr, 1);
11564 : else
11565 911 : gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
11566 : break;
11567 :
11568 6348 : case GFC_ISYM_MAXLOC:
11569 6348 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11570 6348 : break;
11571 :
11572 216 : case GFC_ISYM_FINDLOC:
11573 216 : gfc_conv_intrinsic_findloc (se, expr);
11574 216 : break;
11575 :
11576 1101 : case GFC_ISYM_MAXVAL:
11577 1101 : gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
11578 1101 : break;
11579 :
11580 949 : case GFC_ISYM_MERGE:
11581 949 : gfc_conv_intrinsic_merge (se, expr);
11582 949 : break;
11583 :
11584 42 : case GFC_ISYM_MERGE_BITS:
11585 42 : gfc_conv_intrinsic_merge_bits (se, expr);
11586 42 : break;
11587 :
11588 597 : case GFC_ISYM_MIN:
11589 597 : if (expr->ts.type == BT_CHARACTER)
11590 144 : gfc_conv_intrinsic_minmax_char (se, expr, -1);
11591 : else
11592 453 : gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
11593 : break;
11594 :
11595 7176 : case GFC_ISYM_MINLOC:
11596 7176 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11597 7176 : break;
11598 :
11599 1316 : case GFC_ISYM_MINVAL:
11600 1316 : gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
11601 1316 : break;
11602 :
11603 1595 : case GFC_ISYM_NEAREST:
11604 1595 : gfc_conv_intrinsic_nearest (se, expr);
11605 1595 : break;
11606 :
11607 68 : case GFC_ISYM_NORM2:
11608 68 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
11609 68 : break;
11610 :
11611 230 : case GFC_ISYM_NOT:
11612 230 : gfc_conv_intrinsic_not (se, expr);
11613 230 : break;
11614 :
11615 12 : case GFC_ISYM_OR:
11616 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11617 12 : break;
11618 :
11619 468 : case GFC_ISYM_OUT_OF_RANGE:
11620 468 : gfc_conv_intrinsic_out_of_range (se, expr);
11621 468 : break;
11622 :
11623 36 : case GFC_ISYM_PARITY:
11624 36 : gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
11625 36 : break;
11626 :
11627 5070 : case GFC_ISYM_PRESENT:
11628 5070 : gfc_conv_intrinsic_present (se, expr);
11629 5070 : break;
11630 :
11631 346 : case GFC_ISYM_PRODUCT:
11632 346 : gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
11633 346 : break;
11634 :
11635 12136 : case GFC_ISYM_RANK:
11636 12136 : gfc_conv_intrinsic_rank (se, expr);
11637 12136 : break;
11638 :
11639 48 : case GFC_ISYM_RRSPACING:
11640 48 : gfc_conv_intrinsic_rrspacing (se, expr);
11641 48 : break;
11642 :
11643 262 : case GFC_ISYM_SET_EXPONENT:
11644 262 : gfc_conv_intrinsic_set_exponent (se, expr);
11645 262 : break;
11646 :
11647 72 : case GFC_ISYM_SCALE:
11648 72 : gfc_conv_intrinsic_scale (se, expr);
11649 72 : break;
11650 :
11651 4826 : case GFC_ISYM_SHAPE:
11652 4826 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
11653 4826 : break;
11654 :
11655 423 : case GFC_ISYM_SIGN:
11656 423 : gfc_conv_intrinsic_sign (se, expr);
11657 423 : break;
11658 :
11659 15020 : case GFC_ISYM_SIZE:
11660 15020 : gfc_conv_intrinsic_size (se, expr);
11661 15020 : break;
11662 :
11663 1309 : case GFC_ISYM_SIZEOF:
11664 1309 : case GFC_ISYM_C_SIZEOF:
11665 1309 : gfc_conv_intrinsic_sizeof (se, expr);
11666 1309 : break;
11667 :
11668 834 : case GFC_ISYM_STORAGE_SIZE:
11669 834 : gfc_conv_intrinsic_storage_size (se, expr);
11670 834 : break;
11671 :
11672 70 : case GFC_ISYM_SPACING:
11673 70 : gfc_conv_intrinsic_spacing (se, expr);
11674 70 : break;
11675 :
11676 2193 : case GFC_ISYM_STRIDE:
11677 2193 : conv_intrinsic_stride (se, expr);
11678 2193 : break;
11679 :
11680 2003 : case GFC_ISYM_SUM:
11681 2003 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
11682 2003 : break;
11683 :
11684 21 : case GFC_ISYM_TEAM_NUMBER:
11685 21 : conv_intrinsic_team_number (se, expr);
11686 21 : break;
11687 :
11688 3954 : case GFC_ISYM_TRANSFER:
11689 3954 : if (se->ss && se->ss->info->useflags)
11690 : /* Access the previously obtained result. */
11691 281 : gfc_conv_tmp_array_ref (se);
11692 : else
11693 3673 : gfc_conv_intrinsic_transfer (se, expr);
11694 : break;
11695 :
11696 0 : case GFC_ISYM_TTYNAM:
11697 0 : gfc_conv_intrinsic_ttynam (se, expr);
11698 0 : break;
11699 :
11700 5687 : case GFC_ISYM_UBOUND:
11701 5687 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
11702 5687 : break;
11703 :
11704 244 : case GFC_ISYM_UCOBOUND:
11705 244 : conv_intrinsic_cobound (se, expr);
11706 244 : break;
11707 :
11708 18 : case GFC_ISYM_XOR:
11709 18 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11710 18 : break;
11711 :
11712 8786 : case GFC_ISYM_LOC:
11713 8786 : gfc_conv_intrinsic_loc (se, expr);
11714 8786 : break;
11715 :
11716 1499 : case GFC_ISYM_THIS_IMAGE:
11717 : /* For num_images() == 1, handle as LCOBOUND. */
11718 1499 : if (expr->value.function.actual->expr
11719 526 : && flag_coarray == GFC_FCOARRAY_SINGLE)
11720 208 : conv_intrinsic_cobound (se, expr);
11721 : else
11722 1291 : trans_this_image (se, expr);
11723 : break;
11724 :
11725 193 : case GFC_ISYM_IMAGE_INDEX:
11726 193 : trans_image_index (se, expr);
11727 193 : break;
11728 :
11729 25 : case GFC_ISYM_IMAGE_STATUS:
11730 25 : conv_intrinsic_image_status (se, expr);
11731 25 : break;
11732 :
11733 806 : case GFC_ISYM_NUM_IMAGES:
11734 806 : trans_num_images (se, expr);
11735 806 : break;
11736 :
11737 1374 : case GFC_ISYM_ACCESS:
11738 1374 : case GFC_ISYM_CHDIR:
11739 1374 : case GFC_ISYM_CHMOD:
11740 1374 : case GFC_ISYM_DTIME:
11741 1374 : case GFC_ISYM_ETIME:
11742 1374 : case GFC_ISYM_EXTENDS_TYPE_OF:
11743 1374 : case GFC_ISYM_FGET:
11744 1374 : case GFC_ISYM_FGETC:
11745 1374 : case GFC_ISYM_FNUM:
11746 1374 : case GFC_ISYM_FPUT:
11747 1374 : case GFC_ISYM_FPUTC:
11748 1374 : case GFC_ISYM_FSTAT:
11749 1374 : case GFC_ISYM_FTELL:
11750 1374 : case GFC_ISYM_GETCWD:
11751 1374 : case GFC_ISYM_GETGID:
11752 1374 : case GFC_ISYM_GETPID:
11753 1374 : case GFC_ISYM_GETUID:
11754 1374 : case GFC_ISYM_GET_TEAM:
11755 1374 : case GFC_ISYM_HOSTNM:
11756 1374 : case GFC_ISYM_IERRNO:
11757 1374 : case GFC_ISYM_IRAND:
11758 1374 : case GFC_ISYM_ISATTY:
11759 1374 : case GFC_ISYM_JN2:
11760 1374 : case GFC_ISYM_LINK:
11761 1374 : case GFC_ISYM_LSTAT:
11762 1374 : case GFC_ISYM_MATMUL:
11763 1374 : case GFC_ISYM_MCLOCK:
11764 1374 : case GFC_ISYM_MCLOCK8:
11765 1374 : case GFC_ISYM_RAND:
11766 1374 : case GFC_ISYM_REDUCE:
11767 1374 : case GFC_ISYM_RENAME:
11768 1374 : case GFC_ISYM_SECOND:
11769 1374 : case GFC_ISYM_SECNDS:
11770 1374 : case GFC_ISYM_SIGNAL:
11771 1374 : case GFC_ISYM_STAT:
11772 1374 : case GFC_ISYM_SYMLNK:
11773 1374 : case GFC_ISYM_SYSTEM:
11774 1374 : case GFC_ISYM_TIME:
11775 1374 : case GFC_ISYM_TIME8:
11776 1374 : case GFC_ISYM_UMASK:
11777 1374 : case GFC_ISYM_UNLINK:
11778 1374 : case GFC_ISYM_YN2:
11779 1374 : gfc_conv_intrinsic_funcall (se, expr);
11780 1374 : break;
11781 :
11782 0 : case GFC_ISYM_EOSHIFT:
11783 0 : case GFC_ISYM_PACK:
11784 0 : case GFC_ISYM_RESHAPE:
11785 : /* For those, expr->rank should always be >0 and thus the if above the
11786 : switch should have matched. */
11787 0 : gcc_unreachable ();
11788 3854 : break;
11789 :
11790 3854 : default:
11791 3854 : gfc_conv_intrinsic_lib_function (se, expr);
11792 3854 : break;
11793 : }
11794 : }
11795 :
11796 :
11797 : static gfc_ss *
11798 1560 : walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11799 : {
11800 1560 : gfc_ss *arg_ss, *tmp_ss;
11801 1560 : gfc_actual_arglist *arg;
11802 :
11803 1560 : arg = expr->value.function.actual;
11804 :
11805 1560 : gcc_assert (arg->expr);
11806 :
11807 1560 : arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11808 1560 : gcc_assert (arg_ss != gfc_ss_terminator);
11809 :
11810 : for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11811 : {
11812 1665 : if (tmp_ss->info->type != GFC_SS_SCALAR
11813 : && tmp_ss->info->type != GFC_SS_REFERENCE)
11814 : {
11815 1628 : gcc_assert (tmp_ss->dimen == 2);
11816 :
11817 : /* We just invert dimensions. */
11818 1628 : std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
11819 : }
11820 :
11821 : /* Stop when tmp_ss points to the last valid element of the chain... */
11822 1665 : if (tmp_ss->next == gfc_ss_terminator)
11823 : break;
11824 : }
11825 :
11826 : /* ... so that we can attach the rest of the chain to it. */
11827 1560 : tmp_ss->next = ss;
11828 :
11829 1560 : return arg_ss;
11830 : }
11831 :
11832 :
11833 : /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11834 : This has the side effect of reversing the nested list, so there is no
11835 : need to call gfc_reverse_ss on it (the given list is assumed not to be
11836 : reversed yet). */
11837 :
11838 : static gfc_ss *
11839 3371 : nest_loop_dimension (gfc_ss *ss, int dim)
11840 : {
11841 3371 : int ss_dim, i;
11842 3371 : gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11843 3371 : gfc_loopinfo *new_loop;
11844 :
11845 3371 : gcc_assert (ss != gfc_ss_terminator);
11846 :
11847 8118 : for (; ss != gfc_ss_terminator; ss = ss->next)
11848 : {
11849 4747 : new_ss = gfc_get_ss ();
11850 4747 : new_ss->next = prev_ss;
11851 4747 : new_ss->parent = ss;
11852 4747 : new_ss->info = ss->info;
11853 4747 : new_ss->info->refcount++;
11854 4747 : if (ss->dimen != 0)
11855 : {
11856 4684 : gcc_assert (ss->info->type != GFC_SS_SCALAR
11857 : && ss->info->type != GFC_SS_REFERENCE);
11858 :
11859 4684 : new_ss->dimen = 1;
11860 4684 : new_ss->dim[0] = ss->dim[dim];
11861 :
11862 4684 : gcc_assert (dim < ss->dimen);
11863 :
11864 4684 : ss_dim = --ss->dimen;
11865 10430 : for (i = dim; i < ss_dim; i++)
11866 5746 : ss->dim[i] = ss->dim[i + 1];
11867 :
11868 4684 : ss->dim[ss_dim] = 0;
11869 : }
11870 4747 : prev_ss = new_ss;
11871 :
11872 4747 : if (ss->nested_ss)
11873 : {
11874 81 : ss->nested_ss->parent = new_ss;
11875 81 : new_ss->nested_ss = ss->nested_ss;
11876 : }
11877 4747 : ss->nested_ss = new_ss;
11878 : }
11879 :
11880 3371 : new_loop = gfc_get_loopinfo ();
11881 3371 : gfc_init_loopinfo (new_loop);
11882 :
11883 3371 : gcc_assert (prev_ss != NULL);
11884 3371 : gcc_assert (prev_ss != gfc_ss_terminator);
11885 3371 : gfc_add_ss_to_loop (new_loop, prev_ss);
11886 3371 : return new_ss->parent;
11887 : }
11888 :
11889 :
11890 : /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
11891 : is to be inlined. */
11892 :
11893 : static gfc_ss *
11894 575 : walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
11895 : {
11896 575 : gfc_ss *tmp_ss, *tail, *array_ss;
11897 575 : gfc_actual_arglist *arg1, *arg2, *arg3;
11898 575 : int sum_dim;
11899 575 : bool scalar_mask = false;
11900 :
11901 : /* The rank of the result will be determined later. */
11902 575 : arg1 = expr->value.function.actual;
11903 575 : arg2 = arg1->next;
11904 575 : arg3 = arg2->next;
11905 575 : gcc_assert (arg3 != NULL);
11906 :
11907 575 : if (expr->rank == 0)
11908 : return ss;
11909 :
11910 575 : tmp_ss = gfc_ss_terminator;
11911 :
11912 575 : if (arg3->expr)
11913 : {
11914 118 : gfc_ss *mask_ss;
11915 :
11916 118 : mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
11917 118 : if (mask_ss == tmp_ss)
11918 34 : scalar_mask = 1;
11919 :
11920 : tmp_ss = mask_ss;
11921 : }
11922 :
11923 575 : array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
11924 575 : gcc_assert (array_ss != tmp_ss);
11925 :
11926 : /* Odd thing: If the mask is scalar, it is used by the frontend after
11927 : the array (to make an if around the nested loop). Thus it shall
11928 : be after array_ss once the gfc_ss list is reversed. */
11929 575 : if (scalar_mask)
11930 34 : tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
11931 : else
11932 : tmp_ss = array_ss;
11933 :
11934 : /* "Hide" the dimension on which we will sum in the first arg's scalarization
11935 : chain. */
11936 575 : sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
11937 575 : tail = nest_loop_dimension (tmp_ss, sum_dim);
11938 575 : tail->next = ss;
11939 :
11940 575 : return tmp_ss;
11941 : }
11942 :
11943 :
11944 : /* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the
11945 : function is to be inlined. */
11946 :
11947 : static gfc_ss *
11948 6085 : walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
11949 : {
11950 6085 : if (expr->rank == 0)
11951 : return ss;
11952 :
11953 6085 : gfc_actual_arglist *array_arg = expr->value.function.actual;
11954 6085 : gfc_actual_arglist *dim_arg = array_arg->next;
11955 6085 : gfc_actual_arglist *mask_arg = dim_arg->next;
11956 6085 : gfc_actual_arglist *kind_arg = mask_arg->next;
11957 6085 : gfc_actual_arglist *back_arg = kind_arg->next;
11958 :
11959 6085 : gfc_expr *array = array_arg->expr;
11960 6085 : gfc_expr *dim = dim_arg->expr;
11961 6085 : gfc_expr *mask = mask_arg->expr;
11962 6085 : gfc_expr *back = back_arg->expr;
11963 :
11964 6085 : if (dim == nullptr)
11965 3289 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
11966 :
11967 2796 : gfc_ss *tmp_ss = gfc_ss_terminator;
11968 :
11969 2796 : bool scalar_mask = false;
11970 2796 : if (mask)
11971 : {
11972 1866 : gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
11973 1866 : if (mask_ss == tmp_ss)
11974 : scalar_mask = true;
11975 1174 : else if (maybe_absent_optional_variable (mask))
11976 20 : mask_ss->info->can_be_null_ref = true;
11977 :
11978 : tmp_ss = mask_ss;
11979 : }
11980 :
11981 2796 : gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
11982 2796 : gcc_assert (array_ss != tmp_ss);
11983 :
11984 2796 : tmp_ss = array_ss;
11985 :
11986 : /* Move the dimension on which we will sum to a separate nested scalarization
11987 : chain, "hiding" that dimension from the outer scalarization. */
11988 2796 : int dim_val = mpz_get_si (dim->value.integer);
11989 2796 : gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
11990 :
11991 2796 : if (back && array->rank > 1)
11992 : {
11993 : /* If there are nested scalarization loops, include BACK in the
11994 : scalarization chains to avoid evaluating it multiple times in a loop.
11995 : Otherwise, prefer to handle it outside of scalarization. */
11996 2796 : gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
11997 2796 : back_ss->info->type = GFC_SS_REFERENCE;
11998 2796 : if (maybe_absent_optional_variable (back))
11999 16 : back_ss->info->can_be_null_ref = true;
12000 :
12001 2796 : tail->next = back_ss;
12002 2796 : }
12003 : else
12004 0 : tail->next = ss;
12005 :
12006 2796 : if (scalar_mask)
12007 : {
12008 692 : tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
12009 : /* MASK can be a forwarded optional argument, so make the necessary setup
12010 : to avoid the scalarizer generating any unguarded pointer dereference in
12011 : that case. */
12012 692 : tmp_ss->info->type = GFC_SS_REFERENCE;
12013 692 : if (maybe_absent_optional_variable (mask))
12014 4 : tmp_ss->info->can_be_null_ref = true;
12015 : }
12016 :
12017 : return tmp_ss;
12018 : }
12019 :
12020 :
12021 : static gfc_ss *
12022 8220 : walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
12023 : {
12024 :
12025 8220 : switch (expr->value.function.isym->id)
12026 : {
12027 575 : case GFC_ISYM_PRODUCT:
12028 575 : case GFC_ISYM_SUM:
12029 575 : return walk_inline_intrinsic_arith (ss, expr);
12030 :
12031 1560 : case GFC_ISYM_TRANSPOSE:
12032 1560 : return walk_inline_intrinsic_transpose (ss, expr);
12033 :
12034 6085 : case GFC_ISYM_MAXLOC:
12035 6085 : case GFC_ISYM_MINLOC:
12036 6085 : return walk_inline_intrinsic_minmaxloc (ss, expr);
12037 :
12038 0 : default:
12039 0 : gcc_unreachable ();
12040 : }
12041 : gcc_unreachable ();
12042 : }
12043 :
12044 :
12045 : /* This generates code to execute before entering the scalarization loop.
12046 : Currently does nothing. */
12047 :
12048 : void
12049 11419 : gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
12050 : {
12051 11419 : switch (ss->info->expr->value.function.isym->id)
12052 : {
12053 11419 : case GFC_ISYM_UBOUND:
12054 11419 : case GFC_ISYM_LBOUND:
12055 11419 : case GFC_ISYM_COSHAPE:
12056 11419 : case GFC_ISYM_UCOBOUND:
12057 11419 : case GFC_ISYM_LCOBOUND:
12058 11419 : case GFC_ISYM_MAXLOC:
12059 11419 : case GFC_ISYM_MINLOC:
12060 11419 : case GFC_ISYM_THIS_IMAGE:
12061 11419 : case GFC_ISYM_SHAPE:
12062 11419 : break;
12063 :
12064 0 : default:
12065 0 : gcc_unreachable ();
12066 : }
12067 11419 : }
12068 :
12069 :
12070 : /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
12071 : one parameter are expanded into code inside the scalarization loop. */
12072 :
12073 : static gfc_ss *
12074 9975 : gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
12075 : {
12076 9975 : if (expr->value.function.actual->expr->ts.type == BT_CLASS)
12077 438 : gfc_add_class_array_ref (expr->value.function.actual->expr);
12078 :
12079 : /* The two argument version returns a scalar. */
12080 9975 : if (expr->value.function.isym->id != GFC_ISYM_SHAPE
12081 3522 : && expr->value.function.isym->id != GFC_ISYM_COSHAPE
12082 3518 : && expr->value.function.actual->next->expr)
12083 : return ss;
12084 :
12085 9975 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12086 : }
12087 :
12088 :
12089 : /* Walk an intrinsic array libcall. */
12090 :
12091 : static gfc_ss *
12092 14377 : gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
12093 : {
12094 14377 : gcc_assert (expr->rank > 0);
12095 14377 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12096 : }
12097 :
12098 :
12099 : /* Return whether the function call expression EXPR will be expanded
12100 : inline by gfc_conv_intrinsic_function. */
12101 :
12102 : bool
12103 298384 : gfc_inline_intrinsic_function_p (gfc_expr *expr)
12104 : {
12105 298384 : gfc_actual_arglist *args, *dim_arg, *mask_arg;
12106 298384 : gfc_expr *maskexpr;
12107 :
12108 298384 : gfc_intrinsic_sym *isym = expr->value.function.isym;
12109 298384 : if (!isym)
12110 : return false;
12111 :
12112 298342 : switch (isym->id)
12113 : {
12114 5104 : case GFC_ISYM_PRODUCT:
12115 5104 : case GFC_ISYM_SUM:
12116 : /* Disable inline expansion if code size matters. */
12117 5104 : if (optimize_size)
12118 : return false;
12119 :
12120 4249 : args = expr->value.function.actual;
12121 4249 : dim_arg = args->next;
12122 :
12123 : /* We need to be able to subset the SUM argument at compile-time. */
12124 4249 : if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
12125 : return false;
12126 :
12127 : /* FIXME: If MASK is optional for a more than two-dimensional
12128 : argument, the scalarizer gets confused if the mask is
12129 : absent. See PR 82995. For now, fall back to the library
12130 : function. */
12131 :
12132 3637 : mask_arg = dim_arg->next;
12133 3637 : maskexpr = mask_arg->expr;
12134 :
12135 3637 : if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
12136 276 : && maskexpr->symtree->n.sym->attr.dummy
12137 48 : && maskexpr->symtree->n.sym->attr.optional)
12138 : return false;
12139 :
12140 : return true;
12141 :
12142 : case GFC_ISYM_TRANSPOSE:
12143 : return true;
12144 :
12145 57188 : case GFC_ISYM_MINLOC:
12146 57188 : case GFC_ISYM_MAXLOC:
12147 57188 : {
12148 57188 : if ((isym->id == GFC_ISYM_MINLOC
12149 30521 : && (flag_inline_intrinsics
12150 30521 : & GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0)
12151 46611 : || (isym->id == GFC_ISYM_MAXLOC
12152 26667 : && (flag_inline_intrinsics
12153 26667 : & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0))
12154 : return false;
12155 :
12156 37638 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12157 37638 : gfc_actual_arglist *dim_arg = array_arg->next;
12158 :
12159 37638 : gfc_expr *array = array_arg->expr;
12160 37638 : gfc_expr *dim = dim_arg->expr;
12161 :
12162 37638 : if (!(array->ts.type == BT_INTEGER
12163 : || array->ts.type == BT_REAL))
12164 : return false;
12165 :
12166 34658 : if (array->rank == 1)
12167 : return true;
12168 :
12169 20711 : if (dim != nullptr
12170 13372 : && dim->expr_type != EXPR_CONSTANT)
12171 : return false;
12172 :
12173 : return true;
12174 : }
12175 :
12176 : default:
12177 : return false;
12178 : }
12179 : }
12180 :
12181 :
12182 : /* Returns nonzero if the specified intrinsic function call maps directly to
12183 : an external library call. Should only be used for functions that return
12184 : arrays. */
12185 :
12186 : int
12187 87235 : gfc_is_intrinsic_libcall (gfc_expr * expr)
12188 : {
12189 87235 : gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
12190 87235 : gcc_assert (expr->rank > 0);
12191 :
12192 87235 : if (gfc_inline_intrinsic_function_p (expr))
12193 : return 0;
12194 :
12195 72653 : switch (expr->value.function.isym->id)
12196 : {
12197 : case GFC_ISYM_ALL:
12198 : case GFC_ISYM_ANY:
12199 : case GFC_ISYM_COUNT:
12200 : case GFC_ISYM_FINDLOC:
12201 : case GFC_ISYM_JN2:
12202 : case GFC_ISYM_IANY:
12203 : case GFC_ISYM_IALL:
12204 : case GFC_ISYM_IPARITY:
12205 : case GFC_ISYM_MATMUL:
12206 : case GFC_ISYM_MAXLOC:
12207 : case GFC_ISYM_MAXVAL:
12208 : case GFC_ISYM_MINLOC:
12209 : case GFC_ISYM_MINVAL:
12210 : case GFC_ISYM_NORM2:
12211 : case GFC_ISYM_PARITY:
12212 : case GFC_ISYM_PRODUCT:
12213 : case GFC_ISYM_SUM:
12214 : case GFC_ISYM_SPREAD:
12215 : case GFC_ISYM_YN2:
12216 : /* Ignore absent optional parameters. */
12217 : return 1;
12218 :
12219 15753 : case GFC_ISYM_CSHIFT:
12220 15753 : case GFC_ISYM_EOSHIFT:
12221 15753 : case GFC_ISYM_GET_TEAM:
12222 15753 : case GFC_ISYM_FAILED_IMAGES:
12223 15753 : case GFC_ISYM_STOPPED_IMAGES:
12224 15753 : case GFC_ISYM_PACK:
12225 15753 : case GFC_ISYM_REDUCE:
12226 15753 : case GFC_ISYM_RESHAPE:
12227 15753 : case GFC_ISYM_UNPACK:
12228 : /* Pass absent optional parameters. */
12229 15753 : return 2;
12230 :
12231 : default:
12232 : return 0;
12233 : }
12234 : }
12235 :
12236 : /* Walk an intrinsic function. */
12237 : gfc_ss *
12238 55219 : gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
12239 : gfc_intrinsic_sym * isym)
12240 : {
12241 55219 : gcc_assert (isym);
12242 :
12243 55219 : if (isym->elemental)
12244 18195 : return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
12245 : expr->value.function.isym,
12246 18195 : GFC_SS_SCALAR);
12247 :
12248 37024 : if (expr->rank == 0 && expr->corank == 0)
12249 : return ss;
12250 :
12251 32572 : if (gfc_inline_intrinsic_function_p (expr))
12252 8220 : return walk_inline_intrinsic_function (ss, expr);
12253 :
12254 24352 : if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
12255 13394 : return gfc_walk_intrinsic_libfunc (ss, expr);
12256 :
12257 : /* Special cases. */
12258 10958 : switch (isym->id)
12259 : {
12260 9975 : case GFC_ISYM_COSHAPE:
12261 9975 : case GFC_ISYM_LBOUND:
12262 9975 : case GFC_ISYM_LCOBOUND:
12263 9975 : case GFC_ISYM_UBOUND:
12264 9975 : case GFC_ISYM_UCOBOUND:
12265 9975 : case GFC_ISYM_THIS_IMAGE:
12266 9975 : case GFC_ISYM_SHAPE:
12267 9975 : return gfc_walk_intrinsic_bound (ss, expr);
12268 :
12269 983 : case GFC_ISYM_TRANSFER:
12270 983 : case GFC_ISYM_CAF_GET:
12271 983 : return gfc_walk_intrinsic_libfunc (ss, expr);
12272 :
12273 0 : default:
12274 : /* This probably meant someone forgot to add an intrinsic to the above
12275 : list(s) when they implemented it, or something's gone horribly
12276 : wrong. */
12277 0 : gcc_unreachable ();
12278 : }
12279 : }
12280 :
12281 : static tree
12282 88 : conv_co_collective (gfc_code *code)
12283 : {
12284 88 : gfc_se argse;
12285 88 : stmtblock_t block, post_block;
12286 88 : tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
12287 88 : gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
12288 :
12289 88 : gfc_start_block (&block);
12290 88 : gfc_init_block (&post_block);
12291 :
12292 88 : if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
12293 : {
12294 17 : opr_expr = code->ext.actual->next->expr;
12295 17 : image_idx_expr = code->ext.actual->next->next->expr;
12296 17 : stat_expr = code->ext.actual->next->next->next->expr;
12297 17 : errmsg_expr = code->ext.actual->next->next->next->next->expr;
12298 : }
12299 : else
12300 : {
12301 71 : opr_expr = NULL;
12302 71 : image_idx_expr = code->ext.actual->next->expr;
12303 71 : stat_expr = code->ext.actual->next->next->expr;
12304 71 : errmsg_expr = code->ext.actual->next->next->next->expr;
12305 : }
12306 :
12307 : /* stat. */
12308 88 : if (stat_expr)
12309 : {
12310 59 : gfc_init_se (&argse, NULL);
12311 59 : gfc_conv_expr (&argse, stat_expr);
12312 59 : gfc_add_block_to_block (&block, &argse.pre);
12313 59 : gfc_add_block_to_block (&post_block, &argse.post);
12314 59 : stat = argse.expr;
12315 59 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
12316 32 : stat = gfc_build_addr_expr (NULL_TREE, stat);
12317 : }
12318 29 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
12319 : stat = NULL_TREE;
12320 : else
12321 20 : stat = null_pointer_node;
12322 :
12323 : /* Early exit for GFC_FCOARRAY_SINGLE. */
12324 88 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
12325 : {
12326 36 : if (stat != NULL_TREE)
12327 : {
12328 : /* For optional stats, check the pointer is valid before zero'ing. */
12329 27 : if (gfc_expr_attr (stat_expr).optional)
12330 : {
12331 12 : tree tmp;
12332 12 : stmtblock_t ass_block;
12333 12 : gfc_start_block (&ass_block);
12334 12 : gfc_add_modify (&ass_block, stat,
12335 12 : fold_convert (TREE_TYPE (stat),
12336 : integer_zero_node));
12337 12 : tmp = fold_build2 (NE_EXPR, logical_type_node,
12338 : gfc_build_addr_expr (NULL_TREE, stat),
12339 : null_pointer_node);
12340 12 : tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
12341 : gfc_finish_block (&ass_block),
12342 : build_empty_stmt (input_location));
12343 12 : gfc_add_expr_to_block (&block, tmp);
12344 : }
12345 : else
12346 15 : gfc_add_modify (&block, stat,
12347 15 : fold_convert (TREE_TYPE (stat), integer_zero_node));
12348 : }
12349 36 : return gfc_finish_block (&block);
12350 : }
12351 :
12352 5 : gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
12353 52 : ? code->ext.actual->expr->ts.u.derived : NULL;
12354 :
12355 : /* Handle the array. */
12356 52 : gfc_init_se (&argse, NULL);
12357 52 : if (!derived || !derived->attr.alloc_comp
12358 1 : || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
12359 : {
12360 51 : if (code->ext.actual->expr->rank == 0)
12361 : {
12362 22 : symbol_attribute attr;
12363 22 : gfc_clear_attr (&attr);
12364 22 : gfc_init_se (&argse, NULL);
12365 22 : gfc_conv_expr (&argse, code->ext.actual->expr);
12366 22 : gfc_add_block_to_block (&block, &argse.pre);
12367 22 : gfc_add_block_to_block (&post_block, &argse.post);
12368 22 : array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
12369 22 : array = gfc_build_addr_expr (NULL_TREE, array);
12370 : }
12371 : else
12372 : {
12373 29 : argse.want_pointer = 1;
12374 29 : gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
12375 29 : array = argse.expr;
12376 : }
12377 : }
12378 :
12379 52 : gfc_add_block_to_block (&block, &argse.pre);
12380 52 : gfc_add_block_to_block (&post_block, &argse.post);
12381 :
12382 52 : if (code->ext.actual->expr->ts.type == BT_CHARACTER)
12383 15 : strlen = argse.string_length;
12384 : else
12385 37 : strlen = integer_zero_node;
12386 :
12387 : /* image_index. */
12388 52 : if (image_idx_expr)
12389 : {
12390 35 : gfc_init_se (&argse, NULL);
12391 35 : gfc_conv_expr (&argse, image_idx_expr);
12392 35 : gfc_add_block_to_block (&block, &argse.pre);
12393 35 : gfc_add_block_to_block (&post_block, &argse.post);
12394 35 : image_index = fold_convert (integer_type_node, argse.expr);
12395 : }
12396 : else
12397 17 : image_index = integer_zero_node;
12398 :
12399 : /* errmsg. */
12400 52 : if (errmsg_expr)
12401 : {
12402 25 : gfc_init_se (&argse, NULL);
12403 25 : gfc_conv_expr (&argse, errmsg_expr);
12404 25 : gfc_add_block_to_block (&block, &argse.pre);
12405 25 : gfc_add_block_to_block (&post_block, &argse.post);
12406 25 : errmsg = argse.expr;
12407 25 : errmsg_len = fold_convert (size_type_node, argse.string_length);
12408 : }
12409 : else
12410 : {
12411 27 : errmsg = null_pointer_node;
12412 27 : errmsg_len = build_zero_cst (size_type_node);
12413 : }
12414 :
12415 : /* Generate the function call. */
12416 52 : switch (code->resolved_isym->id)
12417 : {
12418 20 : case GFC_ISYM_CO_BROADCAST:
12419 20 : fndecl = gfor_fndecl_co_broadcast;
12420 20 : break;
12421 8 : case GFC_ISYM_CO_MAX:
12422 8 : fndecl = gfor_fndecl_co_max;
12423 8 : break;
12424 6 : case GFC_ISYM_CO_MIN:
12425 6 : fndecl = gfor_fndecl_co_min;
12426 6 : break;
12427 12 : case GFC_ISYM_CO_REDUCE:
12428 12 : fndecl = gfor_fndecl_co_reduce;
12429 12 : break;
12430 6 : case GFC_ISYM_CO_SUM:
12431 6 : fndecl = gfor_fndecl_co_sum;
12432 6 : break;
12433 0 : default:
12434 0 : gcc_unreachable ();
12435 : }
12436 :
12437 52 : if (derived && derived->attr.alloc_comp
12438 1 : && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12439 : /* The derived type has the attribute 'alloc_comp'. */
12440 : {
12441 2 : tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
12442 1 : code->ext.actual->expr->rank,
12443 : image_index, stat, errmsg, errmsg_len);
12444 1 : gfc_add_expr_to_block (&block, tmp);
12445 1 : }
12446 : else
12447 : {
12448 51 : if (code->resolved_isym->id == GFC_ISYM_CO_SUM
12449 45 : || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12450 25 : fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
12451 : image_index, stat, errmsg, errmsg_len);
12452 26 : else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
12453 14 : fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
12454 : image_index, stat, errmsg,
12455 : strlen, errmsg_len);
12456 : else
12457 : {
12458 12 : tree opr, opr_flags;
12459 :
12460 : // FIXME: Handle TS29113's bind(C) strings with descriptor.
12461 12 : int opr_flag_int;
12462 12 : if (gfc_is_proc_ptr_comp (opr_expr))
12463 : {
12464 0 : gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
12465 0 : opr_flag_int = sym->attr.dimension
12466 0 : || (sym->ts.type == BT_CHARACTER
12467 0 : && !sym->attr.is_bind_c)
12468 0 : ? GFC_CAF_BYREF : 0;
12469 0 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12470 0 : && !sym->attr.is_bind_c
12471 0 : ? GFC_CAF_HIDDENLEN : 0;
12472 0 : opr_flag_int |= sym->formal->sym->attr.value
12473 0 : ? GFC_CAF_ARG_VALUE : 0;
12474 : }
12475 : else
12476 : {
12477 12 : opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
12478 12 : ? GFC_CAF_BYREF : 0;
12479 24 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12480 0 : && !opr_expr->symtree->n.sym->attr.is_bind_c
12481 12 : ? GFC_CAF_HIDDENLEN : 0;
12482 12 : opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
12483 12 : ? GFC_CAF_ARG_VALUE : 0;
12484 : }
12485 12 : opr_flags = build_int_cst (integer_type_node, opr_flag_int);
12486 12 : gfc_conv_expr (&argse, opr_expr);
12487 12 : opr = argse.expr;
12488 12 : fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
12489 : opr_flags, image_index, stat, errmsg,
12490 : strlen, errmsg_len);
12491 : }
12492 : }
12493 :
12494 52 : gfc_add_expr_to_block (&block, fndecl);
12495 52 : gfc_add_block_to_block (&block, &post_block);
12496 :
12497 52 : return gfc_finish_block (&block);
12498 : }
12499 :
12500 :
12501 : static tree
12502 95 : conv_intrinsic_atomic_op (gfc_code *code)
12503 : {
12504 95 : gfc_se argse;
12505 95 : tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
12506 95 : stmtblock_t block, post_block;
12507 95 : gfc_expr *atom_expr = code->ext.actual->expr;
12508 95 : gfc_expr *stat_expr;
12509 95 : built_in_function fn;
12510 :
12511 95 : if (atom_expr->expr_type == EXPR_FUNCTION
12512 0 : && atom_expr->value.function.isym
12513 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12514 0 : atom_expr = atom_expr->value.function.actual->expr;
12515 :
12516 95 : gfc_start_block (&block);
12517 95 : gfc_init_block (&post_block);
12518 :
12519 95 : gfc_init_se (&argse, NULL);
12520 95 : argse.want_pointer = 1;
12521 95 : gfc_conv_expr (&argse, atom_expr);
12522 95 : gfc_add_block_to_block (&block, &argse.pre);
12523 95 : gfc_add_block_to_block (&post_block, &argse.post);
12524 95 : atom = argse.expr;
12525 :
12526 95 : gfc_init_se (&argse, NULL);
12527 95 : if (flag_coarray == GFC_FCOARRAY_LIB
12528 56 : && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
12529 54 : argse.want_pointer = 1;
12530 95 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12531 95 : gfc_add_block_to_block (&block, &argse.pre);
12532 95 : gfc_add_block_to_block (&post_block, &argse.post);
12533 95 : value = argse.expr;
12534 :
12535 95 : switch (code->resolved_isym->id)
12536 : {
12537 58 : case GFC_ISYM_ATOMIC_ADD:
12538 58 : case GFC_ISYM_ATOMIC_AND:
12539 58 : case GFC_ISYM_ATOMIC_DEF:
12540 58 : case GFC_ISYM_ATOMIC_OR:
12541 58 : case GFC_ISYM_ATOMIC_XOR:
12542 58 : stat_expr = code->ext.actual->next->next->expr;
12543 58 : if (flag_coarray == GFC_FCOARRAY_LIB)
12544 34 : old = null_pointer_node;
12545 : break;
12546 37 : default:
12547 37 : gfc_init_se (&argse, NULL);
12548 37 : if (flag_coarray == GFC_FCOARRAY_LIB)
12549 22 : argse.want_pointer = 1;
12550 37 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12551 37 : gfc_add_block_to_block (&block, &argse.pre);
12552 37 : gfc_add_block_to_block (&post_block, &argse.post);
12553 37 : old = argse.expr;
12554 37 : stat_expr = code->ext.actual->next->next->next->expr;
12555 : }
12556 :
12557 : /* STAT= */
12558 95 : if (stat_expr != NULL)
12559 : {
12560 82 : gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
12561 82 : gfc_init_se (&argse, NULL);
12562 82 : if (flag_coarray == GFC_FCOARRAY_LIB)
12563 48 : argse.want_pointer = 1;
12564 82 : gfc_conv_expr_val (&argse, stat_expr);
12565 82 : gfc_add_block_to_block (&block, &argse.pre);
12566 82 : gfc_add_block_to_block (&post_block, &argse.post);
12567 82 : stat = argse.expr;
12568 : }
12569 13 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12570 8 : stat = null_pointer_node;
12571 :
12572 95 : if (flag_coarray == GFC_FCOARRAY_LIB)
12573 : {
12574 56 : tree image_index, caf_decl, offset, token;
12575 56 : int op;
12576 :
12577 56 : switch (code->resolved_isym->id)
12578 : {
12579 : case GFC_ISYM_ATOMIC_ADD:
12580 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12581 : op = (int) GFC_CAF_ATOMIC_ADD;
12582 : break;
12583 12 : case GFC_ISYM_ATOMIC_AND:
12584 12 : case GFC_ISYM_ATOMIC_FETCH_AND:
12585 12 : op = (int) GFC_CAF_ATOMIC_AND;
12586 12 : break;
12587 12 : case GFC_ISYM_ATOMIC_OR:
12588 12 : case GFC_ISYM_ATOMIC_FETCH_OR:
12589 12 : op = (int) GFC_CAF_ATOMIC_OR;
12590 12 : break;
12591 12 : case GFC_ISYM_ATOMIC_XOR:
12592 12 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12593 12 : op = (int) GFC_CAF_ATOMIC_XOR;
12594 12 : break;
12595 11 : case GFC_ISYM_ATOMIC_DEF:
12596 11 : op = 0; /* Unused. */
12597 11 : break;
12598 0 : default:
12599 0 : gcc_unreachable ();
12600 : }
12601 :
12602 56 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12603 56 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12604 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12605 :
12606 56 : if (gfc_is_coindexed (atom_expr))
12607 48 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12608 : else
12609 8 : image_index = integer_zero_node;
12610 :
12611 : /* Ensure VALUE names addressable storage: taking the address of a
12612 : constant is invalid in C, and scalars need a temporary as well. */
12613 56 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12614 : {
12615 42 : tree elem
12616 42 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value);
12617 42 : elem = gfc_trans_force_lval (&block, elem);
12618 42 : value = gfc_build_addr_expr (NULL_TREE, elem);
12619 : }
12620 14 : else if (TREE_CODE (value) == ADDR_EXPR
12621 14 : && TREE_CONSTANT (TREE_OPERAND (value, 0)))
12622 : {
12623 0 : tree elem
12624 0 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)),
12625 : build_fold_indirect_ref (value));
12626 0 : elem = gfc_trans_force_lval (&block, elem);
12627 0 : value = gfc_build_addr_expr (NULL_TREE, elem);
12628 : }
12629 :
12630 56 : gfc_init_se (&argse, NULL);
12631 56 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12632 : atom_expr);
12633 :
12634 56 : gfc_add_block_to_block (&block, &argse.pre);
12635 56 : if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
12636 11 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
12637 : token, offset, image_index, value, stat,
12638 : build_int_cst (integer_type_node,
12639 11 : (int) atom_expr->ts.type),
12640 : build_int_cst (integer_type_node,
12641 11 : (int) atom_expr->ts.kind));
12642 : else
12643 45 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
12644 45 : build_int_cst (integer_type_node, op),
12645 : token, offset, image_index, value, old, stat,
12646 : build_int_cst (integer_type_node,
12647 45 : (int) atom_expr->ts.type),
12648 : build_int_cst (integer_type_node,
12649 45 : (int) atom_expr->ts.kind));
12650 :
12651 56 : gfc_add_expr_to_block (&block, tmp);
12652 56 : gfc_add_block_to_block (&block, &argse.post);
12653 56 : gfc_add_block_to_block (&block, &post_block);
12654 56 : return gfc_finish_block (&block);
12655 : }
12656 :
12657 :
12658 39 : switch (code->resolved_isym->id)
12659 : {
12660 : case GFC_ISYM_ATOMIC_ADD:
12661 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12662 : fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
12663 : break;
12664 8 : case GFC_ISYM_ATOMIC_AND:
12665 8 : case GFC_ISYM_ATOMIC_FETCH_AND:
12666 8 : fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12667 8 : break;
12668 9 : case GFC_ISYM_ATOMIC_DEF:
12669 9 : fn = BUILT_IN_ATOMIC_STORE_N;
12670 9 : break;
12671 8 : case GFC_ISYM_ATOMIC_OR:
12672 8 : case GFC_ISYM_ATOMIC_FETCH_OR:
12673 8 : fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12674 8 : break;
12675 8 : case GFC_ISYM_ATOMIC_XOR:
12676 8 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12677 8 : fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12678 8 : break;
12679 0 : default:
12680 0 : gcc_unreachable ();
12681 : }
12682 :
12683 39 : tmp = TREE_TYPE (TREE_TYPE (atom));
12684 78 : fn = (built_in_function) ((int) fn
12685 39 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12686 39 : + 1);
12687 39 : tree itype = TREE_TYPE (TREE_TYPE (atom));
12688 39 : tmp = builtin_decl_explicit (fn);
12689 :
12690 39 : switch (code->resolved_isym->id)
12691 : {
12692 24 : case GFC_ISYM_ATOMIC_ADD:
12693 24 : case GFC_ISYM_ATOMIC_AND:
12694 24 : case GFC_ISYM_ATOMIC_DEF:
12695 24 : case GFC_ISYM_ATOMIC_OR:
12696 24 : case GFC_ISYM_ATOMIC_XOR:
12697 24 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12698 : fold_convert (itype, value),
12699 : build_int_cst (NULL, MEMMODEL_RELAXED));
12700 24 : gfc_add_expr_to_block (&block, tmp);
12701 24 : break;
12702 15 : default:
12703 15 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12704 : fold_convert (itype, value),
12705 : build_int_cst (NULL, MEMMODEL_RELAXED));
12706 15 : gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12707 15 : break;
12708 : }
12709 :
12710 39 : if (stat != NULL_TREE)
12711 34 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12712 39 : gfc_add_block_to_block (&block, &post_block);
12713 39 : return gfc_finish_block (&block);
12714 : }
12715 :
12716 :
12717 : static tree
12718 176 : conv_intrinsic_atomic_ref (gfc_code *code)
12719 : {
12720 176 : gfc_se argse;
12721 176 : tree tmp, atom, value, stat = NULL_TREE;
12722 176 : stmtblock_t block, post_block;
12723 176 : built_in_function fn;
12724 176 : gfc_expr *atom_expr = code->ext.actual->next->expr;
12725 :
12726 176 : if (atom_expr->expr_type == EXPR_FUNCTION
12727 0 : && atom_expr->value.function.isym
12728 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12729 0 : atom_expr = atom_expr->value.function.actual->expr;
12730 :
12731 176 : gfc_start_block (&block);
12732 176 : gfc_init_block (&post_block);
12733 176 : gfc_init_se (&argse, NULL);
12734 176 : argse.want_pointer = 1;
12735 176 : gfc_conv_expr (&argse, atom_expr);
12736 176 : gfc_add_block_to_block (&block, &argse.pre);
12737 176 : gfc_add_block_to_block (&post_block, &argse.post);
12738 176 : atom = argse.expr;
12739 :
12740 176 : gfc_init_se (&argse, NULL);
12741 176 : if (flag_coarray == GFC_FCOARRAY_LIB
12742 115 : && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12743 109 : argse.want_pointer = 1;
12744 176 : gfc_conv_expr (&argse, code->ext.actual->expr);
12745 176 : gfc_add_block_to_block (&block, &argse.pre);
12746 176 : gfc_add_block_to_block (&post_block, &argse.post);
12747 176 : value = argse.expr;
12748 :
12749 : /* STAT= */
12750 176 : if (code->ext.actual->next->next->expr != NULL)
12751 : {
12752 164 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12753 : == EXPR_VARIABLE);
12754 164 : gfc_init_se (&argse, NULL);
12755 164 : if (flag_coarray == GFC_FCOARRAY_LIB)
12756 108 : argse.want_pointer = 1;
12757 164 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12758 164 : gfc_add_block_to_block (&block, &argse.pre);
12759 164 : gfc_add_block_to_block (&post_block, &argse.post);
12760 164 : stat = argse.expr;
12761 : }
12762 12 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12763 7 : stat = null_pointer_node;
12764 :
12765 176 : if (flag_coarray == GFC_FCOARRAY_LIB)
12766 : {
12767 115 : tree image_index, caf_decl, offset, token;
12768 115 : tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12769 :
12770 115 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12771 115 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12772 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12773 :
12774 115 : if (gfc_is_coindexed (atom_expr))
12775 103 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12776 : else
12777 12 : image_index = integer_zero_node;
12778 :
12779 115 : gfc_init_se (&argse, NULL);
12780 115 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12781 : atom_expr);
12782 115 : gfc_add_block_to_block (&block, &argse.pre);
12783 :
12784 : /* Different type, need type conversion. */
12785 115 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12786 : {
12787 6 : vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12788 6 : orig_value = value;
12789 6 : value = gfc_build_addr_expr (NULL_TREE, vardecl);
12790 : }
12791 :
12792 115 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12793 : token, offset, image_index, value, stat,
12794 : build_int_cst (integer_type_node,
12795 115 : (int) atom_expr->ts.type),
12796 : build_int_cst (integer_type_node,
12797 115 : (int) atom_expr->ts.kind));
12798 115 : gfc_add_expr_to_block (&block, tmp);
12799 115 : if (vardecl != NULL_TREE)
12800 6 : gfc_add_modify (&block, orig_value,
12801 6 : fold_convert (TREE_TYPE (orig_value), vardecl));
12802 115 : gfc_add_block_to_block (&block, &argse.post);
12803 115 : gfc_add_block_to_block (&block, &post_block);
12804 115 : return gfc_finish_block (&block);
12805 : }
12806 :
12807 61 : tmp = TREE_TYPE (TREE_TYPE (atom));
12808 122 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12809 61 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12810 61 : + 1);
12811 61 : tmp = builtin_decl_explicit (fn);
12812 61 : tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12813 : build_int_cst (integer_type_node,
12814 : MEMMODEL_RELAXED));
12815 61 : gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12816 :
12817 61 : if (stat != NULL_TREE)
12818 56 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12819 61 : gfc_add_block_to_block (&block, &post_block);
12820 61 : return gfc_finish_block (&block);
12821 : }
12822 :
12823 :
12824 : static tree
12825 14 : conv_intrinsic_atomic_cas (gfc_code *code)
12826 : {
12827 14 : gfc_se argse;
12828 14 : tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12829 14 : stmtblock_t block, post_block;
12830 14 : built_in_function fn;
12831 14 : gfc_expr *atom_expr = code->ext.actual->expr;
12832 :
12833 14 : if (atom_expr->expr_type == EXPR_FUNCTION
12834 0 : && atom_expr->value.function.isym
12835 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12836 0 : atom_expr = atom_expr->value.function.actual->expr;
12837 :
12838 14 : gfc_init_block (&block);
12839 14 : gfc_init_block (&post_block);
12840 14 : gfc_init_se (&argse, NULL);
12841 14 : argse.want_pointer = 1;
12842 14 : gfc_conv_expr (&argse, atom_expr);
12843 14 : atom = argse.expr;
12844 :
12845 14 : gfc_init_se (&argse, NULL);
12846 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12847 8 : argse.want_pointer = 1;
12848 14 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12849 14 : gfc_add_block_to_block (&block, &argse.pre);
12850 14 : gfc_add_block_to_block (&post_block, &argse.post);
12851 14 : old = argse.expr;
12852 :
12853 14 : gfc_init_se (&argse, NULL);
12854 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12855 8 : argse.want_pointer = 1;
12856 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12857 14 : gfc_add_block_to_block (&block, &argse.pre);
12858 14 : gfc_add_block_to_block (&post_block, &argse.post);
12859 14 : comp = argse.expr;
12860 :
12861 14 : gfc_init_se (&argse, NULL);
12862 14 : if (flag_coarray == GFC_FCOARRAY_LIB
12863 8 : && code->ext.actual->next->next->next->expr->ts.kind
12864 8 : == atom_expr->ts.kind)
12865 8 : argse.want_pointer = 1;
12866 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
12867 14 : gfc_add_block_to_block (&block, &argse.pre);
12868 14 : gfc_add_block_to_block (&post_block, &argse.post);
12869 14 : new_val = argse.expr;
12870 :
12871 : /* STAT= */
12872 14 : if (code->ext.actual->next->next->next->next->expr != NULL)
12873 : {
12874 14 : gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
12875 : == EXPR_VARIABLE);
12876 14 : gfc_init_se (&argse, NULL);
12877 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12878 8 : argse.want_pointer = 1;
12879 14 : gfc_conv_expr_val (&argse,
12880 14 : code->ext.actual->next->next->next->next->expr);
12881 14 : gfc_add_block_to_block (&block, &argse.pre);
12882 14 : gfc_add_block_to_block (&post_block, &argse.post);
12883 14 : stat = argse.expr;
12884 : }
12885 0 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12886 0 : stat = null_pointer_node;
12887 :
12888 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12889 : {
12890 8 : tree image_index, caf_decl, offset, token;
12891 :
12892 8 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12893 8 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12894 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12895 :
12896 8 : if (gfc_is_coindexed (atom_expr))
12897 8 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12898 : else
12899 0 : image_index = integer_zero_node;
12900 :
12901 8 : if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
12902 : {
12903 0 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
12904 0 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
12905 0 : new_val = gfc_build_addr_expr (NULL_TREE, tmp);
12906 : }
12907 :
12908 8 : gfc_init_se (&argse, NULL);
12909 8 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12910 : atom_expr);
12911 8 : gfc_add_block_to_block (&block, &argse.pre);
12912 :
12913 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
12914 : token, offset, image_index, old, comp, new_val,
12915 : stat, build_int_cst (integer_type_node,
12916 8 : (int) atom_expr->ts.type),
12917 : build_int_cst (integer_type_node,
12918 8 : (int) atom_expr->ts.kind));
12919 8 : gfc_add_expr_to_block (&block, tmp);
12920 8 : gfc_add_block_to_block (&block, &argse.post);
12921 8 : gfc_add_block_to_block (&block, &post_block);
12922 8 : return gfc_finish_block (&block);
12923 : }
12924 :
12925 6 : tmp = TREE_TYPE (TREE_TYPE (atom));
12926 12 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
12927 6 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12928 6 : + 1);
12929 6 : tmp = builtin_decl_explicit (fn);
12930 :
12931 6 : gfc_add_modify (&block, old, comp);
12932 12 : tmp = build_call_expr_loc (input_location, tmp, 6, atom,
12933 : gfc_build_addr_expr (NULL, old),
12934 6 : fold_convert (TREE_TYPE (old), new_val),
12935 : boolean_false_node,
12936 : build_int_cst (NULL, MEMMODEL_RELAXED),
12937 : build_int_cst (NULL, MEMMODEL_RELAXED));
12938 6 : gfc_add_expr_to_block (&block, tmp);
12939 :
12940 6 : if (stat != NULL_TREE)
12941 6 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12942 6 : gfc_add_block_to_block (&block, &post_block);
12943 6 : return gfc_finish_block (&block);
12944 : }
12945 :
12946 : static tree
12947 105 : conv_intrinsic_event_query (gfc_code *code)
12948 : {
12949 105 : gfc_se se, argse;
12950 105 : tree stat = NULL_TREE, stat2 = NULL_TREE;
12951 105 : tree count = NULL_TREE, count2 = NULL_TREE;
12952 :
12953 105 : gfc_expr *event_expr = code->ext.actual->expr;
12954 :
12955 105 : if (code->ext.actual->next->next->expr)
12956 : {
12957 18 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12958 : == EXPR_VARIABLE);
12959 18 : gfc_init_se (&argse, NULL);
12960 18 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12961 18 : stat = argse.expr;
12962 : }
12963 87 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12964 58 : stat = null_pointer_node;
12965 :
12966 105 : if (code->ext.actual->next->expr)
12967 : {
12968 105 : gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
12969 105 : gfc_init_se (&argse, NULL);
12970 105 : gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
12971 105 : count = argse.expr;
12972 : }
12973 :
12974 105 : gfc_start_block (&se.pre);
12975 105 : if (flag_coarray == GFC_FCOARRAY_LIB)
12976 : {
12977 70 : tree tmp, token, image_index;
12978 70 : tree index = build_zero_cst (gfc_array_index_type);
12979 :
12980 70 : if (event_expr->expr_type == EXPR_FUNCTION
12981 0 : && event_expr->value.function.isym
12982 0 : && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12983 0 : event_expr = event_expr->value.function.actual->expr;
12984 :
12985 70 : tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
12986 :
12987 70 : if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
12988 70 : || event_expr->symtree->n.sym->ts.u.derived->from_intmod
12989 : != INTMOD_ISO_FORTRAN_ENV
12990 70 : || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
12991 : != ISOFORTRAN_EVENT_TYPE)
12992 : {
12993 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
12994 : "yet supported", &event_expr->where);
12995 0 : return NULL_TREE;
12996 : }
12997 :
12998 70 : if (gfc_is_coindexed (event_expr))
12999 : {
13000 0 : gfc_error ("The event variable at %L shall not be coindexed",
13001 : &event_expr->where);
13002 0 : return NULL_TREE;
13003 : }
13004 :
13005 70 : image_index = integer_zero_node;
13006 :
13007 70 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
13008 : event_expr);
13009 :
13010 : /* For arrays, obtain the array index. */
13011 70 : if (gfc_expr_attr (event_expr).dimension)
13012 : {
13013 52 : tree desc, tmp, extent, lbound, ubound;
13014 52 : gfc_array_ref *ar, ar2;
13015 52 : int i;
13016 :
13017 : /* TODO: Extend this, once DT components are supported. */
13018 52 : ar = &event_expr->ref->u.ar;
13019 52 : ar2 = *ar;
13020 52 : memset (ar, '\0', sizeof (*ar));
13021 52 : ar->as = ar2.as;
13022 52 : ar->type = AR_FULL;
13023 :
13024 52 : gfc_init_se (&argse, NULL);
13025 52 : argse.descriptor_only = 1;
13026 52 : gfc_conv_expr_descriptor (&argse, event_expr);
13027 52 : gfc_add_block_to_block (&se.pre, &argse.pre);
13028 52 : desc = argse.expr;
13029 52 : *ar = ar2;
13030 :
13031 52 : extent = build_one_cst (gfc_array_index_type);
13032 156 : for (i = 0; i < ar->dimen; i++)
13033 : {
13034 52 : gfc_init_se (&argse, NULL);
13035 52 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
13036 52 : gfc_add_block_to_block (&argse.pre, &argse.pre);
13037 52 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
13038 52 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
13039 52 : TREE_TYPE (lbound), argse.expr, lbound);
13040 52 : tmp = fold_build2_loc (input_location, MULT_EXPR,
13041 52 : TREE_TYPE (tmp), extent, tmp);
13042 52 : index = fold_build2_loc (input_location, PLUS_EXPR,
13043 52 : TREE_TYPE (tmp), index, tmp);
13044 52 : if (i < ar->dimen - 1)
13045 : {
13046 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
13047 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
13048 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
13049 0 : TREE_TYPE (tmp), extent, tmp);
13050 : }
13051 : }
13052 : }
13053 :
13054 70 : if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
13055 : {
13056 0 : count2 = count;
13057 0 : count = gfc_create_var (integer_type_node, "count");
13058 : }
13059 :
13060 70 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
13061 : {
13062 0 : stat2 = stat;
13063 0 : stat = gfc_create_var (integer_type_node, "stat");
13064 : }
13065 :
13066 70 : index = fold_convert (size_type_node, index);
13067 140 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
13068 : token, index, image_index, count
13069 70 : ? gfc_build_addr_expr (NULL, count) : count,
13070 70 : stat != null_pointer_node
13071 12 : ? gfc_build_addr_expr (NULL, stat) : stat);
13072 70 : gfc_add_expr_to_block (&se.pre, tmp);
13073 :
13074 70 : if (count2 != NULL_TREE)
13075 0 : gfc_add_modify (&se.pre, count2,
13076 0 : fold_convert (TREE_TYPE (count2), count));
13077 :
13078 70 : if (stat2 != NULL_TREE)
13079 0 : gfc_add_modify (&se.pre, stat2,
13080 0 : fold_convert (TREE_TYPE (stat2), stat));
13081 :
13082 70 : return gfc_finish_block (&se.pre);
13083 : }
13084 :
13085 35 : gfc_init_se (&argse, NULL);
13086 35 : gfc_conv_expr_val (&argse, code->ext.actual->expr);
13087 35 : gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
13088 :
13089 35 : if (stat != NULL_TREE)
13090 6 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
13091 :
13092 35 : return gfc_finish_block (&se.pre);
13093 : }
13094 :
13095 :
13096 : /* This is a peculiar case because of the need to do dependency checking.
13097 : It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
13098 : a special case and this function called instead of
13099 : gfc_conv_procedure_call. */
13100 : void
13101 197 : gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
13102 : gfc_loopinfo *loop)
13103 : {
13104 197 : gfc_actual_arglist *actual;
13105 197 : gfc_se argse[5];
13106 197 : gfc_expr *arg[5];
13107 197 : gfc_ss *lss;
13108 197 : int n;
13109 :
13110 197 : tree from, frompos, len, to, topos;
13111 197 : tree lenmask, oldbits, newbits, bitsize;
13112 197 : tree type, utype, above, mask1, mask2;
13113 :
13114 197 : if (loop)
13115 67 : lss = loop->ss;
13116 : else
13117 130 : lss = gfc_ss_terminator;
13118 :
13119 : actual = actual_args;
13120 1182 : for (n = 0; n < 5; n++, actual = actual->next)
13121 : {
13122 985 : arg[n] = actual->expr;
13123 985 : gfc_init_se (&argse[n], NULL);
13124 :
13125 985 : if (lss != gfc_ss_terminator)
13126 : {
13127 335 : gfc_copy_loopinfo_to_se (&argse[n], loop);
13128 : /* Find the ss for the expression if it is there. */
13129 335 : argse[n].ss = lss;
13130 335 : gfc_mark_ss_chain_used (lss, 1);
13131 : }
13132 :
13133 985 : gfc_conv_expr (&argse[n], arg[n]);
13134 :
13135 985 : if (loop)
13136 335 : lss = argse[n].ss;
13137 : }
13138 :
13139 197 : from = argse[0].expr;
13140 197 : frompos = argse[1].expr;
13141 197 : len = argse[2].expr;
13142 197 : to = argse[3].expr;
13143 197 : topos = argse[4].expr;
13144 :
13145 : /* The type of the result (TO). */
13146 197 : type = TREE_TYPE (to);
13147 197 : bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
13148 :
13149 : /* Optionally generate code for runtime argument check. */
13150 197 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
13151 : {
13152 18 : tree nbits, below, ccond;
13153 18 : tree fp = fold_convert (long_integer_type_node, frompos);
13154 18 : tree ln = fold_convert (long_integer_type_node, len);
13155 18 : tree tp = fold_convert (long_integer_type_node, topos);
13156 18 : below = fold_build2_loc (input_location, LT_EXPR,
13157 : logical_type_node, frompos,
13158 18 : build_int_cst (TREE_TYPE (frompos), 0));
13159 18 : above = fold_build2_loc (input_location, GT_EXPR,
13160 : logical_type_node, frompos,
13161 18 : fold_convert (TREE_TYPE (frompos), bitsize));
13162 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13163 : logical_type_node, below, above);
13164 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13165 18 : &arg[1]->where,
13166 : "FROMPOS argument (%ld) out of range 0:%d "
13167 : "in intrinsic MVBITS", fp, bitsize);
13168 18 : below = fold_build2_loc (input_location, LT_EXPR,
13169 : logical_type_node, len,
13170 18 : build_int_cst (TREE_TYPE (len), 0));
13171 18 : above = fold_build2_loc (input_location, GT_EXPR,
13172 : logical_type_node, len,
13173 18 : fold_convert (TREE_TYPE (len), bitsize));
13174 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13175 : logical_type_node, below, above);
13176 18 : gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
13177 18 : &arg[2]->where,
13178 : "LEN argument (%ld) out of range 0:%d "
13179 : "in intrinsic MVBITS", ln, bitsize);
13180 18 : below = fold_build2_loc (input_location, LT_EXPR,
13181 : logical_type_node, topos,
13182 18 : build_int_cst (TREE_TYPE (topos), 0));
13183 18 : above = fold_build2_loc (input_location, GT_EXPR,
13184 : logical_type_node, topos,
13185 18 : fold_convert (TREE_TYPE (topos), bitsize));
13186 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13187 : logical_type_node, below, above);
13188 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13189 18 : &arg[4]->where,
13190 : "TOPOS argument (%ld) out of range 0:%d "
13191 : "in intrinsic MVBITS", tp, bitsize);
13192 :
13193 : /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
13194 : integers. Additions below cannot overflow. */
13195 18 : nbits = fold_convert (long_integer_type_node, bitsize);
13196 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13197 : long_integer_type_node, fp, ln);
13198 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13199 : logical_type_node, above, nbits);
13200 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13201 : &arg[1]->where,
13202 : "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13203 : "in intrinsic MVBITS", fp, ln, bitsize);
13204 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13205 : long_integer_type_node, tp, ln);
13206 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13207 : logical_type_node, above, nbits);
13208 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13209 : &arg[4]->where,
13210 : "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13211 : "in intrinsic MVBITS", tp, ln, bitsize);
13212 : }
13213 :
13214 1182 : for (n = 0; n < 5; n++)
13215 : {
13216 985 : gfc_add_block_to_block (&se->pre, &argse[n].pre);
13217 985 : gfc_add_block_to_block (&se->post, &argse[n].post);
13218 : }
13219 :
13220 : /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
13221 197 : above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
13222 197 : len, fold_convert (TREE_TYPE (len), bitsize));
13223 197 : mask1 = build_int_cst (type, -1);
13224 197 : mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13225 : build_int_cst (type, 1), len);
13226 197 : mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
13227 : mask2, build_int_cst (type, 1));
13228 197 : lenmask = fold_build3_loc (input_location, COND_EXPR, type,
13229 : above, mask1, mask2);
13230 :
13231 : /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
13232 : * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
13233 : * not strictly necessary; artificial bits from rshift will be masked. */
13234 197 : utype = unsigned_type_for (type);
13235 197 : newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
13236 : fold_convert (utype, from), frompos);
13237 197 : newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
13238 : fold_convert (type, newbits), lenmask);
13239 197 : newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13240 : newbits, topos);
13241 :
13242 : /* oldbits = TO & (~(lenmask << TOPOS)). */
13243 197 : oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13244 : lenmask, topos);
13245 197 : oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
13246 197 : oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
13247 :
13248 : /* TO = newbits | oldbits. */
13249 197 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
13250 : oldbits, newbits);
13251 :
13252 : /* Return the assignment. */
13253 197 : se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
13254 : void_type_node, to, se->expr);
13255 197 : }
13256 :
13257 : /* Comes from trans-stmt.cc, but we don't want the whole header included. */
13258 : extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
13259 : tree *stat, tree *errmsg, tree *errmsg_len);
13260 :
13261 : static tree
13262 263 : conv_intrinsic_move_alloc (gfc_code *code)
13263 : {
13264 263 : stmtblock_t block;
13265 263 : gfc_expr *from_expr, *to_expr;
13266 263 : gfc_se from_se, to_se;
13267 263 : tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE;
13268 263 : bool coarray, from_is_class, from_is_scalar;
13269 263 : gfc_actual_arglist *arg = code->ext.actual;
13270 263 : sync_stat tmp_sync_stat = {nullptr, nullptr};
13271 :
13272 263 : gfc_start_block (&block);
13273 :
13274 263 : from_expr = arg->expr;
13275 263 : arg = arg->next;
13276 263 : to_expr = arg->expr;
13277 263 : arg = arg->next;
13278 :
13279 789 : while (arg)
13280 : {
13281 526 : if (arg->expr)
13282 : {
13283 0 : if (!strcmp ("stat", arg->name))
13284 0 : tmp_sync_stat.stat = arg->expr;
13285 0 : else if (!strcmp ("errmsg", arg->name))
13286 0 : tmp_sync_stat.errmsg = arg->expr;
13287 : }
13288 526 : arg = arg->next;
13289 : }
13290 :
13291 263 : gfc_init_se (&from_se, NULL);
13292 263 : gfc_init_se (&to_se, NULL);
13293 :
13294 263 : gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len);
13295 263 : if (stat != null_pointer_node)
13296 0 : fin_label = gfc_build_label_decl (NULL_TREE);
13297 :
13298 263 : gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
13299 263 : coarray = from_expr->corank != 0;
13300 :
13301 263 : from_is_class = from_expr->ts.type == BT_CLASS;
13302 263 : from_is_scalar = from_expr->rank == 0 && !coarray;
13303 263 : if (to_expr->ts.type == BT_CLASS || from_is_scalar)
13304 : {
13305 163 : from_se.want_pointer = 1;
13306 163 : if (from_is_scalar)
13307 115 : gfc_conv_expr (&from_se, from_expr);
13308 : else
13309 48 : gfc_conv_expr_descriptor (&from_se, from_expr);
13310 163 : if (from_is_class)
13311 64 : from_tree = gfc_class_data_get (from_se.expr);
13312 : else
13313 : {
13314 99 : gfc_symbol *vtab;
13315 99 : from_tree = from_se.expr;
13316 :
13317 99 : if (to_expr->ts.type == BT_CLASS)
13318 : {
13319 36 : vtab = gfc_find_vtab (&from_expr->ts);
13320 36 : gcc_assert (vtab);
13321 36 : from_se.expr = gfc_get_symbol_decl (vtab);
13322 : }
13323 : }
13324 163 : gfc_add_block_to_block (&block, &from_se.pre);
13325 :
13326 163 : to_se.want_pointer = 1;
13327 163 : if (to_expr->rank == 0)
13328 115 : gfc_conv_expr (&to_se, to_expr);
13329 : else
13330 48 : gfc_conv_expr_descriptor (&to_se, to_expr);
13331 163 : if (to_expr->ts.type == BT_CLASS)
13332 100 : to_tree = gfc_class_data_get (to_se.expr);
13333 : else
13334 63 : to_tree = to_se.expr;
13335 163 : gfc_add_block_to_block (&block, &to_se.pre);
13336 :
13337 : /* Deallocate "to". */
13338 163 : if (to_expr->rank == 0)
13339 : {
13340 115 : tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
13341 : true, to_expr, to_expr->ts,
13342 : NULL_TREE, false, true,
13343 : errmsg, errmsg_len);
13344 115 : gfc_add_expr_to_block (&block, tmp);
13345 : }
13346 :
13347 163 : if (from_is_scalar)
13348 : {
13349 : /* Assign (_data) pointers. */
13350 115 : gfc_add_modify_loc (input_location, &block, to_tree,
13351 115 : fold_convert (TREE_TYPE (to_tree), from_tree));
13352 :
13353 : /* Set "from" to NULL. */
13354 115 : gfc_add_modify_loc (input_location, &block, from_tree,
13355 115 : fold_convert (TREE_TYPE (from_tree),
13356 : null_pointer_node));
13357 :
13358 115 : gfc_add_block_to_block (&block, &from_se.post);
13359 : }
13360 163 : gfc_add_block_to_block (&block, &to_se.post);
13361 :
13362 : /* Set _vptr. */
13363 163 : if (to_expr->ts.type == BT_CLASS)
13364 : {
13365 100 : gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
13366 100 : if (from_is_class)
13367 64 : gfc_reset_vptr (&block, from_expr);
13368 100 : if (UNLIMITED_POLY (to_expr))
13369 : {
13370 20 : tree to_len = gfc_class_len_get (to_se.class_container);
13371 20 : tmp = from_expr->ts.type == BT_CHARACTER && from_se.string_length
13372 20 : ? from_se.string_length
13373 : : size_zero_node;
13374 20 : gfc_add_modify_loc (input_location, &block, to_len,
13375 20 : fold_convert (TREE_TYPE (to_len), tmp));
13376 : }
13377 : }
13378 :
13379 163 : if (from_is_scalar)
13380 : {
13381 115 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13382 : {
13383 6 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13384 6 : fold_convert (TREE_TYPE (to_se.string_length),
13385 : from_se.string_length));
13386 6 : if (from_expr->ts.deferred)
13387 6 : gfc_add_modify_loc (
13388 : input_location, &block, from_se.string_length,
13389 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13390 : }
13391 115 : if (UNLIMITED_POLY (from_expr))
13392 2 : gfc_reset_len (&block, from_expr);
13393 :
13394 115 : return gfc_finish_block (&block);
13395 : }
13396 :
13397 48 : gfc_init_se (&to_se, NULL);
13398 48 : gfc_init_se (&from_se, NULL);
13399 : }
13400 :
13401 : /* Deallocate "to". */
13402 148 : if (from_expr->rank == 0)
13403 : {
13404 4 : to_se.want_coarray = 1;
13405 4 : from_se.want_coarray = 1;
13406 : }
13407 148 : gfc_conv_expr_descriptor (&to_se, to_expr);
13408 148 : gfc_conv_expr_descriptor (&from_se, from_expr);
13409 148 : gfc_add_block_to_block (&block, &to_se.pre);
13410 148 : gfc_add_block_to_block (&block, &from_se.pre);
13411 :
13412 : /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
13413 : is an image control "statement", cf. IR F08/0040 in 12-006A. */
13414 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13415 : {
13416 6 : tree cond;
13417 :
13418 6 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13419 : fin_label, true, to_expr,
13420 : GFC_CAF_COARRAY_DEALLOCATE_ONLY,
13421 : NULL_TREE, NULL_TREE,
13422 : gfc_conv_descriptor_token (to_se.expr),
13423 : true);
13424 6 : gfc_add_expr_to_block (&block, tmp);
13425 :
13426 6 : tmp = gfc_conv_descriptor_data_get (to_se.expr);
13427 6 : cond = fold_build2_loc (input_location, EQ_EXPR,
13428 : logical_type_node, tmp,
13429 6 : fold_convert (TREE_TYPE (tmp),
13430 : null_pointer_node));
13431 6 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
13432 : 3, null_pointer_node, null_pointer_node,
13433 : integer_zero_node);
13434 :
13435 6 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
13436 : tmp, build_empty_stmt (input_location));
13437 6 : gfc_add_expr_to_block (&block, tmp);
13438 6 : }
13439 : else
13440 : {
13441 142 : if (to_expr->ts.type == BT_DERIVED
13442 25 : && to_expr->ts.u.derived->attr.alloc_comp)
13443 : {
13444 19 : tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
13445 : to_se.expr, to_expr->rank);
13446 19 : gfc_add_expr_to_block (&block, tmp);
13447 : }
13448 :
13449 142 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13450 : fin_label, true, to_expr,
13451 : GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
13452 : NULL_TREE, NULL_TREE, true);
13453 142 : gfc_add_expr_to_block (&block, tmp);
13454 : }
13455 :
13456 : /* Copy the array descriptor data. */
13457 148 : gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
13458 :
13459 : /* Set "from" to NULL. */
13460 148 : tmp = gfc_conv_descriptor_data_get (from_se.expr);
13461 148 : gfc_add_modify_loc (input_location, &block, tmp,
13462 148 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
13463 :
13464 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13465 : {
13466 : /* Copy the array descriptor data has overwritten the to-token and cleared
13467 : from.data. Now also clear the from.token. */
13468 6 : gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr),
13469 : null_pointer_node);
13470 : }
13471 :
13472 148 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13473 : {
13474 7 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13475 7 : fold_convert (TREE_TYPE (to_se.string_length),
13476 : from_se.string_length));
13477 7 : if (from_expr->ts.deferred)
13478 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
13479 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13480 : }
13481 148 : if (fin_label)
13482 0 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
13483 :
13484 148 : gfc_add_block_to_block (&block, &to_se.post);
13485 148 : gfc_add_block_to_block (&block, &from_se.post);
13486 :
13487 148 : return gfc_finish_block (&block);
13488 : }
13489 :
13490 :
13491 : tree
13492 6624 : gfc_conv_intrinsic_subroutine (gfc_code *code)
13493 : {
13494 6624 : tree res;
13495 :
13496 6624 : gcc_assert (code->resolved_isym);
13497 :
13498 6624 : switch (code->resolved_isym->id)
13499 : {
13500 263 : case GFC_ISYM_MOVE_ALLOC:
13501 263 : res = conv_intrinsic_move_alloc (code);
13502 263 : break;
13503 :
13504 14 : case GFC_ISYM_ATOMIC_CAS:
13505 14 : res = conv_intrinsic_atomic_cas (code);
13506 14 : break;
13507 :
13508 95 : case GFC_ISYM_ATOMIC_ADD:
13509 95 : case GFC_ISYM_ATOMIC_AND:
13510 95 : case GFC_ISYM_ATOMIC_DEF:
13511 95 : case GFC_ISYM_ATOMIC_OR:
13512 95 : case GFC_ISYM_ATOMIC_XOR:
13513 95 : case GFC_ISYM_ATOMIC_FETCH_ADD:
13514 95 : case GFC_ISYM_ATOMIC_FETCH_AND:
13515 95 : case GFC_ISYM_ATOMIC_FETCH_OR:
13516 95 : case GFC_ISYM_ATOMIC_FETCH_XOR:
13517 95 : res = conv_intrinsic_atomic_op (code);
13518 95 : break;
13519 :
13520 176 : case GFC_ISYM_ATOMIC_REF:
13521 176 : res = conv_intrinsic_atomic_ref (code);
13522 176 : break;
13523 :
13524 105 : case GFC_ISYM_EVENT_QUERY:
13525 105 : res = conv_intrinsic_event_query (code);
13526 105 : break;
13527 :
13528 3084 : case GFC_ISYM_C_F_POINTER:
13529 3084 : case GFC_ISYM_C_F_PROCPOINTER:
13530 3084 : res = conv_isocbinding_subroutine (code);
13531 3084 : break;
13532 :
13533 360 : case GFC_ISYM_CAF_SEND:
13534 360 : res = conv_caf_send_to_remote (code);
13535 360 : break;
13536 :
13537 140 : case GFC_ISYM_CAF_SENDGET:
13538 140 : res = conv_caf_sendget (code);
13539 140 : break;
13540 :
13541 88 : case GFC_ISYM_CO_BROADCAST:
13542 88 : case GFC_ISYM_CO_MIN:
13543 88 : case GFC_ISYM_CO_MAX:
13544 88 : case GFC_ISYM_CO_REDUCE:
13545 88 : case GFC_ISYM_CO_SUM:
13546 88 : res = conv_co_collective (code);
13547 88 : break;
13548 :
13549 10 : case GFC_ISYM_FREE:
13550 10 : res = conv_intrinsic_free (code);
13551 10 : break;
13552 :
13553 55 : case GFC_ISYM_FSTAT:
13554 55 : case GFC_ISYM_LSTAT:
13555 55 : case GFC_ISYM_STAT:
13556 55 : res = conv_intrinsic_fstat_lstat_stat_sub (code);
13557 55 : break;
13558 :
13559 90 : case GFC_ISYM_RANDOM_INIT:
13560 90 : res = conv_intrinsic_random_init (code);
13561 90 : break;
13562 :
13563 15 : case GFC_ISYM_KILL:
13564 15 : res = conv_intrinsic_kill_sub (code);
13565 15 : break;
13566 :
13567 : case GFC_ISYM_MVBITS:
13568 : res = NULL_TREE;
13569 : break;
13570 :
13571 194 : case GFC_ISYM_SYSTEM_CLOCK:
13572 194 : res = conv_intrinsic_system_clock (code);
13573 194 : break;
13574 :
13575 102 : case GFC_ISYM_SPLIT:
13576 102 : res = conv_intrinsic_split (code);
13577 102 : break;
13578 :
13579 : default:
13580 : res = NULL_TREE;
13581 : break;
13582 : }
13583 :
13584 6624 : return res;
13585 : }
13586 :
13587 : #include "gt-fortran-trans-intrinsic.h"
|
