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 80663 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
203 : tree *argarray, int nargs)
204 : {
205 80663 : gfc_actual_arglist *actual;
206 80663 : gfc_expr *e;
207 80663 : gfc_intrinsic_arg *formal;
208 80663 : gfc_se argse;
209 80663 : int curr_arg;
210 :
211 80663 : formal = expr->value.function.isym->formal;
212 80663 : actual = expr->value.function.actual;
213 :
214 181898 : for (curr_arg = 0; curr_arg < nargs; curr_arg++,
215 62921 : actual = actual->next,
216 101235 : formal = formal ? formal->next : NULL)
217 : {
218 101235 : gcc_assert (actual);
219 101235 : e = actual->expr;
220 : /* Skip omitted optional arguments. */
221 101235 : if (!e)
222 : {
223 31 : --curr_arg;
224 31 : continue;
225 : }
226 :
227 : /* Evaluate the parameter. This will substitute scalarized
228 : references automatically. */
229 101204 : gfc_init_se (&argse, se);
230 :
231 101204 : if (e->ts.type == BT_CHARACTER)
232 : {
233 9625 : gfc_conv_expr (&argse, e);
234 9625 : gfc_conv_string_parameter (&argse);
235 9625 : argarray[curr_arg++] = argse.string_length;
236 9625 : gcc_assert (curr_arg < nargs);
237 : }
238 : else
239 91579 : 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 101204 : if (e->expr_type == EXPR_VARIABLE
244 51707 : && 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 101204 : gfc_add_block_to_block (&se->pre, &argse.pre);
250 101204 : gfc_add_block_to_block (&se->post, &argse.post);
251 101204 : argarray[curr_arg] = argse.expr;
252 : }
253 80663 : }
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 55773 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
260 : {
261 55773 : int n = 0;
262 55773 : gfc_actual_arglist *actual;
263 :
264 126733 : for (actual = expr->value.function.actual; actual; actual = actual->next)
265 : {
266 70960 : if (!actual->expr)
267 6334 : continue;
268 :
269 64626 : if (actual->expr->ts.type == BT_CHARACTER)
270 4545 : n += 2;
271 : else
272 60081 : n++;
273 : }
274 :
275 55773 : 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 39694 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
284 : {
285 39694 : tree type;
286 39694 : tree *args;
287 39694 : int nargs;
288 :
289 39694 : nargs = gfc_intrinsic_argument_list_length (expr);
290 39694 : 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 39694 : type = gfc_typenode_for_spec (&expr->ts);
296 39694 : gcc_assert (expr->value.function.actual->expr);
297 39694 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
298 :
299 : /* Conversion between character kinds involves a call to a library
300 : function. */
301 39694 : 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 39446 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
338 39446 : && 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 39446 : 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 1579 : build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
422 : enum rounding_mode op)
423 : {
424 1579 : 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 1285 : case RND_TRUNC:
436 1285 : 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 3106 : gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
530 : {
531 3106 : tree type;
532 3106 : tree *args;
533 3106 : int nargs;
534 :
535 3106 : nargs = gfc_intrinsic_argument_list_length (expr);
536 3106 : 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 3106 : type = gfc_typenode_for_spec (&expr->ts);
541 3106 : gcc_assert (expr->value.function.actual->expr);
542 3106 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
543 :
544 3106 : 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 1579 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
554 1579 : && 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 1579 : se->expr = build_fix_expr (&se->pre, args[0], type, op);
564 : }
565 3106 : }
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 659904 : define_quad_builtin (const char *name, tree type, bool is_const)
596 : {
597 659904 : tree fndecl;
598 659904 : fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
599 : type);
600 :
601 : /* Mark the decl as external. */
602 659904 : DECL_EXTERNAL (fndecl) = 1;
603 659904 : TREE_PUBLIC (fndecl) = 1;
604 :
605 : /* Mark it __attribute__((const)). */
606 659904 : TREE_READONLY (fndecl) = is_const;
607 :
608 659904 : rest_of_decl_compilation (fndecl, 1, 0);
609 :
610 659904 : 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 45120840 : add_simd_flag_for_built_in (tree fndecl)
618 : {
619 45120840 : if (gfc_vectorized_builtins == NULL
620 18121850 : || fndecl == NULL_TREE)
621 37288515 : return;
622 :
623 7832325 : const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
624 7832325 : int *clauses = gfc_vectorized_builtins->get (name);
625 7832325 : if (clauses)
626 : {
627 4913788 : for (unsigned i = 0; i < 3; i++)
628 3685341 : if (*clauses & (1 << i))
629 : {
630 1228452 : gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
631 1228452 : tree omp_clause = NULL_TREE;
632 1228452 : if (simd_type == SIMD_NONE)
633 : ; /* No SIMD clause. */
634 : else
635 : {
636 1228452 : omp_clause_code code
637 : = (simd_type == SIMD_INBRANCH
638 1228452 : ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
639 1228452 : omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
640 1228452 : omp_clause = build_tree_list (NULL_TREE, omp_clause);
641 : }
642 :
643 1228452 : DECL_ATTRIBUTES (fndecl)
644 2456904 : = tree_cons (get_identifier ("omp declare simd"), omp_clause,
645 1228452 : 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 76476 : gfc_adjust_builtins (void)
655 : {
656 76476 : gfc_intrinsic_map_t *m;
657 4588560 : for (m = gfc_intrinsic_map;
658 4588560 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
659 : {
660 4512084 : add_simd_flag_for_built_in (m->real4_decl);
661 4512084 : add_simd_flag_for_built_in (m->complex4_decl);
662 4512084 : add_simd_flag_for_built_in (m->real8_decl);
663 4512084 : add_simd_flag_for_built_in (m->complex8_decl);
664 4512084 : add_simd_flag_for_built_in (m->real10_decl);
665 4512084 : add_simd_flag_for_built_in (m->complex10_decl);
666 4512084 : add_simd_flag_for_built_in (m->real16_decl);
667 4512084 : add_simd_flag_for_built_in (m->complex16_decl);
668 4512084 : add_simd_flag_for_built_in (m->real16_decl);
669 4512084 : add_simd_flag_for_built_in (m->complex16_decl);
670 : }
671 :
672 : /* Release all strings. */
673 76476 : if (gfc_vectorized_builtins != NULL)
674 : {
675 1689116 : for (hash_map<nofree_string_hash, int>::iterator it
676 30715 : = gfc_vectorized_builtins->begin ();
677 1689116 : it != gfc_vectorized_builtins->end (); ++it)
678 1658401 : free (const_cast<char *> ((*it).first));
679 :
680 61430 : delete gfc_vectorized_builtins;
681 30715 : gfc_vectorized_builtins = NULL;
682 : }
683 76476 : }
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 31424 : gfc_build_intrinsic_lib_fndecls (void)
690 : {
691 31424 : gfc_intrinsic_map_t *m;
692 31424 : tree quad_decls[END_BUILTINS + 1];
693 :
694 31424 : 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 31424 : tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
701 31424 : tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
702 :
703 31424 : memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
704 :
705 31424 : type = gfc_float128_type_node;
706 31424 : complex_type = gfc_complex_float128_type_node;
707 : /* type (*) (type) */
708 31424 : func_1 = build_function_type_list (type, type, NULL_TREE);
709 : /* int (*) (type) */
710 31424 : func_iround = build_function_type_list (integer_type_node,
711 : type, NULL_TREE);
712 : /* long (*) (type) */
713 31424 : func_lround = build_function_type_list (long_integer_type_node,
714 : type, NULL_TREE);
715 : /* long long (*) (type) */
716 31424 : func_llround = build_function_type_list (long_long_integer_type_node,
717 : type, NULL_TREE);
718 : /* type (*) (type, type) */
719 31424 : func_2 = build_function_type_list (type, type, type, NULL_TREE);
720 : /* type (*) (type, type, type) */
721 31424 : func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
722 : /* type (*) (type, &int) */
723 31424 : func_frexp
724 31424 : = build_function_type_list (type,
725 : type,
726 : build_pointer_type (integer_type_node),
727 : NULL_TREE);
728 : /* type (*) (type, int) */
729 31424 : func_scalbn = build_function_type_list (type,
730 : type, integer_type_node, NULL_TREE);
731 : /* type (*) (complex type) */
732 31424 : func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
733 : /* complex type (*) (complex type, complex type) */
734 31424 : func_cpow
735 31424 : = 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 31424 : quad_decls[BUILT_IN_SQRT]
763 31424 : = define_quad_builtin (gfc_real16_use_iec_60559
764 : ? "sqrtf128" : "sqrtq", func_1, true);
765 : }
766 :
767 : /* Add GCC builtin functions. */
768 1854016 : for (m = gfc_intrinsic_map;
769 1885440 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
770 : {
771 1854016 : if (m->float_built_in != END_BUILTINS)
772 1728320 : m->real4_decl = builtin_decl_explicit (m->float_built_in);
773 1854016 : if (m->complex_float_built_in != END_BUILTINS)
774 502784 : m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
775 1854016 : if (m->double_built_in != END_BUILTINS)
776 1728320 : m->real8_decl = builtin_decl_explicit (m->double_built_in);
777 1854016 : if (m->complex_double_built_in != END_BUILTINS)
778 502784 : m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
779 :
780 : /* If real(kind=10) exists, it is always long double. */
781 1854016 : if (m->long_double_built_in != END_BUILTINS)
782 1728320 : m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
783 1854016 : if (m->complex_long_double_built_in != END_BUILTINS)
784 502784 : m->complex10_decl
785 502784 : = builtin_decl_explicit (m->complex_long_double_built_in);
786 :
787 1854016 : 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 1854016 : 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 659904 : m->real16_decl = quad_decls[m->double_built_in];
801 : }
802 1194112 : 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 31424 : }
809 :
810 :
811 : /* Create a fndecl for a simple intrinsic library function. */
812 :
813 : static tree
814 4405 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
815 : {
816 4405 : tree type;
817 4405 : vec<tree, va_gc> *argtypes;
818 4405 : tree fndecl;
819 4405 : gfc_actual_arglist *actual;
820 4405 : tree *pdecl;
821 4405 : gfc_typespec *ts;
822 4405 : char name[GFC_MAX_SYMBOL_LEN + 3];
823 :
824 4405 : ts = &expr->ts;
825 4405 : if (ts->type == BT_REAL)
826 : {
827 3561 : switch (ts->kind)
828 : {
829 1273 : case 4:
830 1273 : pdecl = &m->real4_decl;
831 1273 : break;
832 1272 : case 8:
833 1272 : pdecl = &m->real8_decl;
834 1272 : break;
835 574 : case 10:
836 574 : pdecl = &m->real10_decl;
837 574 : break;
838 442 : case 16:
839 442 : pdecl = &m->real16_decl;
840 442 : 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 4405 : if (*pdecl)
871 4066 : return *pdecl;
872 :
873 339 : if (m->libm_name)
874 : {
875 162 : int n = gfc_validate_kind (BT_REAL, ts->kind, false);
876 162 : 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 162 : 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 162 : 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 162 : else if (gfc_real_kinds[n].c_float128)
886 162 : snprintf (name, sizeof (name), "%s%s%s",
887 162 : ts->type == BT_COMPLEX ? "c" : "", m->name,
888 162 : 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 339 : argtypes = NULL;
900 694 : for (actual = expr->value.function.actual; actual; actual = actual->next)
901 : {
902 355 : type = gfc_typenode_for_spec (&actual->expr->ts);
903 355 : vec_safe_push (argtypes, type);
904 : }
905 1017 : type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
906 339 : fndecl = build_decl (input_location,
907 : FUNCTION_DECL, get_identifier (name), type);
908 :
909 : /* Mark the decl as external. */
910 339 : DECL_EXTERNAL (fndecl) = 1;
911 339 : TREE_PUBLIC (fndecl) = 1;
912 :
913 : /* Mark it __attribute__((const)), if possible. */
914 339 : TREE_READONLY (fndecl) = m->is_constant;
915 :
916 339 : rest_of_decl_compilation (fndecl, 1, 0);
917 :
918 339 : (*pdecl) = fndecl;
919 339 : return fndecl;
920 : }
921 :
922 :
923 : /* Convert an intrinsic function into an external or builtin call. */
924 :
925 : static void
926 3859 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
927 : {
928 3859 : gfc_intrinsic_map_t *m;
929 3859 : tree fndecl;
930 3859 : tree rettype;
931 3859 : tree *args;
932 3859 : unsigned int num_args;
933 3859 : gfc_isym_id id;
934 :
935 3859 : id = expr->value.function.isym->id;
936 : /* Find the entry for this function. */
937 79241 : for (m = gfc_intrinsic_map;
938 79241 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
939 : {
940 79241 : if (id == m->id)
941 : break;
942 : }
943 :
944 3859 : 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 3859 : num_args = gfc_intrinsic_argument_list_length (expr);
952 3859 : args = XALLOCAVEC (tree, num_args);
953 :
954 3859 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
955 3859 : fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
956 3859 : rettype = TREE_TYPE (TREE_TYPE (fndecl));
957 :
958 3859 : fndecl = build_addr (fndecl);
959 3859 : se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
960 3859 : }
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 1428 : conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
1032 : gfc_expr *hash)
1033 : {
1034 1428 : char *name;
1035 1428 : gfc_se argse;
1036 1428 : gfc_expr func_index;
1037 1428 : gfc_symtree *index_st;
1038 1428 : tree func_index_tree;
1039 1428 : stmtblock_t blk;
1040 :
1041 : /* Need to get namespace where static variables are possible. */
1042 1428 : while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
1043 0 : ns = ns->parent;
1044 1428 : gcc_assert (ns);
1045 :
1046 1428 : name = xasprintf (pat, caf_call_cnt);
1047 1428 : gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
1048 1428 : free (name);
1049 :
1050 1428 : index_st->n.sym->attr.flavor = FL_VARIABLE;
1051 1428 : index_st->n.sym->attr.save = SAVE_EXPLICIT;
1052 1428 : index_st->n.sym->value
1053 1428 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1054 : &gfc_current_locus);
1055 1428 : mpz_set_si (index_st->n.sym->value->value.integer, -1);
1056 1428 : index_st->n.sym->ts.type = BT_INTEGER;
1057 1428 : index_st->n.sym->ts.kind = gfc_default_integer_kind;
1058 1428 : gfc_set_sym_referenced (index_st->n.sym);
1059 1428 : memset (&func_index, 0, sizeof (gfc_expr));
1060 1428 : gfc_clear_ts (&func_index.ts);
1061 1428 : func_index.expr_type = EXPR_VARIABLE;
1062 1428 : func_index.symtree = index_st;
1063 1428 : func_index.ts = index_st->n.sym->ts;
1064 1428 : gfc_commit_symbol (index_st->n.sym);
1065 :
1066 1428 : gfc_init_se (&argse, NULL);
1067 1428 : gfc_conv_expr (&argse, &func_index);
1068 1428 : gfc_add_block_to_block (block, &argse.pre);
1069 1428 : func_index_tree = argse.expr;
1070 :
1071 1428 : gfc_init_se (&argse, NULL);
1072 1428 : gfc_conv_expr (&argse, hash);
1073 :
1074 1428 : gfc_init_block (&blk);
1075 1428 : gfc_add_modify (&blk, func_index_tree,
1076 : build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1,
1077 : argse.expr));
1078 1428 : 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 1428 : return func_index_tree;
1087 : }
1088 :
1089 : static tree
1090 1428 : conv_caf_add_call_data (stmtblock_t *blk, gfc_namespace *ns, const char *pat,
1091 : gfc_symbol *data_sym, tree *data_size)
1092 : {
1093 1428 : char *name;
1094 1428 : gfc_symtree *data_st;
1095 1428 : gfc_constructor *con;
1096 1428 : gfc_expr data, data_init;
1097 1428 : gfc_se argse;
1098 1428 : tree data_tree;
1099 :
1100 1428 : memset (&data, 0, sizeof (gfc_expr));
1101 1428 : gfc_clear_ts (&data.ts);
1102 1428 : data.expr_type = EXPR_VARIABLE;
1103 1428 : name = xasprintf (pat, caf_call_cnt);
1104 1428 : gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false));
1105 1428 : free (name);
1106 1428 : data_st->n.sym->attr.flavor = FL_VARIABLE;
1107 1428 : data_st->n.sym->ts = data_sym->ts;
1108 1428 : data.symtree = data_st;
1109 1428 : gfc_set_sym_referenced (data.symtree->n.sym);
1110 1428 : data.ts = data_st->n.sym->ts;
1111 1428 : gfc_commit_symbol (data_st->n.sym);
1112 :
1113 1428 : memset (&data_init, 0, sizeof (gfc_expr));
1114 1428 : gfc_clear_ts (&data_init.ts);
1115 1428 : data_init.expr_type = EXPR_STRUCTURE;
1116 1428 : data_init.ts = data.ts;
1117 1744 : for (gfc_component *comp = data.ts.u.derived->components; comp;
1118 316 : comp = comp->next)
1119 : {
1120 316 : con = gfc_constructor_get ();
1121 316 : con->expr = comp->initializer;
1122 316 : comp->initializer = NULL;
1123 316 : gfc_constructor_append (&data_init.value.constructor, con);
1124 : }
1125 :
1126 1428 : 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 1318 : data_tree = build_zero_cst (pvoid_type_node);
1141 1318 : *data_size = build_zero_cst (size_type_node);
1142 : }
1143 :
1144 1428 : 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 1261 : conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
1164 : tree *team_no)
1165 : {
1166 1261 : gfc_expr *stat_e, *team_e;
1167 :
1168 1261 : stat_e = gfc_find_stat_co (expr);
1169 1261 : 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 1228 : *stat = null_pointer_node;
1180 :
1181 1261 : team_e = gfc_find_team_co (expr, TEAM_TEAM);
1182 1261 : 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 1243 : *team = null_pointer_node;
1195 :
1196 1261 : team_e = gfc_find_team_co (expr, TEAM_NUMBER);
1197 1261 : 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 1231 : *team_no = null_pointer_node;
1211 1261 : }
1212 :
1213 : /* Get data from a remote coarray. */
1214 :
1215 : static void
1216 1000 : gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
1217 : bool may_realloc, symbol_attribute *caf_attr)
1218 : {
1219 1000 : gfc_expr *array_expr;
1220 1000 : 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 1000 : symbol_attribute caf_attr_store;
1224 1000 : gfc_namespace *ns;
1225 1000 : gfc_expr *get_fn_hash = expr->value.function.actual->next->expr,
1226 1000 : *get_fn_expr = expr->value.function.actual->next->next->expr;
1227 1000 : gfc_symbol *add_data_sym = get_fn_expr->symtree->n.sym->formal->sym;
1228 :
1229 1000 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1230 :
1231 1000 : 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 621 : array_expr = expr->value.function.actual->expr;
1239 621 : ns = array_expr->expr_type == EXPR_VARIABLE
1240 621 : && !array_expr->symtree->n.sym->attr.associate_var
1241 621 : ? array_expr->symtree->n.sym->ns
1242 : : gfc_current_ns;
1243 621 : type = gfc_typenode_for_spec (&array_expr->ts);
1244 :
1245 621 : if (caf_attr == NULL)
1246 : {
1247 621 : caf_attr_store = gfc_caf_attr (array_expr);
1248 621 : caf_attr = &caf_attr_store;
1249 : }
1250 :
1251 621 : res_var = lhs;
1252 :
1253 621 : conv_stat_and_team (&se->pre, expr, &stat, &team, &team_no);
1254 :
1255 621 : get_fn_index_tree
1256 621 : = conv_caf_func_index (&se->pre, ns, "__caf_get_from_remote_fn_index_%d",
1257 : get_fn_hash);
1258 621 : add_data_tree
1259 621 : = conv_caf_add_call_data (&se->pre, ns, "__caf_get_from_remote_add_data_%d",
1260 : add_data_sym, &add_data_size);
1261 621 : ++caf_call_cnt;
1262 :
1263 621 : if (array_expr->rank == 0)
1264 : {
1265 240 : res_var = gfc_create_var (type, "caf_res");
1266 240 : 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 207 : dest_size = res_var->typed.type->type_common.size_unit;
1277 207 : opt_src_charlen
1278 207 : = build_zero_cst (build_pointer_type (size_type_node));
1279 : }
1280 240 : dest_data
1281 240 : = gfc_evaluate_now (gfc_build_addr_expr (NULL_TREE, res_var), &se->pre);
1282 240 : res_var = build_fold_indirect_ref (dest_data);
1283 240 : dest_data = gfc_build_addr_expr (pvoid_type_node, dest_data);
1284 240 : 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 621 : opt_dest_charlen = opt_src_charlen;
1332 621 : caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1333 621 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1334 2 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1335 :
1336 621 : if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank
1337 621 : || GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)))
1338 540 : opt_src_desc = build_zero_cst (pvoid_type_node);
1339 : else
1340 81 : opt_src_desc = gfc_build_addr_expr (pvoid_type_node, caf_decl);
1341 :
1342 621 : image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1343 621 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, array_expr);
1344 :
1345 : /* It guarantees memory consistency within the same segment. */
1346 621 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1347 621 : 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 621 : ASM_VOLATILE_P (tmp) = 1;
1351 621 : gfc_add_expr_to_block (&se->pre, tmp);
1352 :
1353 621 : 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 621 : gfc_add_expr_to_block (&se->pre, tmp);
1360 :
1361 621 : if (se->ss)
1362 381 : gfc_advance_se_ss_chain (se);
1363 :
1364 621 : se->expr = res_var;
1365 :
1366 621 : 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 12427 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2286 : {
2287 12427 : gfc_se argse;
2288 :
2289 12427 : gfc_init_se (&argse, NULL);
2290 12427 : argse.data_not_needed = 1;
2291 12427 : argse.descriptor_only = 1;
2292 :
2293 12427 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2294 12427 : gfc_add_block_to_block (&se->pre, &argse.pre);
2295 12427 : gfc_add_block_to_block (&se->post, &argse.post);
2296 :
2297 12427 : se->expr = gfc_conv_descriptor_rank (argse.expr);
2298 12427 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2299 : se->expr);
2300 12427 : }
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 16130 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2410 : {
2411 16130 : gfc_actual_arglist *arg;
2412 16130 : gfc_actual_arglist *arg2;
2413 16130 : tree desc;
2414 16130 : tree type;
2415 16130 : tree bound;
2416 16130 : tree tmp;
2417 16130 : tree cond, cond1;
2418 16130 : tree ubound;
2419 16130 : tree lbound;
2420 16130 : tree size;
2421 16130 : gfc_se argse;
2422 16130 : gfc_array_spec * as;
2423 16130 : bool assumed_rank_lb_one;
2424 :
2425 16130 : arg = expr->value.function.actual;
2426 16130 : arg2 = arg->next;
2427 :
2428 16130 : if (se->ss)
2429 : {
2430 : /* Create an implicit second parameter from the loop variable. */
2431 7944 : gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2432 7944 : gcc_assert (se->loop->dimen == 1);
2433 7944 : gcc_assert (se->ss->info->expr == expr);
2434 7944 : gfc_advance_se_ss_chain (se);
2435 7944 : bound = se->loop->loopvar[0];
2436 7944 : 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 16130 : gfc_init_se (&argse, NULL);
2457 16130 : gfc_conv_expr_descriptor (&argse, arg->expr);
2458 16130 : gfc_add_block_to_block (&se->pre, &argse.pre);
2459 16130 : gfc_add_block_to_block (&se->post, &argse.post);
2460 :
2461 16130 : desc = argse.expr;
2462 :
2463 16130 : as = gfc_get_full_arrayspec_from_expr (arg->expr);
2464 :
2465 16130 : 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 16130 : if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2479 : {
2480 8924 : 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 15546 : assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2501 11061 : && ((arg->expr->ts.type != BT_CLASS
2502 1963 : && !arg->expr->symtree->n.sym->attr.allocatable
2503 1620 : && !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 16130 : ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2509 16130 : lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2510 16130 : size = fold_build2_loc (input_location, MINUS_EXPR,
2511 : gfc_array_index_type, ubound, lbound);
2512 16130 : 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 16130 : if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
2537 532 : se->expr = gfc_index_one_node;
2538 15598 : else if (as)
2539 : {
2540 15014 : 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 9668 : 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 4799 : else if (op == GFC_ISYM_SHAPE)
2567 4799 : 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 15014 : if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
2578 : {
2579 811 : tree minus_one = build_int_cst (gfc_array_index_type, -1);
2580 811 : tree rank = fold_convert (gfc_array_index_type,
2581 : gfc_conv_descriptor_rank (desc));
2582 811 : 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 811 : 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 811 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2592 : logical_type_node, ubound, minus_one);
2593 811 : cond = fold_build2_loc (input_location, EQ_EXPR,
2594 : logical_type_node, bound, rank);
2595 811 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2596 : logical_type_node, cond, cond1);
2597 811 : 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 584 : if (op != GFC_ISYM_LBOUND)
2605 : {
2606 482 : 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 16130 : type = gfc_typenode_for_spec (&expr->ts);
2616 16130 : se->expr = convert (type, se->expr);
2617 16130 : }
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 2250 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2800 : {
2801 2250 : gfc_actual_arglist *array_arg;
2802 2250 : gfc_actual_arglist *dim_arg;
2803 2250 : gfc_se argse;
2804 2250 : tree desc, tmp;
2805 :
2806 2250 : array_arg = expr->value.function.actual;
2807 2250 : dim_arg = array_arg->next;
2808 :
2809 2250 : gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2810 :
2811 2250 : gfc_init_se (&argse, NULL);
2812 2250 : gfc_conv_expr_descriptor (&argse, array_arg->expr);
2813 2250 : gfc_add_block_to_block (&se->pre, &argse.pre);
2814 2250 : gfc_add_block_to_block (&se->post, &argse.post);
2815 2250 : desc = argse.expr;
2816 :
2817 2250 : gcc_assert (dim_arg->expr);
2818 2250 : gfc_init_se (&argse, NULL);
2819 2250 : gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2820 2250 : gfc_add_block_to_block (&se->pre, &argse.pre);
2821 2250 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2822 : argse.expr, gfc_index_one_node);
2823 2250 : se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2824 2250 : }
2825 :
2826 : static void
2827 7836 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2828 : {
2829 7836 : tree arg, cabs;
2830 :
2831 7836 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2832 :
2833 7836 : switch (expr->value.function.actual->expr->ts.type)
2834 : {
2835 6830 : case BT_INTEGER:
2836 6830 : case BT_REAL:
2837 6830 : se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2838 : arg);
2839 6830 : 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 7836 : }
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 3630 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2894 : {
2895 3630 : tree type;
2896 3630 : tree tmp;
2897 3630 : tree test;
2898 3630 : tree test2;
2899 3630 : tree fmod;
2900 3630 : tree zero;
2901 3630 : tree args[2];
2902 :
2903 3630 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
2904 :
2905 3630 : switch (expr->ts.type)
2906 : {
2907 3477 : case BT_INTEGER:
2908 : /* Integer case is easy, we've got a builtin op. */
2909 3477 : type = TREE_TYPE (args[0]);
2910 :
2911 3477 : if (modulo)
2912 409 : se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2913 : args[0], args[1]);
2914 : else
2915 3068 : 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 1365 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3644 : {
3645 1365 : tree tmp;
3646 1365 : tree mvar;
3647 1365 : tree val;
3648 1365 : tree *args;
3649 1365 : tree type;
3650 1365 : tree argtype;
3651 1365 : gfc_actual_arglist *argexpr;
3652 1365 : unsigned int i, nargs;
3653 :
3654 1365 : nargs = gfc_intrinsic_argument_list_length (expr);
3655 1365 : args = XALLOCAVEC (tree, nargs);
3656 :
3657 1365 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3658 1365 : type = gfc_typenode_for_spec (&expr->ts);
3659 :
3660 : /* Only evaluate the argument once. */
3661 1365 : if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3662 368 : 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 1365 : argtype = TREE_TYPE (args[0]);
3667 1365 : argexpr = expr->value.function.actual;
3668 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3669 : {
3670 1584 : tree tmptype = TREE_TYPE (args[i]);
3671 1584 : if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
3672 1 : argtype = tmptype;
3673 : }
3674 1365 : mvar = gfc_create_var (argtype, "M");
3675 1365 : gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
3676 :
3677 1365 : argexpr = expr->value.function.actual;
3678 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3679 : {
3680 1584 : tree cond = NULL_TREE;
3681 1584 : val = args[i];
3682 :
3683 : /* Handle absent optional arguments by ignoring the comparison. */
3684 1584 : 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 1542 : 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 1584 : 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 1584 : tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
3705 1584 : calc = fold_build2_loc (input_location, code, argtype,
3706 : convert (argtype, val), mvar);
3707 1584 : tmp = build2_v (MODIFY_EXPR, mvar, calc);
3708 :
3709 1584 : if (cond != NULL_TREE)
3710 42 : tmp = build3_v (COND_EXPR, cond, tmp,
3711 : build_empty_stmt (input_location));
3712 1584 : gfc_add_expr_to_block (&se->pre, tmp);
3713 : }
3714 1365 : se->expr = convert (type, mvar);
3715 1365 : }
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 11270 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3770 : {
3771 11270 : gfc_symbol *sym;
3772 :
3773 : /* TODO: Add symbols for intrinsic function to the global namespace. */
3774 11270 : gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3775 11270 : sym = gfc_new_symbol (expr->value.function.name, NULL);
3776 :
3777 11270 : sym->ts = expr->ts;
3778 11270 : if (sym->ts.type == BT_CHARACTER)
3779 1784 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3780 11270 : sym->attr.external = 1;
3781 11270 : sym->attr.function = 1;
3782 11270 : sym->attr.always_explicit = 1;
3783 11270 : sym->attr.proc = PROC_INTRINSIC;
3784 11270 : sym->attr.flavor = FL_PROCEDURE;
3785 11270 : sym->result = sym;
3786 11270 : if (expr->rank > 0)
3787 : {
3788 9878 : sym->attr.dimension = 1;
3789 9878 : sym->as = gfc_get_array_spec ();
3790 9878 : sym->as->type = AS_ASSUMED_SHAPE;
3791 9878 : sym->as->rank = expr->rank;
3792 : }
3793 :
3794 11270 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3795 : ignore_optional ? expr->value.function.actual
3796 : : NULL);
3797 :
3798 11270 : 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 13716 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3915 : {
3916 13716 : gfc_symbol *sym;
3917 13716 : vec<tree, va_gc> *append_args;
3918 13716 : bool specific_symbol;
3919 :
3920 13716 : gcc_assert (!se->ss || se->ss->info->expr == expr);
3921 :
3922 13716 : if (se->ss)
3923 11762 : gcc_assert (expr->rank > 0);
3924 : else
3925 1954 : gcc_assert (expr->rank == 0);
3926 :
3927 13716 : 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 5439 : default:
3942 5439 : specific_symbol = false;
3943 : }
3944 :
3945 13716 : 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 5439 : 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 13716 : append_args = NULL;
3958 13716 : 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 12905 : 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 13716 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4009 : append_args);
4010 :
4011 13716 : if (specific_symbol)
4012 8277 : gfc_free_expr (expr);
4013 : else
4014 5439 : gfc_free_symbol (sym);
4015 13716 : }
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 38027 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4038 : {
4039 38027 : tree resvar;
4040 38027 : stmtblock_t block;
4041 38027 : stmtblock_t body;
4042 38027 : tree type;
4043 38027 : tree tmp;
4044 38027 : tree found;
4045 38027 : gfc_loopinfo loop;
4046 38027 : gfc_actual_arglist *actual;
4047 38027 : gfc_ss *arrayss;
4048 38027 : gfc_se arrayse;
4049 38027 : tree exit_label;
4050 :
4051 38027 : if (se->ss)
4052 : {
4053 0 : gfc_conv_intrinsic_funcall (se, expr);
4054 0 : return;
4055 : }
4056 :
4057 38027 : actual = expr->value.function.actual;
4058 38027 : type = gfc_typenode_for_spec (&expr->ts);
4059 : /* Initialize the result. */
4060 38027 : resvar = gfc_create_var (type, "test");
4061 38027 : if (op == EQ_EXPR)
4062 420 : tmp = convert (type, boolean_true_node);
4063 : else
4064 37607 : tmp = convert (type, boolean_false_node);
4065 38027 : gfc_add_modify (&se->pre, resvar, tmp);
4066 :
4067 : /* Walk the arguments. */
4068 38027 : arrayss = gfc_walk_expr (actual->expr);
4069 38027 : gcc_assert (arrayss != gfc_ss_terminator);
4070 :
4071 : /* Initialize the scalarizer. */
4072 38027 : gfc_init_loopinfo (&loop);
4073 38027 : exit_label = gfc_build_label_decl (NULL_TREE);
4074 38027 : TREE_USED (exit_label) = 1;
4075 38027 : gfc_add_ss_to_loop (&loop, arrayss);
4076 :
4077 : /* Initialize the loop. */
4078 38027 : gfc_conv_ss_startstride (&loop);
4079 38027 : gfc_conv_loop_setup (&loop, &expr->where);
4080 :
4081 38027 : gfc_mark_ss_chain_used (arrayss, 1);
4082 : /* Generate the loop body. */
4083 38027 : gfc_start_scalarized_body (&loop, &body);
4084 :
4085 : /* If the condition matches then set the return value. */
4086 38027 : gfc_start_block (&block);
4087 38027 : if (op == EQ_EXPR)
4088 420 : tmp = convert (type, boolean_false_node);
4089 : else
4090 37607 : tmp = convert (type, boolean_true_node);
4091 38027 : gfc_add_modify (&block, resvar, tmp);
4092 :
4093 : /* And break out of the loop. */
4094 38027 : tmp = build1_v (GOTO_EXPR, exit_label);
4095 38027 : gfc_add_expr_to_block (&block, tmp);
4096 :
4097 38027 : found = gfc_finish_block (&block);
4098 :
4099 : /* Check this element. */
4100 38027 : gfc_init_se (&arrayse, NULL);
4101 38027 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4102 38027 : arrayse.ss = arrayss;
4103 38027 : gfc_conv_expr_val (&arrayse, actual->expr);
4104 :
4105 38027 : gfc_add_block_to_block (&body, &arrayse.pre);
4106 38027 : tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4107 38027 : build_int_cst (TREE_TYPE (arrayse.expr), 0));
4108 38027 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4109 38027 : gfc_add_expr_to_block (&body, tmp);
4110 38027 : gfc_add_block_to_block (&body, &arrayse.post);
4111 :
4112 38027 : gfc_trans_scalarizing_loops (&loop, &body);
4113 :
4114 : /* Add the exit label. */
4115 38027 : tmp = build1_v (LABEL_EXPR, exit_label);
4116 38027 : gfc_add_expr_to_block (&loop.pre, tmp);
4117 :
4118 38027 : gfc_add_block_to_block (&se->pre, &loop.pre);
4119 38027 : gfc_add_block_to_block (&se->pre, &loop.post);
4120 38027 : gfc_cleanup_loop (&loop);
4121 :
4122 38027 : 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 2513 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4409 : bool norm2)
4410 : {
4411 2513 : tree resvar;
4412 2513 : tree scale = NULL_TREE;
4413 2513 : tree type;
4414 2513 : stmtblock_t body;
4415 2513 : stmtblock_t block;
4416 2513 : tree tmp;
4417 2513 : gfc_loopinfo loop, *ploop;
4418 2513 : gfc_actual_arglist *arg_array, *arg_mask;
4419 2513 : gfc_ss *arrayss = NULL;
4420 2513 : gfc_ss *maskss = NULL;
4421 2513 : gfc_se arrayse;
4422 2513 : gfc_se maskse;
4423 2513 : gfc_se *parent_se;
4424 2513 : gfc_expr *arrayexpr;
4425 2513 : gfc_expr *maskexpr;
4426 2513 : bool optional_mask;
4427 :
4428 2513 : 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 2513 : type = gfc_typenode_for_spec (&expr->ts);
4437 : /* Initialize the result. */
4438 2513 : resvar = gfc_create_var (type, "val");
4439 2513 : 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 2445 : else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4449 2027 : tmp = gfc_build_const (type, integer_zero_node);
4450 418 : else if (op == NE_EXPR)
4451 : /* PARITY. */
4452 36 : tmp = convert (type, boolean_false_node);
4453 382 : 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 358 : tmp = gfc_build_const (type, integer_one_node);
4458 :
4459 2513 : gfc_add_modify (&se->pre, resvar, tmp);
4460 :
4461 2513 : arg_array = expr->value.function.actual;
4462 :
4463 2513 : arrayexpr = arg_array->expr;
4464 :
4465 2513 : if (op == NE_EXPR || norm2)
4466 : {
4467 : /* PARITY and NORM2. */
4468 : maskexpr = NULL;
4469 : optional_mask = false;
4470 : }
4471 : else
4472 : {
4473 2409 : arg_mask = arg_array->next->next;
4474 2409 : gcc_assert (arg_mask != NULL);
4475 2409 : maskexpr = arg_mask->expr;
4476 371 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4477 266 : && maskexpr->symtree->n.sym->attr.dummy
4478 2427 : && maskexpr->symtree->n.sym->attr.optional;
4479 : }
4480 :
4481 2513 : if (expr->rank == 0)
4482 : {
4483 : /* Walk the arguments. */
4484 1935 : arrayss = gfc_walk_expr (arrayexpr);
4485 1935 : gcc_assert (arrayss != gfc_ss_terminator);
4486 :
4487 1935 : 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 1935 : 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 1935 : if (maskexpr && maskexpr->rank > 0)
4503 223 : gfc_add_ss_to_loop (&loop, maskss);
4504 1935 : gfc_add_ss_to_loop (&loop, arrayss);
4505 :
4506 : /* Initialize the loop. */
4507 1935 : gfc_conv_ss_startstride (&loop);
4508 1935 : gfc_conv_loop_setup (&loop, &expr->where);
4509 :
4510 1935 : if (maskexpr && maskexpr->rank > 0)
4511 223 : gfc_mark_ss_chain_used (maskss, 1);
4512 1935 : gfc_mark_ss_chain_used (arrayss, 1);
4513 :
4514 1935 : 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 2513 : gcc_assert (ploop);
4521 :
4522 : /* Generate the loop body. */
4523 2513 : gfc_start_scalarized_body (ploop, &body);
4524 :
4525 : /* If we have a mask, only add this element if the mask is set. */
4526 2513 : 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 2206 : gfc_init_block (&block);
4539 :
4540 : /* Do the actual summation/product. */
4541 2513 : gfc_init_se (&arrayse, parent_se);
4542 2513 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
4543 2513 : if (expr->rank == 0)
4544 1935 : arrayse.ss = arrayss;
4545 2513 : gfc_conv_expr_val (&arrayse, arrayexpr);
4546 2513 : gfc_add_block_to_block (&block, &arrayse.pre);
4547 :
4548 2513 : 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 2445 : tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4614 2445 : gfc_add_modify (&block, resvar, tmp);
4615 : }
4616 :
4617 2513 : gfc_add_block_to_block (&block, &arrayse.post);
4618 :
4619 2513 : 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 2206 : tmp = gfc_finish_block (&block);
4632 2513 : gfc_add_expr_to_block (&body, tmp);
4633 :
4634 2513 : gfc_trans_scalarizing_loops (ploop, &body);
4635 :
4636 : /* For a scalar mask, enclose the loop in an if statement. */
4637 2513 : 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 2449 : gfc_add_block_to_block (&se->pre, &ploop->pre);
4669 2449 : gfc_add_block_to_block (&se->pre, &ploop->post);
4670 : }
4671 :
4672 2513 : if (expr->rank == 0)
4673 1935 : gfc_cleanup_loop (ploop);
4674 :
4675 2513 : 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 2513 : se->expr = resvar;
4686 2513 : }
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 5831 : conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7605 : unsigned primary, unsigned optional)
7606 : {
7607 5831 : gfc_actual_arglist* prim_arg;
7608 5831 : gfc_actual_arglist* opt_arg;
7609 5831 : unsigned cur_pos;
7610 5831 : gfc_actual_arglist* arg;
7611 5831 : gfc_symbol* sym;
7612 5831 : vec<tree, va_gc> *append_args;
7613 :
7614 : /* Find the two arguments given as position. */
7615 5831 : cur_pos = 0;
7616 5831 : prim_arg = NULL;
7617 5831 : opt_arg = NULL;
7618 17493 : for (arg = expr->value.function.actual; arg; arg = arg->next)
7619 : {
7620 17493 : ++cur_pos;
7621 :
7622 17493 : if (cur_pos == primary)
7623 5831 : prim_arg = arg;
7624 17493 : if (cur_pos == optional)
7625 5831 : opt_arg = arg;
7626 :
7627 17493 : if (cur_pos >= primary && cur_pos >= optional)
7628 : break;
7629 : }
7630 5831 : gcc_assert (prim_arg);
7631 5831 : gcc_assert (prim_arg->expr);
7632 5831 : 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 5831 : append_args = NULL;
7637 5831 : 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 5831 : gcc_assert (!se->ignore_optional);
7648 5831 : sym = gfc_get_symbol_for_expr (expr, false);
7649 5831 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7650 : append_args);
7651 5831 : gfc_free_symbol (sym);
7652 5831 : }
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 2335 : gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7728 : {
7729 2335 : int kind = expr->value.function.actual->expr->ts.kind;
7730 2335 : tree args[2], type, fndecl;
7731 :
7732 2335 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7733 2335 : type = gfc_typenode_for_spec (&expr->ts);
7734 :
7735 2335 : if (kind == 1)
7736 1933 : 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 2335 : se->expr = build_call_expr_loc (input_location,
7743 : fndecl, 2, args[0], args[1]);
7744 2335 : se->expr = convert (type, se->expr);
7745 2335 : }
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 15133 : gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
8213 : {
8214 15133 : gfc_actual_arglist *actual;
8215 15133 : tree arg1;
8216 15133 : tree type;
8217 15133 : tree size;
8218 15133 : gfc_se argse;
8219 15133 : gfc_expr *e;
8220 15133 : gfc_symbol *sym = NULL;
8221 :
8222 15133 : gfc_init_se (&argse, NULL);
8223 15133 : actual = expr->value.function.actual;
8224 :
8225 15133 : if (actual->expr->ts.type == BT_CLASS)
8226 609 : gfc_add_class_array_ref (actual->expr);
8227 :
8228 15133 : 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 15133 : if (e->expr_type == EXPR_VARIABLE
8234 14657 : && e->symtree->n.sym->ns == NULL /* This is distinctive! */
8235 573 : && e->symtree->n.sym->ts.type == BT_CLASS
8236 62 : && e->ref && e->ref->type == REF_COMPONENT
8237 44 : && strcmp (e->ref->u.c.component->name, "_data") == 0)
8238 15133 : sym = e->symtree->n.sym;
8239 :
8240 15133 : 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 14279 : end_arg_check:
8287 :
8288 15133 : argse.data_not_needed = 1;
8289 15133 : 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 15126 : else if (sym && sym->backend_decl)
8297 : {
8298 32 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8299 32 : argse.expr = gfc_class_data_get (sym->backend_decl);
8300 : }
8301 : else
8302 15094 : gfc_conv_expr_descriptor (&argse, actual->expr);
8303 15133 : gfc_add_block_to_block (&se->pre, &argse.pre);
8304 15133 : gfc_add_block_to_block (&se->post, &argse.post);
8305 15133 : arg1 = argse.expr;
8306 :
8307 15133 : actual = actual->next;
8308 15133 : if (actual->expr)
8309 : {
8310 9027 : stmtblock_t block;
8311 9027 : gfc_init_block (&block);
8312 9027 : gfc_init_se (&argse, NULL);
8313 9027 : gfc_conv_expr_type (&argse, actual->expr,
8314 : gfc_array_index_type);
8315 9027 : gfc_add_block_to_block (&block, &argse.pre);
8316 9027 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8317 : argse.expr, gfc_index_one_node);
8318 9027 : 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 9027 : if (actual->expr->expr_type == EXPR_VARIABLE
8323 2392 : && 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 8996 : gfc_add_block_to_block (&se->pre, &block);
8352 : }
8353 : else
8354 6106 : size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8355 15133 : type = gfc_typenode_for_spec (&expr->ts);
8356 15133 : se->expr = convert (type, size);
8357 15133 : }
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 3730 : gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8678 : {
8679 3730 : tree tmp;
8680 3730 : tree tmpdecl;
8681 3730 : tree ptr;
8682 3730 : tree extent;
8683 3730 : tree source;
8684 3730 : tree source_type;
8685 3730 : tree source_bytes;
8686 3730 : tree mold_type;
8687 3730 : tree dest_word_len;
8688 3730 : tree size_words;
8689 3730 : tree size_bytes;
8690 3730 : tree upper;
8691 3730 : tree lower;
8692 3730 : tree stmt;
8693 3730 : tree class_ref = NULL_TREE;
8694 3730 : gfc_actual_arglist *arg;
8695 3730 : gfc_se argse;
8696 3730 : gfc_array_info *info;
8697 3730 : stmtblock_t block;
8698 3730 : int n;
8699 3730 : bool scalar_mold;
8700 3730 : gfc_expr *source_expr, *mold_expr, *class_expr;
8701 :
8702 3730 : info = NULL;
8703 3730 : 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 3730 : arg = expr->value.function.actual;
8710 3730 : source_expr = arg->expr;
8711 :
8712 : /* Ensure double transfer through LOGICAL preserves all
8713 : the needed bits. */
8714 3730 : if (arg->expr->expr_type == EXPR_FUNCTION
8715 2738 : && arg->expr->value.function.esym == NULL
8716 2720 : && arg->expr->value.function.isym != NULL
8717 2720 : && 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 3730 : gfc_init_se (&argse, NULL);
8723 :
8724 3730 : 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 3730 : if (arg->expr->rank == 0)
8728 : {
8729 3374 : gfc_conv_expr_reference (&argse, arg->expr);
8730 3374 : 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 3337 : source = argse.expr;
8754 :
8755 : /* Obtain the source word length. */
8756 3374 : 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 3043 : default:
8777 3043 : source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8778 : source));
8779 3043 : tmp = fold_convert (gfc_array_index_type,
8780 : size_in_bytes (source_type));
8781 3043 : 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 3730 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8869 3730 : gfc_add_block_to_block (&se->pre, &argse.pre);
8870 3730 : 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 3730 : arg = arg->next;
8876 3730 : mold_expr = arg->expr;
8877 :
8878 3730 : gfc_init_se (&argse, NULL);
8879 :
8880 3730 : scalar_mold = arg->expr->rank == 0;
8881 :
8882 3730 : if (arg->expr->rank == 0)
8883 : {
8884 3407 : gfc_conv_expr_reference (&argse, mold_expr);
8885 3407 : 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 3730 : gfc_add_block_to_block (&se->pre, &argse.pre);
8896 3730 : gfc_add_block_to_block (&se->post, &argse.post);
8897 :
8898 3730 : 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 3730 : 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 3257 : default:
8924 3257 : tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8925 3257 : 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 3730 : if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
8931 : dest_word_len = tmp;
8932 : else
8933 : {
8934 3676 : dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8935 3676 : gfc_add_modify (&se->pre, dest_word_len, tmp);
8936 : }
8937 :
8938 : /* Finally convert SIZE, if it is present. */
8939 3730 : arg = arg->next;
8940 3730 : size_words = gfc_create_var (gfc_array_index_type, NULL);
8941 :
8942 3730 : 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 3730 : if (scalar_mold && tmp == NULL_TREE)
8957 3258 : 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 3258 : scalar_transfer:
9040 3258 : extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9041 : dest_word_len, source_bytes);
9042 3258 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9043 : extent, gfc_index_zero_node);
9044 :
9045 3258 : 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 3066 : tmpdecl = gfc_create_var (mold_type, "transfer");
9097 :
9098 3066 : ptr = convert (build_pointer_type (mold_type), source);
9099 :
9100 : /* For CLASS results, allocate the needed memory first. */
9101 3066 : 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 3066 : if (mold_expr->ts.type == BT_CLASS)
9111 6 : tmp = gfc_class_data_get (tmpdecl);
9112 : else
9113 3060 : tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
9114 :
9115 3066 : 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 3066 : gfc_add_expr_to_block (&se->pre, tmp);
9121 :
9122 : /* For CLASS results, set the _vptr. */
9123 3066 : if (mold_expr->ts.type == BT_CLASS)
9124 6 : gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
9125 :
9126 3066 : 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 7367 : gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
9136 : {
9137 7367 : gfc_se arg1se;
9138 7367 : tree tmp;
9139 7367 : gfc_expr *e = expr->value.function.actual->expr;
9140 :
9141 7367 : gfc_init_se (&arg1se, NULL);
9142 7367 : 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 7367 : gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
9154 :
9155 7367 : if (e->rank == 0)
9156 : {
9157 : /* Allocatable scalar. */
9158 2876 : arg1se.want_pointer = 1;
9159 2876 : gfc_conv_expr (&arg1se, e);
9160 2876 : tmp = arg1se.expr;
9161 : }
9162 : else
9163 : {
9164 : /* Allocatable array. */
9165 4491 : arg1se.descriptor_only = 1;
9166 4491 : gfc_conv_expr_descriptor (&arg1se, e);
9167 4491 : tmp = gfc_conv_descriptor_data_get (arg1se.expr);
9168 : }
9169 :
9170 7367 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
9171 7367 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9172 :
9173 : /* Components of pointer array references sometimes come back with a pre block. */
9174 7367 : if (arg1se.pre.head)
9175 327 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9176 :
9177 7367 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9178 7367 : }
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 9448 : gfc_conv_associated (gfc_se *se, gfc_expr *expr)
9189 : {
9190 9448 : gfc_actual_arglist *arg1;
9191 9448 : gfc_actual_arglist *arg2;
9192 9448 : gfc_se arg1se;
9193 9448 : gfc_se arg2se;
9194 9448 : tree tmp2;
9195 9448 : tree tmp;
9196 9448 : tree nonzero_arraylen = NULL_TREE;
9197 9448 : gfc_ss *ss;
9198 9448 : bool scalar;
9199 :
9200 9448 : gfc_init_se (&arg1se, NULL);
9201 9448 : gfc_init_se (&arg2se, NULL);
9202 9448 : arg1 = expr->value.function.actual;
9203 9448 : 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 9448 : ss = gfc_walk_expr (arg1->expr);
9208 9448 : scalar = ss == gfc_ss_terminator;
9209 9448 : if (!scalar)
9210 3889 : gfc_free_ss_chain (ss);
9211 :
9212 9448 : if (!arg2->expr)
9213 : {
9214 : /* No optional target. */
9215 7071 : if (scalar)
9216 : {
9217 : /* A pointer to a scalar. */
9218 4634 : arg1se.want_pointer = 1;
9219 4634 : gfc_conv_expr (&arg1se, arg1->expr);
9220 4634 : 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 4634 : if (arg1->expr->ts.type == BT_CLASS)
9225 : {
9226 390 : tmp2 = gfc_class_data_get (arg1se.expr);
9227 390 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9228 0 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
9229 : }
9230 : else
9231 4244 : 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 7071 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9240 7071 : gfc_add_block_to_block (&se->post, &arg1se.post);
9241 7071 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9242 7071 : fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9243 7071 : se->expr = tmp;
9244 : }
9245 : else
9246 : {
9247 : /* An optional target. */
9248 2377 : if (arg2->expr->ts.type == BT_CLASS
9249 30 : && arg2->expr->expr_type != EXPR_FUNCTION)
9250 24 : gfc_add_data_component (arg2->expr);
9251 :
9252 2377 : if (scalar)
9253 : {
9254 : /* A pointer to a scalar. */
9255 925 : arg1se.want_pointer = 1;
9256 925 : gfc_conv_expr (&arg1se, arg1->expr);
9257 925 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9258 128 : && arg1->expr->symtree->n.sym->attr.dummy)
9259 42 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9260 : arg1se.expr);
9261 925 : if (arg1->expr->ts.type == BT_CLASS)
9262 252 : arg1se.expr = gfc_class_data_get (arg1se.expr);
9263 :
9264 925 : arg2se.want_pointer = 1;
9265 925 : gfc_conv_expr (&arg2se, arg2->expr);
9266 925 : if (arg2->expr->symtree->n.sym->attr.proc_pointer
9267 36 : && arg2->expr->symtree->n.sym->attr.dummy)
9268 0 : arg2se.expr = build_fold_indirect_ref_loc (input_location,
9269 : arg2se.expr);
9270 925 : 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 925 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9276 925 : gfc_add_block_to_block (&se->post, &arg1se.post);
9277 925 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9278 925 : gfc_add_block_to_block (&se->post, &arg2se.post);
9279 925 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9280 : arg1se.expr, arg2se.expr);
9281 925 : tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9282 : arg1se.expr, null_pointer_node);
9283 925 : 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 2377 : 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 9448 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9351 9448 : }
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 8816 : gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9818 : {
9819 8816 : tree temp_var;
9820 8816 : gfc_expr *arg_expr;
9821 :
9822 8816 : gcc_assert (!se->ss);
9823 :
9824 8816 : arg_expr = expr->value.function.actual->expr;
9825 8816 : if (arg_expr->rank == 0)
9826 : {
9827 6401 : if (arg_expr->ts.type == BT_CLASS)
9828 18 : gfc_add_data_component (arg_expr);
9829 6401 : gfc_conv_expr_reference (se, arg_expr);
9830 : }
9831 : else
9832 2415 : gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9833 8816 : 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 8816 : temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9838 8816 : gfc_add_modify (&se->pre, temp_var, se->expr);
9839 8816 : se->expr = temp_var;
9840 8816 : }
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 9571 : conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9879 : {
9880 9571 : gfc_actual_arglist *arg = expr->value.function.actual;
9881 :
9882 9571 : if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9883 : {
9884 7239 : if (arg->expr->rank == 0)
9885 1987 : gfc_conv_expr_reference (se, arg->expr);
9886 5252 : else if (gfc_is_simply_contiguous (arg->expr, false, false))
9887 4216 : 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 7239 : se->expr = convert (pvoid_type_node, se->expr);
9899 7239 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9900 : }
9901 2332 : else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9902 : {
9903 260 : gfc_conv_expr_reference (se, arg->expr);
9904 260 : if (arg->expr->symtree->n.sym->attr.proc_pointer
9905 29 : && arg->expr->symtree->n.sym->attr.dummy)
9906 7 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9907 : /* The code below is necessary to create a reference from the calling
9908 : subprogram to the argument of C_FUNLOC() in the call graph.
9909 : Please see PR 117303 for more details. */
9910 260 : se->expr = convert (pvoid_type_node, se->expr);
9911 260 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9912 : }
9913 2072 : else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9914 : {
9915 2030 : gfc_se arg1se;
9916 2030 : gfc_se arg2se;
9917 :
9918 : /* Build the addr_expr for the first argument. The argument is
9919 : already an *address* so we don't need to set want_pointer in
9920 : the gfc_se. */
9921 2030 : gfc_init_se (&arg1se, NULL);
9922 2030 : gfc_conv_expr (&arg1se, arg->expr);
9923 2030 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9924 2030 : gfc_add_block_to_block (&se->post, &arg1se.post);
9925 :
9926 : /* See if we were given two arguments. */
9927 2030 : if (arg->next->expr == NULL)
9928 : /* Only given one arg so generate a null and do a
9929 : not-equal comparison against the first arg. */
9930 1675 : se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9931 : arg1se.expr,
9932 1675 : fold_convert (TREE_TYPE (arg1se.expr),
9933 : null_pointer_node));
9934 : else
9935 : {
9936 355 : tree eq_expr;
9937 355 : tree not_null_expr;
9938 :
9939 : /* Given two arguments so build the arg2se from second arg. */
9940 355 : gfc_init_se (&arg2se, NULL);
9941 355 : gfc_conv_expr (&arg2se, arg->next->expr);
9942 355 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9943 355 : gfc_add_block_to_block (&se->post, &arg2se.post);
9944 :
9945 : /* Generate test to compare that the two args are equal. */
9946 355 : eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9947 : arg1se.expr, arg2se.expr);
9948 : /* Generate test to ensure that the first arg is not null. */
9949 355 : not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9950 : logical_type_node,
9951 : arg1se.expr, null_pointer_node);
9952 :
9953 : /* Finally, the generated test must check that both arg1 is not
9954 : NULL and that it is equal to the second arg. */
9955 355 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9956 : logical_type_node,
9957 : not_null_expr, eq_expr);
9958 : }
9959 : }
9960 42 : else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
9961 : {
9962 : /* There are three cases:
9963 : f_c_string(string) -> trim(string) // c_null_char
9964 : f_c_string(string, .false.) -> trim(string) // c_null_char
9965 : f_c_string(string, .true.) -> string // c_null_char */
9966 :
9967 42 : gfc_se lse, rse, tse;
9968 42 : tree len, tmp, var;
9969 42 : gfc_expr *string = arg->expr;
9970 42 : gfc_expr *asis = arg->next->expr;
9971 42 : gfc_expr *cnc;
9972 :
9973 : /* Convert string. */
9974 42 : gfc_init_se (&lse, se);
9975 42 : gfc_conv_expr (&lse, string);
9976 42 : gfc_conv_string_parameter (&lse);
9977 :
9978 : /* Create a string for C_NULL_CHAR and convert it. */
9979 42 : cnc = gfc_get_character_expr (gfc_default_character_kind,
9980 : &string->where, "\0", 1);
9981 42 : gfc_init_se (&rse, se);
9982 42 : gfc_conv_expr (&rse, cnc);
9983 42 : gfc_conv_string_parameter (&rse);
9984 42 : gfc_free_expr (cnc);
9985 :
9986 : #ifdef cnode
9987 : #undef cnode
9988 : #endif
9989 : #define cnode gfc_charlen_type_node
9990 42 : if (asis)
9991 : {
9992 30 : stmtblock_t block;
9993 30 : gfc_se asis_se, vse;
9994 30 : tree elen, evar, tlen, tvar;
9995 30 : tree else_branch, then_branch;
9996 :
9997 30 : elen = evar = tlen = tvar = NULL_TREE;
9998 :
9999 : /* f_c_string(string, .true.) -> string // c_null_char */
10000 :
10001 30 : gfc_init_block (&block);
10002 :
10003 30 : gfc_add_block_to_block (&block, &lse.pre);
10004 30 : gfc_add_block_to_block (&block, &rse.pre);
10005 :
10006 30 : tlen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
10007 : fold_convert (cnode, lse.string_length),
10008 : fold_convert (cnode, rse.string_length));
10009 :
10010 30 : gfc_init_se (&vse, se);
10011 30 : tvar = gfc_conv_string_tmp (&vse, pchar_type_node, tlen);
10012 30 : gfc_add_block_to_block (&block, &vse.pre);
10013 :
10014 30 : tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
10015 : 6, tlen, tvar,
10016 : lse.string_length, lse.expr,
10017 : rse.string_length, rse.expr);
10018 30 : gfc_add_expr_to_block (&block, tmp);
10019 :
10020 30 : then_branch = gfc_finish_block (&block);
10021 :
10022 : /* f_c_string(string, .false.) = trim(string) // c_null_char */
10023 :
10024 30 : gfc_init_block (&block);
10025 :
10026 30 : gfc_init_se (&tse, se);
10027 30 : conv_trim (&tse, &lse);
10028 30 : gfc_add_block_to_block (&block, &tse.pre);
10029 30 : gfc_add_block_to_block (&block, &rse.pre);
10030 :
10031 30 : elen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
10032 : fold_convert (cnode, tse.string_length),
10033 : fold_convert (cnode, rse.string_length));
10034 :
10035 30 : gfc_init_se (&vse, se);
10036 30 : evar = gfc_conv_string_tmp (&vse, pchar_type_node, elen);
10037 30 : gfc_add_block_to_block (&block, &vse.pre);
10038 :
10039 30 : tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
10040 : 6, elen, evar,
10041 : tse.string_length, tse.expr,
10042 : rse.string_length, rse.expr);
10043 30 : gfc_add_expr_to_block (&block, tmp);
10044 :
10045 30 : else_branch = gfc_finish_block (&block);
10046 :
10047 30 : gfc_init_se (&asis_se, se);
10048 30 : gfc_conv_expr (&asis_se, asis);
10049 30 : if (asis->expr_type == EXPR_VARIABLE
10050 18 : && asis->symtree->n.sym->attr.dummy
10051 6 : && asis->symtree->n.sym->attr.optional)
10052 : {
10053 6 : tree present = gfc_conv_expr_present (asis->symtree->n.sym);
10054 6 : asis_se.expr = build3_loc (input_location, COND_EXPR,
10055 : logical_type_node, present,
10056 : asis_se.expr,
10057 : build_int_cst (logical_type_node, 0));
10058 : }
10059 30 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10060 30 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10061 : asis_se.expr, then_branch, else_branch);
10062 :
10063 30 : gfc_add_expr_to_block (&se->pre, tmp);
10064 :
10065 30 : var = fold_build3_loc (input_location, COND_EXPR, pchar_type_node,
10066 : asis_se.expr, tvar, evar);
10067 30 : gfc_add_expr_to_block (&se->pre, var);
10068 :
10069 30 : len = fold_build3_loc (input_location, COND_EXPR, cnode,
10070 : asis_se.expr, tlen, elen);
10071 30 : gfc_add_expr_to_block (&se->pre, len);
10072 : }
10073 : else
10074 : {
10075 : /* f_c_string(string) = trim(string) // c_null_char */
10076 :
10077 12 : gfc_add_block_to_block (&se->pre, &lse.pre);
10078 12 : gfc_add_block_to_block (&se->pre, &rse.pre);
10079 :
10080 12 : gfc_init_se (&tse, se);
10081 12 : conv_trim (&tse, &lse);
10082 12 : gfc_add_block_to_block (&se->pre, &tse.pre);
10083 12 : gfc_add_block_to_block (&se->post, &tse.post);
10084 :
10085 12 : len = fold_build2_loc (input_location, PLUS_EXPR, cnode,
10086 : fold_convert (cnode, tse.string_length),
10087 : fold_convert (cnode, rse.string_length));
10088 :
10089 12 : var = gfc_conv_string_tmp (se, pchar_type_node, len);
10090 :
10091 12 : tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
10092 : 6, len, var,
10093 : tse.string_length, tse.expr,
10094 : rse.string_length, rse.expr);
10095 12 : gfc_add_expr_to_block (&se->pre, tmp);
10096 : }
10097 :
10098 42 : se->expr = var;
10099 42 : se->string_length = len;
10100 :
10101 : #undef cnode
10102 : }
10103 : else
10104 0 : gcc_unreachable ();
10105 9571 : }
10106 :
10107 :
10108 : /* The following routine generates code for the intrinsic
10109 : subroutines from the ISO_C_BINDING module:
10110 : * C_F_POINTER
10111 : * C_F_PROCPOINTER. */
10112 :
10113 : static tree
10114 3165 : conv_isocbinding_subroutine (gfc_code *code)
10115 : {
10116 3165 : gfc_expr *cptr, *fptr, *shape, *lower;
10117 3165 : gfc_se se, cptrse, fptrse, shapese, lowerse;
10118 3165 : gfc_ss *shape_ss, *lower_ss;
10119 3165 : tree desc, dim, tmp, stride, offset, lbound, ubound;
10120 3165 : stmtblock_t body, block;
10121 3165 : gfc_loopinfo loop;
10122 3165 : gfc_actual_arglist *arg;
10123 :
10124 3165 : arg = code->ext.actual;
10125 3165 : cptr = arg->expr;
10126 3165 : fptr = arg->next->expr;
10127 3165 : shape = arg->next->next ? arg->next->next->expr : NULL;
10128 3083 : lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
10129 :
10130 3165 : gfc_init_se (&se, NULL);
10131 3165 : gfc_init_se (&cptrse, NULL);
10132 3165 : gfc_conv_expr (&cptrse, cptr);
10133 3165 : gfc_add_block_to_block (&se.pre, &cptrse.pre);
10134 3165 : gfc_add_block_to_block (&se.post, &cptrse.post);
10135 :
10136 3165 : gfc_init_se (&fptrse, NULL);
10137 3165 : if (fptr->rank == 0)
10138 : {
10139 2680 : fptrse.want_pointer = 1;
10140 2680 : gfc_conv_expr (&fptrse, fptr);
10141 2680 : gfc_add_block_to_block (&se.pre, &fptrse.pre);
10142 2680 : gfc_add_block_to_block (&se.post, &fptrse.post);
10143 2680 : if (fptr->symtree->n.sym->attr.proc_pointer
10144 81 : && fptr->symtree->n.sym->attr.dummy)
10145 19 : fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
10146 2680 : se.expr
10147 2680 : = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
10148 : fptrse.expr,
10149 2680 : fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
10150 2680 : gfc_add_expr_to_block (&se.pre, se.expr);
10151 2680 : gfc_add_block_to_block (&se.pre, &se.post);
10152 2680 : return gfc_finish_block (&se.pre);
10153 : }
10154 :
10155 485 : gfc_start_block (&block);
10156 :
10157 : /* Get the descriptor of the Fortran pointer. */
10158 485 : fptrse.descriptor_only = 1;
10159 485 : gfc_conv_expr_descriptor (&fptrse, fptr);
10160 485 : gfc_add_block_to_block (&block, &fptrse.pre);
10161 485 : desc = fptrse.expr;
10162 :
10163 : /* Set the span field. */
10164 485 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
10165 485 : tmp = fold_convert (gfc_array_index_type, tmp);
10166 485 : gfc_conv_descriptor_span_set (&block, desc, tmp);
10167 :
10168 : /* Set data value, dtype, and offset. */
10169 485 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
10170 485 : gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
10171 485 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
10172 485 : gfc_get_dtype (TREE_TYPE (desc)));
10173 :
10174 : /* Start scalarization of the bounds, using the shape argument. */
10175 :
10176 485 : shape_ss = gfc_walk_expr (shape);
10177 485 : gcc_assert (shape_ss != gfc_ss_terminator);
10178 485 : gfc_init_se (&shapese, NULL);
10179 485 : if (lower)
10180 : {
10181 12 : lower_ss = gfc_walk_expr (lower);
10182 12 : gcc_assert (lower_ss != gfc_ss_terminator);
10183 12 : gfc_init_se (&lowerse, NULL);
10184 : }
10185 :
10186 485 : gfc_init_loopinfo (&loop);
10187 485 : gfc_add_ss_to_loop (&loop, shape_ss);
10188 485 : if (lower)
10189 12 : gfc_add_ss_to_loop (&loop, lower_ss);
10190 485 : gfc_conv_ss_startstride (&loop);
10191 485 : gfc_conv_loop_setup (&loop, &fptr->where);
10192 485 : gfc_mark_ss_chain_used (shape_ss, 1);
10193 485 : if (lower)
10194 12 : gfc_mark_ss_chain_used (lower_ss, 1);
10195 :
10196 485 : gfc_copy_loopinfo_to_se (&shapese, &loop);
10197 485 : shapese.ss = shape_ss;
10198 485 : if (lower)
10199 : {
10200 12 : gfc_copy_loopinfo_to_se (&lowerse, &loop);
10201 12 : lowerse.ss = lower_ss;
10202 : }
10203 :
10204 485 : stride = gfc_create_var (gfc_array_index_type, "stride");
10205 485 : offset = gfc_create_var (gfc_array_index_type, "offset");
10206 485 : gfc_add_modify (&block, stride, gfc_index_one_node);
10207 485 : gfc_add_modify (&block, offset, gfc_index_zero_node);
10208 :
10209 : /* Loop body. */
10210 485 : gfc_start_scalarized_body (&loop, &body);
10211 :
10212 485 : dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10213 : loop.loopvar[0], loop.from[0]);
10214 :
10215 485 : if (lower)
10216 : {
10217 12 : gfc_conv_expr (&lowerse, lower);
10218 12 : gfc_add_block_to_block (&body, &lowerse.pre);
10219 12 : lbound = fold_convert (gfc_array_index_type, lowerse.expr);
10220 12 : gfc_add_block_to_block (&body, &lowerse.post);
10221 : }
10222 : else
10223 473 : lbound = gfc_index_one_node;
10224 :
10225 : /* Set bounds and stride. */
10226 485 : gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
10227 485 : gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
10228 :
10229 485 : gfc_conv_expr (&shapese, shape);
10230 485 : gfc_add_block_to_block (&body, &shapese.pre);
10231 485 : ubound = fold_build2_loc (
10232 : input_location, MINUS_EXPR, gfc_array_index_type,
10233 : fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
10234 : fold_convert (gfc_array_index_type, shapese.expr)),
10235 : gfc_index_one_node);
10236 485 : gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
10237 485 : gfc_add_block_to_block (&body, &shapese.post);
10238 :
10239 : /* Calculate offset. */
10240 485 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10241 : stride, lbound);
10242 485 : gfc_add_modify (&body, offset,
10243 : fold_build2_loc (input_location, PLUS_EXPR,
10244 : gfc_array_index_type, offset, tmp));
10245 :
10246 : /* Update stride. */
10247 485 : gfc_add_modify (
10248 : &body, stride,
10249 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
10250 : fold_convert (gfc_array_index_type, shapese.expr)));
10251 : /* Finish scalarization loop. */
10252 485 : gfc_trans_scalarizing_loops (&loop, &body);
10253 485 : gfc_add_block_to_block (&block, &loop.pre);
10254 485 : gfc_add_block_to_block (&block, &loop.post);
10255 485 : gfc_add_block_to_block (&block, &fptrse.post);
10256 485 : gfc_cleanup_loop (&loop);
10257 :
10258 485 : gfc_add_modify (&block, offset,
10259 : fold_build1_loc (input_location, NEGATE_EXPR,
10260 : gfc_array_index_type, offset));
10261 485 : gfc_conv_descriptor_offset_set (&block, desc, offset);
10262 :
10263 485 : gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
10264 485 : gfc_add_block_to_block (&se.pre, &se.post);
10265 485 : return gfc_finish_block (&se.pre);
10266 : }
10267 :
10268 :
10269 : /* Save and restore floating-point state. */
10270 :
10271 : tree
10272 947 : gfc_save_fp_state (stmtblock_t *block)
10273 : {
10274 947 : tree type, fpstate, tmp;
10275 :
10276 947 : type = build_array_type (char_type_node,
10277 : build_range_type (size_type_node, size_zero_node,
10278 : size_int (GFC_FPE_STATE_BUFFER_SIZE)));
10279 947 : fpstate = gfc_create_var (type, "fpstate");
10280 947 : fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
10281 :
10282 947 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
10283 : 1, fpstate);
10284 947 : gfc_add_expr_to_block (block, tmp);
10285 :
10286 947 : return fpstate;
10287 : }
10288 :
10289 :
10290 : void
10291 947 : gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
10292 : {
10293 947 : tree tmp;
10294 :
10295 947 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
10296 : 1, fpstate);
10297 947 : gfc_add_expr_to_block (block, tmp);
10298 947 : }
10299 :
10300 :
10301 : /* Generate code for arguments of IEEE functions. */
10302 :
10303 : static void
10304 12457 : conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
10305 : int nargs)
10306 : {
10307 12457 : gfc_actual_arglist *actual;
10308 12457 : gfc_expr *e;
10309 12457 : gfc_se argse;
10310 12457 : int arg;
10311 :
10312 12457 : actual = expr->value.function.actual;
10313 34461 : for (arg = 0; arg < nargs; arg++, actual = actual->next)
10314 : {
10315 22004 : gcc_assert (actual);
10316 22004 : e = actual->expr;
10317 :
10318 22004 : gfc_init_se (&argse, se);
10319 22004 : gfc_conv_expr_val (&argse, e);
10320 :
10321 22004 : gfc_add_block_to_block (&se->pre, &argse.pre);
10322 22004 : gfc_add_block_to_block (&se->post, &argse.post);
10323 22004 : argarray[arg] = argse.expr;
10324 : }
10325 12457 : }
10326 :
10327 :
10328 : /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
10329 : and IEEE_UNORDERED, which translate directly to GCC type-generic
10330 : built-ins. */
10331 :
10332 : static void
10333 1062 : conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
10334 : enum built_in_function code, int nargs)
10335 : {
10336 1062 : tree args[2];
10337 1062 : gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
10338 :
10339 1062 : conv_ieee_function_args (se, expr, args, nargs);
10340 1062 : se->expr = build_call_expr_loc_array (input_location,
10341 : builtin_decl_explicit (code),
10342 : nargs, args);
10343 2388 : STRIP_TYPE_NOPS (se->expr);
10344 1062 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10345 1062 : }
10346 :
10347 :
10348 : /* Generate code for intrinsics IEEE_SIGNBIT. */
10349 :
10350 : static void
10351 624 : conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
10352 : {
10353 624 : tree arg, signbit;
10354 :
10355 624 : conv_ieee_function_args (se, expr, &arg, 1);
10356 624 : signbit = build_call_expr_loc (input_location,
10357 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10358 : 1, arg);
10359 624 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10360 : signbit, integer_zero_node);
10361 624 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
10362 624 : }
10363 :
10364 :
10365 : /* Generate code for IEEE_IS_NORMAL intrinsic:
10366 : IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
10367 :
10368 : static void
10369 312 : conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
10370 : {
10371 312 : tree arg, isnormal, iszero;
10372 :
10373 : /* Convert arg, evaluate it only once. */
10374 312 : conv_ieee_function_args (se, expr, &arg, 1);
10375 312 : arg = gfc_evaluate_now (arg, &se->pre);
10376 :
10377 312 : isnormal = build_call_expr_loc (input_location,
10378 : builtin_decl_explicit (BUILT_IN_ISNORMAL),
10379 : 1, arg);
10380 312 : iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
10381 312 : build_real_from_int_cst (TREE_TYPE (arg),
10382 312 : integer_zero_node));
10383 312 : se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10384 : logical_type_node, isnormal, iszero);
10385 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10386 312 : }
10387 :
10388 :
10389 : /* Generate code for IEEE_IS_NEGATIVE intrinsic:
10390 : IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10391 :
10392 : static void
10393 312 : conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
10394 : {
10395 312 : tree arg, signbit, isnan;
10396 :
10397 : /* Convert arg, evaluate it only once. */
10398 312 : conv_ieee_function_args (se, expr, &arg, 1);
10399 312 : arg = gfc_evaluate_now (arg, &se->pre);
10400 :
10401 312 : isnan = build_call_expr_loc (input_location,
10402 : builtin_decl_explicit (BUILT_IN_ISNAN),
10403 : 1, arg);
10404 936 : STRIP_TYPE_NOPS (isnan);
10405 :
10406 312 : signbit = build_call_expr_loc (input_location,
10407 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10408 : 1, arg);
10409 312 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10410 : signbit, integer_zero_node);
10411 :
10412 312 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10413 : logical_type_node, signbit,
10414 : fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10415 312 : TREE_TYPE(isnan), isnan));
10416 :
10417 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10418 312 : }
10419 :
10420 :
10421 : /* Generate code for IEEE_LOGB and IEEE_RINT. */
10422 :
10423 : static void
10424 240 : conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
10425 : enum built_in_function code)
10426 : {
10427 240 : tree arg, decl, call, fpstate;
10428 240 : int argprec;
10429 :
10430 240 : conv_ieee_function_args (se, expr, &arg, 1);
10431 240 : argprec = TYPE_PRECISION (TREE_TYPE (arg));
10432 240 : decl = builtin_decl_for_precision (code, argprec);
10433 :
10434 : /* Save floating-point state. */
10435 240 : fpstate = gfc_save_fp_state (&se->pre);
10436 :
10437 : /* Make the function call. */
10438 240 : call = build_call_expr_loc (input_location, decl, 1, arg);
10439 240 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
10440 :
10441 : /* Restore floating-point state. */
10442 240 : gfc_restore_fp_state (&se->post, fpstate);
10443 240 : }
10444 :
10445 :
10446 : /* Generate code for IEEE_REM. */
10447 :
10448 : static void
10449 84 : conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
10450 : {
10451 84 : tree args[2], decl, call, fpstate;
10452 84 : int argprec;
10453 :
10454 84 : conv_ieee_function_args (se, expr, args, 2);
10455 :
10456 : /* If arguments have unequal size, convert them to the larger. */
10457 84 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
10458 84 : > TYPE_PRECISION (TREE_TYPE (args[1])))
10459 6 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10460 78 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
10461 78 : > TYPE_PRECISION (TREE_TYPE (args[0])))
10462 24 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
10463 :
10464 84 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10465 84 : decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
10466 :
10467 : /* Save floating-point state. */
10468 84 : fpstate = gfc_save_fp_state (&se->pre);
10469 :
10470 : /* Make the function call. */
10471 84 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10472 84 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10473 :
10474 : /* Restore floating-point state. */
10475 84 : gfc_restore_fp_state (&se->post, fpstate);
10476 84 : }
10477 :
10478 :
10479 : /* Generate code for IEEE_NEXT_AFTER. */
10480 :
10481 : static void
10482 180 : conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
10483 : {
10484 180 : tree args[2], decl, call, fpstate;
10485 180 : int argprec;
10486 :
10487 180 : conv_ieee_function_args (se, expr, args, 2);
10488 :
10489 : /* Result has the characteristics of first argument. */
10490 180 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10491 180 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10492 180 : decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
10493 :
10494 : /* Save floating-point state. */
10495 180 : fpstate = gfc_save_fp_state (&se->pre);
10496 :
10497 : /* Make the function call. */
10498 180 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10499 180 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10500 :
10501 : /* Restore floating-point state. */
10502 180 : gfc_restore_fp_state (&se->post, fpstate);
10503 180 : }
10504 :
10505 :
10506 : /* Generate code for IEEE_SCALB. */
10507 :
10508 : static void
10509 228 : conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10510 : {
10511 228 : tree args[2], decl, call, huge, type;
10512 228 : int argprec, n;
10513 :
10514 228 : conv_ieee_function_args (se, expr, args, 2);
10515 :
10516 : /* Result has the characteristics of first argument. */
10517 228 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10518 228 : decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10519 :
10520 228 : if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10521 : {
10522 : /* We need to fold the integer into the range of a C int. */
10523 18 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10524 18 : type = TREE_TYPE (args[1]);
10525 :
10526 18 : n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10527 18 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10528 : gfc_c_int_kind);
10529 18 : huge = fold_convert (type, huge);
10530 18 : args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10531 : huge);
10532 18 : args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10533 : fold_build1_loc (input_location, NEGATE_EXPR,
10534 : type, huge));
10535 : }
10536 :
10537 228 : args[1] = fold_convert (integer_type_node, args[1]);
10538 :
10539 : /* Make the function call. */
10540 228 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10541 228 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10542 228 : }
10543 :
10544 :
10545 : /* Generate code for IEEE_COPY_SIGN. */
10546 :
10547 : static void
10548 576 : conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10549 : {
10550 576 : tree args[2], decl, sign;
10551 576 : int argprec;
10552 :
10553 576 : conv_ieee_function_args (se, expr, args, 2);
10554 :
10555 : /* Get the sign of the second argument. */
10556 576 : sign = build_call_expr_loc (input_location,
10557 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10558 : 1, args[1]);
10559 576 : sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10560 : sign, integer_zero_node);
10561 :
10562 : /* Create a value of one, with the right sign. */
10563 576 : sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10564 : sign,
10565 : fold_build1_loc (input_location, NEGATE_EXPR,
10566 : integer_type_node,
10567 : integer_one_node),
10568 : integer_one_node);
10569 576 : args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10570 :
10571 576 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10572 576 : decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10573 :
10574 576 : se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10575 576 : }
10576 :
10577 :
10578 : /* Generate code for IEEE_CLASS. */
10579 :
10580 : static void
10581 648 : conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10582 : {
10583 648 : tree arg, c, t1, t2, t3, t4;
10584 :
10585 : /* Convert arg, evaluate it only once. */
10586 648 : conv_ieee_function_args (se, expr, &arg, 1);
10587 648 : arg = gfc_evaluate_now (arg, &se->pre);
10588 :
10589 648 : c = build_call_expr_loc (input_location,
10590 : builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
10591 : build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10592 : build_int_cst (integer_type_node,
10593 : IEEE_POSITIVE_INF),
10594 : build_int_cst (integer_type_node,
10595 : IEEE_POSITIVE_NORMAL),
10596 : build_int_cst (integer_type_node,
10597 : IEEE_POSITIVE_DENORMAL),
10598 : build_int_cst (integer_type_node,
10599 : IEEE_POSITIVE_ZERO),
10600 : arg);
10601 648 : c = gfc_evaluate_now (c, &se->pre);
10602 648 : t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10603 : c, build_int_cst (integer_type_node,
10604 : IEEE_QUIET_NAN));
10605 648 : t2 = build_call_expr_loc (input_location,
10606 : builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
10607 : arg);
10608 648 : t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10609 648 : t2, build_zero_cst (TREE_TYPE (t2)));
10610 648 : t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10611 : logical_type_node, t1, t2);
10612 648 : t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10613 : c, build_int_cst (integer_type_node,
10614 : IEEE_POSITIVE_ZERO));
10615 648 : t4 = build_call_expr_loc (input_location,
10616 : builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
10617 : arg);
10618 648 : t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10619 648 : t4, build_zero_cst (TREE_TYPE (t4)));
10620 648 : t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10621 : logical_type_node, t3, t4);
10622 648 : int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10623 648 : gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10624 648 : gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10625 648 : gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10626 648 : gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10627 648 : gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10628 648 : t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10629 648 : build_int_cst (TREE_TYPE (c), s), c);
10630 648 : t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10631 : t3, t4, c);
10632 648 : t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10633 648 : build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10634 : t3);
10635 648 : tree type = gfc_typenode_for_spec (&expr->ts);
10636 : /* Perform a quick sanity check that the return type is
10637 : IEEE_CLASS_TYPE derived type defined in
10638 : libgfortran/ieee/ieee_arithmetic.F90
10639 : Primarily check that it is a derived type with a single
10640 : member in it. */
10641 648 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10642 648 : tree field = NULL_TREE;
10643 1296 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10644 648 : if (TREE_CODE (f) == FIELD_DECL)
10645 : {
10646 648 : gcc_assert (field == NULL_TREE);
10647 : field = f;
10648 : }
10649 648 : gcc_assert (field);
10650 648 : t1 = fold_convert (TREE_TYPE (field), t1);
10651 648 : se->expr = build_constructor_single (type, field, t1);
10652 648 : }
10653 :
10654 :
10655 : /* Generate code for IEEE_VALUE. */
10656 :
10657 : static void
10658 1111 : conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10659 : {
10660 1111 : tree args[2], arg, ret, tmp;
10661 1111 : stmtblock_t body;
10662 :
10663 : /* Convert args, evaluate the second one only once. */
10664 1111 : conv_ieee_function_args (se, expr, args, 2);
10665 1111 : arg = gfc_evaluate_now (args[1], &se->pre);
10666 :
10667 1111 : tree type = TREE_TYPE (arg);
10668 : /* Perform a quick sanity check that the second argument's type is
10669 : IEEE_CLASS_TYPE derived type defined in
10670 : libgfortran/ieee/ieee_arithmetic.F90
10671 : Primarily check that it is a derived type with a single
10672 : member in it. */
10673 1111 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10674 1111 : tree field = NULL_TREE;
10675 2222 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10676 1111 : if (TREE_CODE (f) == FIELD_DECL)
10677 : {
10678 1111 : gcc_assert (field == NULL_TREE);
10679 : field = f;
10680 : }
10681 1111 : gcc_assert (field);
10682 1111 : arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10683 : arg, field, NULL_TREE);
10684 1111 : arg = gfc_evaluate_now (arg, &se->pre);
10685 :
10686 1111 : type = gfc_typenode_for_spec (&expr->ts);
10687 1111 : gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10688 1111 : ret = gfc_create_var (type, NULL);
10689 :
10690 1111 : gfc_init_block (&body);
10691 :
10692 1111 : tree end_label = gfc_build_label_decl (NULL_TREE);
10693 12221 : for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10694 : {
10695 11110 : tree label = gfc_build_label_decl (NULL_TREE);
10696 11110 : tree low = build_int_cst (TREE_TYPE (arg), c);
10697 11110 : tmp = build_case_label (low, low, label);
10698 11110 : gfc_add_expr_to_block (&body, tmp);
10699 :
10700 11110 : REAL_VALUE_TYPE real;
10701 11110 : int k;
10702 11110 : switch (c)
10703 : {
10704 1111 : case IEEE_SIGNALING_NAN:
10705 1111 : real_nan (&real, "", 0, TYPE_MODE (type));
10706 1111 : break;
10707 1111 : case IEEE_QUIET_NAN:
10708 1111 : real_nan (&real, "", 1, TYPE_MODE (type));
10709 1111 : break;
10710 1111 : case IEEE_NEGATIVE_INF:
10711 1111 : real_inf (&real);
10712 1111 : real = real_value_negate (&real);
10713 1111 : break;
10714 1111 : case IEEE_NEGATIVE_NORMAL:
10715 1111 : real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10716 1111 : break;
10717 1111 : case IEEE_NEGATIVE_DENORMAL:
10718 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10719 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10720 : type, GFC_RND_MODE);
10721 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10722 1111 : real = real_value_negate (&real);
10723 1111 : break;
10724 1111 : case IEEE_NEGATIVE_ZERO:
10725 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10726 1111 : real = real_value_negate (&real);
10727 1111 : break;
10728 1111 : case IEEE_POSITIVE_ZERO:
10729 : /* Make this also the default: label. The other possibility
10730 : would be to add a separate default: label followed by
10731 : __builtin_unreachable (). */
10732 1111 : label = gfc_build_label_decl (NULL_TREE);
10733 1111 : tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10734 1111 : gfc_add_expr_to_block (&body, tmp);
10735 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10736 1111 : break;
10737 1111 : case IEEE_POSITIVE_DENORMAL:
10738 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10739 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10740 : type, GFC_RND_MODE);
10741 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10742 1111 : break;
10743 1111 : case IEEE_POSITIVE_NORMAL:
10744 1111 : real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10745 1111 : break;
10746 1111 : case IEEE_POSITIVE_INF:
10747 1111 : real_inf (&real);
10748 1111 : break;
10749 : default:
10750 : gcc_unreachable ();
10751 : }
10752 :
10753 11110 : tree val = build_real (type, real);
10754 11110 : gfc_add_modify (&body, ret, val);
10755 :
10756 11110 : tmp = build1_v (GOTO_EXPR, end_label);
10757 11110 : gfc_add_expr_to_block (&body, tmp);
10758 : }
10759 :
10760 1111 : tmp = gfc_finish_block (&body);
10761 1111 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10762 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10763 :
10764 1111 : tmp = build1_v (LABEL_EXPR, end_label);
10765 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10766 :
10767 1111 : se->expr = ret;
10768 1111 : }
10769 :
10770 :
10771 : /* Generate code for IEEE_FMA. */
10772 :
10773 : static void
10774 120 : conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10775 : {
10776 120 : tree args[3], decl, call;
10777 120 : int argprec;
10778 :
10779 120 : conv_ieee_function_args (se, expr, args, 3);
10780 :
10781 : /* All three arguments should have the same type. */
10782 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10783 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10784 :
10785 : /* Call the type-generic FMA built-in. */
10786 120 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10787 120 : decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
10788 120 : call = build_call_expr_loc_array (input_location, decl, 3, args);
10789 :
10790 : /* Convert to the final type. */
10791 120 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10792 120 : }
10793 :
10794 :
10795 : /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10796 :
10797 : static void
10798 3072 : conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10799 : const char *name)
10800 : {
10801 3072 : tree args[2], func;
10802 3072 : built_in_function fn;
10803 :
10804 3072 : conv_ieee_function_args (se, expr, args, 2);
10805 3072 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10806 3072 : args[0] = gfc_evaluate_now (args[0], &se->pre);
10807 3072 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10808 :
10809 3072 : if (startswith (name, "mag"))
10810 : {
10811 : /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10812 : fminmag() and fmaxmag(), which do not exist as built-ins.
10813 :
10814 : Following glibc, we emit this:
10815 :
10816 : fminmag (x, y) {
10817 : ax = ABS (x);
10818 : ay = ABS (y);
10819 : if (isless (ax, ay))
10820 : return x;
10821 : else if (isgreater (ax, ay))
10822 : return y;
10823 : else if (ax == ay)
10824 : return x < y ? x : y;
10825 : else if (issignaling (x) || issignaling (y))
10826 : return x + y;
10827 : else
10828 : return isnan (y) ? x : y;
10829 : }
10830 :
10831 : fmaxmag (x, y) {
10832 : ax = ABS (x);
10833 : ay = ABS (y);
10834 : if (isgreater (ax, ay))
10835 : return x;
10836 : else if (isless (ax, ay))
10837 : return y;
10838 : else if (ax == ay)
10839 : return x > y ? x : y;
10840 : else if (issignaling (x) || issignaling (y))
10841 : return x + y;
10842 : else
10843 : return isnan (y) ? x : y;
10844 : }
10845 :
10846 : */
10847 :
10848 1536 : tree abs0, abs1, sig0, sig1;
10849 1536 : tree cond1, cond2, cond3, cond4, cond5;
10850 1536 : tree res;
10851 1536 : tree type = TREE_TYPE (args[0]);
10852 :
10853 1536 : func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
10854 1536 : abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
10855 1536 : abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
10856 1536 : abs0 = gfc_evaluate_now (abs0, &se->pre);
10857 1536 : abs1 = gfc_evaluate_now (abs1, &se->pre);
10858 :
10859 1536 : cond5 = build_call_expr_loc (input_location,
10860 : builtin_decl_explicit (BUILT_IN_ISNAN),
10861 : 1, args[1]);
10862 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
10863 : args[0], args[1]);
10864 :
10865 1536 : sig0 = build_call_expr_loc (input_location,
10866 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
10867 : 1, args[0]);
10868 1536 : sig1 = build_call_expr_loc (input_location,
10869 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
10870 : 1, args[1]);
10871 1536 : cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
10872 : logical_type_node, sig0, sig1);
10873 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
10874 : fold_build2_loc (input_location, PLUS_EXPR,
10875 : type, args[0], args[1]),
10876 : res);
10877 :
10878 1536 : cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10879 : abs0, abs1);
10880 2304 : res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
10881 : fold_build2_loc (input_location,
10882 : max ? MAX_EXPR : MIN_EXPR,
10883 : type, args[0], args[1]),
10884 : res);
10885 :
10886 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
10887 1536 : cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10888 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
10889 : args[1], res);
10890 :
10891 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
10892 1536 : cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10893 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
10894 : args[0], res);
10895 :
10896 1536 : se->expr = res;
10897 : }
10898 : else
10899 : {
10900 : /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
10901 1536 : fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
10902 1536 : func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind);
10903 1536 : se->expr = build_call_expr_loc_array (input_location, func, 2, args);
10904 : }
10905 3072 : }
10906 :
10907 :
10908 : /* Generate code for comparison functions IEEE_QUIET_* and
10909 : IEEE_SIGNALING_*. */
10910 :
10911 : static void
10912 3888 : conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
10913 : const char *name)
10914 : {
10915 3888 : tree args[2];
10916 3888 : tree arg1, arg2, res;
10917 :
10918 : /* Evaluate arguments only once. */
10919 3888 : conv_ieee_function_args (se, expr, args, 2);
10920 3888 : arg1 = gfc_evaluate_now (args[0], &se->pre);
10921 3888 : arg2 = gfc_evaluate_now (args[1], &se->pre);
10922 :
10923 3888 : if (startswith (name, "eq"))
10924 : {
10925 648 : if (signaling)
10926 324 : res = build_call_expr_loc (input_location,
10927 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
10928 : 2, arg1, arg2);
10929 : else
10930 324 : res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10931 : arg1, arg2);
10932 : }
10933 3240 : else if (startswith (name, "ne"))
10934 : {
10935 648 : if (signaling)
10936 : {
10937 324 : res = build_call_expr_loc (input_location,
10938 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
10939 : 2, arg1, arg2);
10940 324 : res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10941 : logical_type_node, res);
10942 : }
10943 : else
10944 324 : res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10945 : arg1, arg2);
10946 : }
10947 2592 : else if (startswith (name, "ge"))
10948 : {
10949 648 : if (signaling)
10950 324 : res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10951 : arg1, arg2);
10952 : else
10953 324 : res = build_call_expr_loc (input_location,
10954 : builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
10955 : 2, arg1, arg2);
10956 : }
10957 1944 : else if (startswith (name, "gt"))
10958 : {
10959 648 : if (signaling)
10960 324 : res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
10961 : arg1, arg2);
10962 : else
10963 324 : res = build_call_expr_loc (input_location,
10964 : builtin_decl_explicit (BUILT_IN_ISGREATER),
10965 : 2, arg1, arg2);
10966 : }
10967 1296 : else if (startswith (name, "le"))
10968 : {
10969 648 : if (signaling)
10970 324 : res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
10971 : arg1, arg2);
10972 : else
10973 324 : res = build_call_expr_loc (input_location,
10974 : builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
10975 : 2, arg1, arg2);
10976 : }
10977 648 : else if (startswith (name, "lt"))
10978 : {
10979 648 : if (signaling)
10980 324 : res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10981 : arg1, arg2);
10982 : else
10983 324 : res = build_call_expr_loc (input_location,
10984 : builtin_decl_explicit (BUILT_IN_ISLESS),
10985 : 2, arg1, arg2);
10986 : }
10987 : else
10988 0 : gcc_unreachable ();
10989 :
10990 3888 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
10991 3888 : }
10992 :
10993 :
10994 : /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
10995 : module. */
10996 :
10997 : bool
10998 13939 : gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
10999 : {
11000 13939 : const char *name = expr->value.function.name;
11001 :
11002 13939 : if (startswith (name, "_gfortran_ieee_is_nan"))
11003 522 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
11004 13417 : else if (startswith (name, "_gfortran_ieee_is_finite"))
11005 372 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
11006 13045 : else if (startswith (name, "_gfortran_ieee_unordered"))
11007 168 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
11008 12877 : else if (startswith (name, "_gfortran_ieee_signbit"))
11009 624 : conv_intrinsic_ieee_signbit (se, expr);
11010 12253 : else if (startswith (name, "_gfortran_ieee_is_normal"))
11011 312 : conv_intrinsic_ieee_is_normal (se, expr);
11012 11941 : else if (startswith (name, "_gfortran_ieee_is_negative"))
11013 312 : conv_intrinsic_ieee_is_negative (se, expr);
11014 11629 : else if (startswith (name, "_gfortran_ieee_copy_sign"))
11015 576 : conv_intrinsic_ieee_copy_sign (se, expr);
11016 11053 : else if (startswith (name, "_gfortran_ieee_scalb"))
11017 228 : conv_intrinsic_ieee_scalb (se, expr);
11018 10825 : else if (startswith (name, "_gfortran_ieee_next_after"))
11019 180 : conv_intrinsic_ieee_next_after (se, expr);
11020 10645 : else if (startswith (name, "_gfortran_ieee_rem"))
11021 84 : conv_intrinsic_ieee_rem (se, expr);
11022 10561 : else if (startswith (name, "_gfortran_ieee_logb"))
11023 144 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
11024 10417 : else if (startswith (name, "_gfortran_ieee_rint"))
11025 96 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
11026 10321 : else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
11027 648 : conv_intrinsic_ieee_class (se, expr);
11028 9673 : else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
11029 1111 : conv_intrinsic_ieee_value (se, expr);
11030 8562 : else if (startswith (name, "_gfortran_ieee_fma"))
11031 120 : conv_intrinsic_ieee_fma (se, expr);
11032 8442 : else if (startswith (name, "_gfortran_ieee_min_num_"))
11033 1536 : conv_intrinsic_ieee_minmax (se, expr, 0, name + 23);
11034 6906 : else if (startswith (name, "_gfortran_ieee_max_num_"))
11035 1536 : conv_intrinsic_ieee_minmax (se, expr, 1, name + 23);
11036 5370 : else if (startswith (name, "_gfortran_ieee_quiet_"))
11037 1944 : conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
11038 3426 : else if (startswith (name, "_gfortran_ieee_signaling_"))
11039 1944 : conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
11040 : else
11041 : /* It is not among the functions we translate directly. We return
11042 : false, so a library function call is emitted. */
11043 : return false;
11044 :
11045 : return true;
11046 : }
11047 :
11048 :
11049 : /* Generate a direct call to malloc() for the MALLOC intrinsic. */
11050 :
11051 : static void
11052 16 : gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
11053 : {
11054 16 : tree arg, res, restype;
11055 :
11056 16 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
11057 16 : arg = fold_convert (size_type_node, arg);
11058 16 : res = build_call_expr_loc (input_location,
11059 : builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
11060 16 : restype = gfc_typenode_for_spec (&expr->ts);
11061 16 : se->expr = fold_convert (restype, res);
11062 16 : }
11063 :
11064 :
11065 : /* Generate code for an intrinsic function. Some map directly to library
11066 : calls, others get special handling. In some cases the name of the function
11067 : used depends on the type specifiers. */
11068 :
11069 : void
11070 262431 : gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
11071 : {
11072 262431 : const char *name;
11073 262431 : int lib, kind;
11074 262431 : tree fndecl;
11075 :
11076 262431 : name = &expr->value.function.name[2];
11077 :
11078 262431 : if (expr->rank > 0)
11079 : {
11080 50351 : lib = gfc_is_intrinsic_libcall (expr);
11081 50351 : if (lib != 0)
11082 : {
11083 19187 : if (lib == 1)
11084 11797 : se->ignore_optional = 1;
11085 :
11086 19187 : switch (expr->value.function.isym->id)
11087 : {
11088 5831 : case GFC_ISYM_EOSHIFT:
11089 5831 : case GFC_ISYM_PACK:
11090 5831 : case GFC_ISYM_RESHAPE:
11091 5831 : case GFC_ISYM_REDUCE:
11092 : /* For all of those the first argument specifies the type and the
11093 : third is optional. */
11094 5831 : conv_generic_with_optional_char_arg (se, expr, 1, 3);
11095 5831 : break;
11096 :
11097 1116 : case GFC_ISYM_FINDLOC:
11098 1116 : gfc_conv_intrinsic_findloc (se, expr);
11099 1116 : break;
11100 :
11101 2935 : case GFC_ISYM_MINLOC:
11102 2935 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11103 2935 : break;
11104 :
11105 2439 : case GFC_ISYM_MAXLOC:
11106 2439 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11107 2439 : break;
11108 :
11109 6866 : default:
11110 6866 : gfc_conv_intrinsic_funcall (se, expr);
11111 6866 : break;
11112 : }
11113 :
11114 19187 : return;
11115 : }
11116 : }
11117 :
11118 243244 : switch (expr->value.function.isym->id)
11119 : {
11120 0 : case GFC_ISYM_NONE:
11121 0 : gcc_unreachable ();
11122 :
11123 529 : case GFC_ISYM_REPEAT:
11124 529 : gfc_conv_intrinsic_repeat (se, expr);
11125 529 : break;
11126 :
11127 574 : case GFC_ISYM_TRIM:
11128 574 : gfc_conv_intrinsic_trim (se, expr);
11129 574 : break;
11130 :
11131 42 : case GFC_ISYM_SC_KIND:
11132 42 : gfc_conv_intrinsic_sc_kind (se, expr);
11133 42 : break;
11134 :
11135 45 : case GFC_ISYM_SI_KIND:
11136 45 : gfc_conv_intrinsic_si_kind (se, expr);
11137 45 : break;
11138 :
11139 6 : case GFC_ISYM_SL_KIND:
11140 6 : gfc_conv_intrinsic_sl_kind (se, expr);
11141 6 : break;
11142 :
11143 82 : case GFC_ISYM_SR_KIND:
11144 82 : gfc_conv_intrinsic_sr_kind (se, expr);
11145 82 : break;
11146 :
11147 228 : case GFC_ISYM_EXPONENT:
11148 228 : gfc_conv_intrinsic_exponent (se, expr);
11149 228 : break;
11150 :
11151 316 : case GFC_ISYM_SCAN:
11152 316 : kind = expr->value.function.actual->expr->ts.kind;
11153 316 : if (kind == 1)
11154 250 : fndecl = gfor_fndecl_string_scan;
11155 66 : else if (kind == 4)
11156 66 : fndecl = gfor_fndecl_string_scan_char4;
11157 : else
11158 0 : gcc_unreachable ();
11159 :
11160 316 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11161 316 : break;
11162 :
11163 94 : case GFC_ISYM_VERIFY:
11164 94 : kind = expr->value.function.actual->expr->ts.kind;
11165 94 : if (kind == 1)
11166 70 : fndecl = gfor_fndecl_string_verify;
11167 24 : else if (kind == 4)
11168 24 : fndecl = gfor_fndecl_string_verify_char4;
11169 : else
11170 0 : gcc_unreachable ();
11171 :
11172 94 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11173 94 : break;
11174 :
11175 7367 : case GFC_ISYM_ALLOCATED:
11176 7367 : gfc_conv_allocated (se, expr);
11177 7367 : break;
11178 :
11179 9448 : case GFC_ISYM_ASSOCIATED:
11180 9448 : gfc_conv_associated(se, expr);
11181 9448 : break;
11182 :
11183 409 : case GFC_ISYM_SAME_TYPE_AS:
11184 409 : gfc_conv_same_type_as (se, expr);
11185 409 : break;
11186 :
11187 7836 : case GFC_ISYM_ABS:
11188 7836 : gfc_conv_intrinsic_abs (se, expr);
11189 7836 : break;
11190 :
11191 351 : case GFC_ISYM_ADJUSTL:
11192 351 : if (expr->ts.kind == 1)
11193 297 : fndecl = gfor_fndecl_adjustl;
11194 54 : else if (expr->ts.kind == 4)
11195 54 : fndecl = gfor_fndecl_adjustl_char4;
11196 : else
11197 0 : gcc_unreachable ();
11198 :
11199 351 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11200 351 : break;
11201 :
11202 123 : case GFC_ISYM_ADJUSTR:
11203 123 : if (expr->ts.kind == 1)
11204 68 : fndecl = gfor_fndecl_adjustr;
11205 55 : else if (expr->ts.kind == 4)
11206 55 : fndecl = gfor_fndecl_adjustr_char4;
11207 : else
11208 0 : gcc_unreachable ();
11209 :
11210 123 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11211 123 : break;
11212 :
11213 428 : case GFC_ISYM_AIMAG:
11214 428 : gfc_conv_intrinsic_imagpart (se, expr);
11215 428 : break;
11216 :
11217 146 : case GFC_ISYM_AINT:
11218 146 : gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
11219 146 : break;
11220 :
11221 420 : case GFC_ISYM_ALL:
11222 420 : gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
11223 420 : break;
11224 :
11225 74 : case GFC_ISYM_ANINT:
11226 74 : gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
11227 74 : break;
11228 :
11229 90 : case GFC_ISYM_AND:
11230 90 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11231 90 : break;
11232 :
11233 37607 : case GFC_ISYM_ANY:
11234 37607 : gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
11235 37607 : break;
11236 :
11237 216 : case GFC_ISYM_ACOSD:
11238 216 : case GFC_ISYM_ASIND:
11239 216 : case GFC_ISYM_ATAND:
11240 216 : gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
11241 216 : break;
11242 :
11243 102 : case GFC_ISYM_COTAN:
11244 102 : gfc_conv_intrinsic_cotan (se, expr);
11245 102 : break;
11246 :
11247 108 : case GFC_ISYM_COTAND:
11248 108 : gfc_conv_intrinsic_cotand (se, expr);
11249 108 : break;
11250 :
11251 120 : case GFC_ISYM_ATAN2D:
11252 120 : gfc_conv_intrinsic_atan2d (se, expr);
11253 120 : break;
11254 :
11255 145 : case GFC_ISYM_BTEST:
11256 145 : gfc_conv_intrinsic_btest (se, expr);
11257 145 : break;
11258 :
11259 54 : case GFC_ISYM_BGE:
11260 54 : gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
11261 54 : break;
11262 :
11263 54 : case GFC_ISYM_BGT:
11264 54 : gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
11265 54 : break;
11266 :
11267 54 : case GFC_ISYM_BLE:
11268 54 : gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
11269 54 : break;
11270 :
11271 54 : case GFC_ISYM_BLT:
11272 54 : gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
11273 54 : break;
11274 :
11275 9571 : case GFC_ISYM_C_ASSOCIATED:
11276 9571 : case GFC_ISYM_C_FUNLOC:
11277 9571 : case GFC_ISYM_C_LOC:
11278 9571 : case GFC_ISYM_F_C_STRING:
11279 9571 : conv_isocbinding_function (se, expr);
11280 9571 : break;
11281 :
11282 2020 : case GFC_ISYM_ACHAR:
11283 2020 : case GFC_ISYM_CHAR:
11284 2020 : gfc_conv_intrinsic_char (se, expr);
11285 2020 : break;
11286 :
11287 39694 : case GFC_ISYM_CONVERSION:
11288 39694 : case GFC_ISYM_DBLE:
11289 39694 : case GFC_ISYM_DFLOAT:
11290 39694 : case GFC_ISYM_FLOAT:
11291 39694 : case GFC_ISYM_LOGICAL:
11292 39694 : case GFC_ISYM_REAL:
11293 39694 : case GFC_ISYM_REALPART:
11294 39694 : case GFC_ISYM_SNGL:
11295 39694 : gfc_conv_intrinsic_conversion (se, expr);
11296 39694 : break;
11297 :
11298 : /* Integer conversions are handled separately to make sure we get the
11299 : correct rounding mode. */
11300 2812 : case GFC_ISYM_INT:
11301 2812 : case GFC_ISYM_INT2:
11302 2812 : case GFC_ISYM_INT8:
11303 2812 : case GFC_ISYM_LONG:
11304 2812 : case GFC_ISYM_UINT:
11305 2812 : gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
11306 2812 : break;
11307 :
11308 162 : case GFC_ISYM_NINT:
11309 162 : gfc_conv_intrinsic_int (se, expr, RND_ROUND);
11310 162 : break;
11311 :
11312 16 : case GFC_ISYM_CEILING:
11313 16 : gfc_conv_intrinsic_int (se, expr, RND_CEIL);
11314 16 : break;
11315 :
11316 116 : case GFC_ISYM_FLOOR:
11317 116 : gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
11318 116 : break;
11319 :
11320 3190 : case GFC_ISYM_MOD:
11321 3190 : gfc_conv_intrinsic_mod (se, expr, 0);
11322 3190 : break;
11323 :
11324 440 : case GFC_ISYM_MODULO:
11325 440 : gfc_conv_intrinsic_mod (se, expr, 1);
11326 440 : break;
11327 :
11328 1000 : case GFC_ISYM_CAF_GET:
11329 1000 : gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL);
11330 1000 : break;
11331 :
11332 167 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
11333 167 : gfc_conv_intrinsic_caf_is_present_remote (se, expr);
11334 167 : break;
11335 :
11336 485 : case GFC_ISYM_CMPLX:
11337 485 : gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
11338 485 : break;
11339 :
11340 10 : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
11341 10 : gfc_conv_intrinsic_iargc (se, expr);
11342 10 : break;
11343 :
11344 6 : case GFC_ISYM_COMPLEX:
11345 6 : gfc_conv_intrinsic_cmplx (se, expr, 1);
11346 6 : break;
11347 :
11348 257 : case GFC_ISYM_CONJG:
11349 257 : gfc_conv_intrinsic_conjg (se, expr);
11350 257 : break;
11351 :
11352 4 : case GFC_ISYM_COSHAPE:
11353 4 : conv_intrinsic_cobound (se, expr);
11354 4 : break;
11355 :
11356 143 : case GFC_ISYM_COUNT:
11357 143 : gfc_conv_intrinsic_count (se, expr);
11358 143 : break;
11359 :
11360 0 : case GFC_ISYM_CTIME:
11361 0 : gfc_conv_intrinsic_ctime (se, expr);
11362 0 : break;
11363 :
11364 96 : case GFC_ISYM_DIM:
11365 96 : gfc_conv_intrinsic_dim (se, expr);
11366 96 : break;
11367 :
11368 113 : case GFC_ISYM_DOT_PRODUCT:
11369 113 : gfc_conv_intrinsic_dot_product (se, expr);
11370 113 : break;
11371 :
11372 13 : case GFC_ISYM_DPROD:
11373 13 : gfc_conv_intrinsic_dprod (se, expr);
11374 13 : break;
11375 :
11376 66 : case GFC_ISYM_DSHIFTL:
11377 66 : gfc_conv_intrinsic_dshift (se, expr, true);
11378 66 : break;
11379 :
11380 66 : case GFC_ISYM_DSHIFTR:
11381 66 : gfc_conv_intrinsic_dshift (se, expr, false);
11382 66 : break;
11383 :
11384 0 : case GFC_ISYM_FDATE:
11385 0 : gfc_conv_intrinsic_fdate (se, expr);
11386 0 : break;
11387 :
11388 60 : case GFC_ISYM_FRACTION:
11389 60 : gfc_conv_intrinsic_fraction (se, expr);
11390 60 : break;
11391 :
11392 24 : case GFC_ISYM_IALL:
11393 24 : gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
11394 24 : break;
11395 :
11396 606 : case GFC_ISYM_IAND:
11397 606 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11398 606 : break;
11399 :
11400 12 : case GFC_ISYM_IANY:
11401 12 : gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
11402 12 : break;
11403 :
11404 168 : case GFC_ISYM_IBCLR:
11405 168 : gfc_conv_intrinsic_singlebitop (se, expr, 0);
11406 168 : break;
11407 :
11408 27 : case GFC_ISYM_IBITS:
11409 27 : gfc_conv_intrinsic_ibits (se, expr);
11410 27 : break;
11411 :
11412 138 : case GFC_ISYM_IBSET:
11413 138 : gfc_conv_intrinsic_singlebitop (se, expr, 1);
11414 138 : break;
11415 :
11416 2033 : case GFC_ISYM_IACHAR:
11417 2033 : case GFC_ISYM_ICHAR:
11418 : /* We assume ASCII character sequence. */
11419 2033 : gfc_conv_intrinsic_ichar (se, expr);
11420 2033 : break;
11421 :
11422 2 : case GFC_ISYM_IARGC:
11423 2 : gfc_conv_intrinsic_iargc (se, expr);
11424 2 : break;
11425 :
11426 694 : case GFC_ISYM_IEOR:
11427 694 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11428 694 : break;
11429 :
11430 341 : case GFC_ISYM_INDEX:
11431 341 : kind = expr->value.function.actual->expr->ts.kind;
11432 341 : if (kind == 1)
11433 275 : fndecl = gfor_fndecl_string_index;
11434 66 : else if (kind == 4)
11435 66 : fndecl = gfor_fndecl_string_index_char4;
11436 : else
11437 0 : gcc_unreachable ();
11438 :
11439 341 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11440 341 : break;
11441 :
11442 495 : case GFC_ISYM_IOR:
11443 495 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11444 495 : break;
11445 :
11446 12 : case GFC_ISYM_IPARITY:
11447 12 : gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
11448 12 : break;
11449 :
11450 6 : case GFC_ISYM_IS_IOSTAT_END:
11451 6 : gfc_conv_has_intvalue (se, expr, LIBERROR_END);
11452 6 : break;
11453 :
11454 18 : case GFC_ISYM_IS_IOSTAT_EOR:
11455 18 : gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
11456 18 : break;
11457 :
11458 735 : case GFC_ISYM_IS_CONTIGUOUS:
11459 735 : gfc_conv_intrinsic_is_contiguous (se, expr);
11460 735 : break;
11461 :
11462 432 : case GFC_ISYM_ISNAN:
11463 432 : gfc_conv_intrinsic_isnan (se, expr);
11464 432 : break;
11465 :
11466 8 : case GFC_ISYM_KILL:
11467 8 : conv_intrinsic_kill (se, expr);
11468 8 : break;
11469 :
11470 90 : case GFC_ISYM_LSHIFT:
11471 90 : gfc_conv_intrinsic_shift (se, expr, false, false);
11472 90 : break;
11473 :
11474 24 : case GFC_ISYM_RSHIFT:
11475 24 : gfc_conv_intrinsic_shift (se, expr, true, true);
11476 24 : break;
11477 :
11478 78 : case GFC_ISYM_SHIFTA:
11479 78 : gfc_conv_intrinsic_shift (se, expr, true, true);
11480 78 : break;
11481 :
11482 234 : case GFC_ISYM_SHIFTL:
11483 234 : gfc_conv_intrinsic_shift (se, expr, false, false);
11484 234 : break;
11485 :
11486 66 : case GFC_ISYM_SHIFTR:
11487 66 : gfc_conv_intrinsic_shift (se, expr, true, false);
11488 66 : break;
11489 :
11490 318 : case GFC_ISYM_ISHFT:
11491 318 : gfc_conv_intrinsic_ishft (se, expr);
11492 318 : break;
11493 :
11494 658 : case GFC_ISYM_ISHFTC:
11495 658 : gfc_conv_intrinsic_ishftc (se, expr);
11496 658 : break;
11497 :
11498 270 : case GFC_ISYM_LEADZ:
11499 270 : gfc_conv_intrinsic_leadz (se, expr);
11500 270 : break;
11501 :
11502 282 : case GFC_ISYM_TRAILZ:
11503 282 : gfc_conv_intrinsic_trailz (se, expr);
11504 282 : break;
11505 :
11506 103 : case GFC_ISYM_POPCNT:
11507 103 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
11508 103 : break;
11509 :
11510 31 : case GFC_ISYM_POPPAR:
11511 31 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
11512 31 : break;
11513 :
11514 5503 : case GFC_ISYM_LBOUND:
11515 5503 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
11516 5503 : break;
11517 :
11518 210 : case GFC_ISYM_LCOBOUND:
11519 210 : conv_intrinsic_cobound (se, expr);
11520 210 : break;
11521 :
11522 744 : case GFC_ISYM_TRANSPOSE:
11523 : /* The scalarizer has already been set up for reversed dimension access
11524 : order ; now we just get the argument value normally. */
11525 744 : gfc_conv_expr (se, expr->value.function.actual->expr);
11526 744 : break;
11527 :
11528 5765 : case GFC_ISYM_LEN:
11529 5765 : gfc_conv_intrinsic_len (se, expr);
11530 5765 : break;
11531 :
11532 2335 : case GFC_ISYM_LEN_TRIM:
11533 2335 : gfc_conv_intrinsic_len_trim (se, expr);
11534 2335 : break;
11535 :
11536 18 : case GFC_ISYM_LGE:
11537 18 : gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
11538 18 : break;
11539 :
11540 36 : case GFC_ISYM_LGT:
11541 36 : gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
11542 36 : break;
11543 :
11544 18 : case GFC_ISYM_LLE:
11545 18 : gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
11546 18 : break;
11547 :
11548 27 : case GFC_ISYM_LLT:
11549 27 : gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
11550 27 : break;
11551 :
11552 16 : case GFC_ISYM_MALLOC:
11553 16 : gfc_conv_intrinsic_malloc (se, expr);
11554 16 : break;
11555 :
11556 32 : case GFC_ISYM_MASKL:
11557 32 : gfc_conv_intrinsic_mask (se, expr, 1);
11558 32 : break;
11559 :
11560 32 : case GFC_ISYM_MASKR:
11561 32 : gfc_conv_intrinsic_mask (se, expr, 0);
11562 32 : break;
11563 :
11564 1049 : case GFC_ISYM_MAX:
11565 1049 : if (expr->ts.type == BT_CHARACTER)
11566 138 : gfc_conv_intrinsic_minmax_char (se, expr, 1);
11567 : else
11568 911 : gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
11569 : break;
11570 :
11571 6348 : case GFC_ISYM_MAXLOC:
11572 6348 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11573 6348 : break;
11574 :
11575 216 : case GFC_ISYM_FINDLOC:
11576 216 : gfc_conv_intrinsic_findloc (se, expr);
11577 216 : break;
11578 :
11579 1101 : case GFC_ISYM_MAXVAL:
11580 1101 : gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
11581 1101 : break;
11582 :
11583 949 : case GFC_ISYM_MERGE:
11584 949 : gfc_conv_intrinsic_merge (se, expr);
11585 949 : break;
11586 :
11587 42 : case GFC_ISYM_MERGE_BITS:
11588 42 : gfc_conv_intrinsic_merge_bits (se, expr);
11589 42 : break;
11590 :
11591 598 : case GFC_ISYM_MIN:
11592 598 : if (expr->ts.type == BT_CHARACTER)
11593 144 : gfc_conv_intrinsic_minmax_char (se, expr, -1);
11594 : else
11595 454 : gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
11596 : break;
11597 :
11598 7176 : case GFC_ISYM_MINLOC:
11599 7176 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11600 7176 : break;
11601 :
11602 1316 : case GFC_ISYM_MINVAL:
11603 1316 : gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
11604 1316 : break;
11605 :
11606 1595 : case GFC_ISYM_NEAREST:
11607 1595 : gfc_conv_intrinsic_nearest (se, expr);
11608 1595 : break;
11609 :
11610 68 : case GFC_ISYM_NORM2:
11611 68 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
11612 68 : break;
11613 :
11614 230 : case GFC_ISYM_NOT:
11615 230 : gfc_conv_intrinsic_not (se, expr);
11616 230 : break;
11617 :
11618 12 : case GFC_ISYM_OR:
11619 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11620 12 : break;
11621 :
11622 468 : case GFC_ISYM_OUT_OF_RANGE:
11623 468 : gfc_conv_intrinsic_out_of_range (se, expr);
11624 468 : break;
11625 :
11626 36 : case GFC_ISYM_PARITY:
11627 36 : gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
11628 36 : break;
11629 :
11630 5070 : case GFC_ISYM_PRESENT:
11631 5070 : gfc_conv_intrinsic_present (se, expr);
11632 5070 : break;
11633 :
11634 358 : case GFC_ISYM_PRODUCT:
11635 358 : gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
11636 358 : break;
11637 :
11638 12427 : case GFC_ISYM_RANK:
11639 12427 : gfc_conv_intrinsic_rank (se, expr);
11640 12427 : break;
11641 :
11642 48 : case GFC_ISYM_RRSPACING:
11643 48 : gfc_conv_intrinsic_rrspacing (se, expr);
11644 48 : break;
11645 :
11646 262 : case GFC_ISYM_SET_EXPONENT:
11647 262 : gfc_conv_intrinsic_set_exponent (se, expr);
11648 262 : break;
11649 :
11650 72 : case GFC_ISYM_SCALE:
11651 72 : gfc_conv_intrinsic_scale (se, expr);
11652 72 : break;
11653 :
11654 4940 : case GFC_ISYM_SHAPE:
11655 4940 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
11656 4940 : break;
11657 :
11658 423 : case GFC_ISYM_SIGN:
11659 423 : gfc_conv_intrinsic_sign (se, expr);
11660 423 : break;
11661 :
11662 15133 : case GFC_ISYM_SIZE:
11663 15133 : gfc_conv_intrinsic_size (se, expr);
11664 15133 : break;
11665 :
11666 1309 : case GFC_ISYM_SIZEOF:
11667 1309 : case GFC_ISYM_C_SIZEOF:
11668 1309 : gfc_conv_intrinsic_sizeof (se, expr);
11669 1309 : break;
11670 :
11671 834 : case GFC_ISYM_STORAGE_SIZE:
11672 834 : gfc_conv_intrinsic_storage_size (se, expr);
11673 834 : break;
11674 :
11675 70 : case GFC_ISYM_SPACING:
11676 70 : gfc_conv_intrinsic_spacing (se, expr);
11677 70 : break;
11678 :
11679 2250 : case GFC_ISYM_STRIDE:
11680 2250 : conv_intrinsic_stride (se, expr);
11681 2250 : break;
11682 :
11683 2003 : case GFC_ISYM_SUM:
11684 2003 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
11685 2003 : break;
11686 :
11687 21 : case GFC_ISYM_TEAM_NUMBER:
11688 21 : conv_intrinsic_team_number (se, expr);
11689 21 : break;
11690 :
11691 4011 : case GFC_ISYM_TRANSFER:
11692 4011 : if (se->ss && se->ss->info->useflags)
11693 : /* Access the previously obtained result. */
11694 281 : gfc_conv_tmp_array_ref (se);
11695 : else
11696 3730 : gfc_conv_intrinsic_transfer (se, expr);
11697 : break;
11698 :
11699 0 : case GFC_ISYM_TTYNAM:
11700 0 : gfc_conv_intrinsic_ttynam (se, expr);
11701 0 : break;
11702 :
11703 5687 : case GFC_ISYM_UBOUND:
11704 5687 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
11705 5687 : break;
11706 :
11707 244 : case GFC_ISYM_UCOBOUND:
11708 244 : conv_intrinsic_cobound (se, expr);
11709 244 : break;
11710 :
11711 18 : case GFC_ISYM_XOR:
11712 18 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11713 18 : break;
11714 :
11715 8816 : case GFC_ISYM_LOC:
11716 8816 : gfc_conv_intrinsic_loc (se, expr);
11717 8816 : break;
11718 :
11719 1499 : case GFC_ISYM_THIS_IMAGE:
11720 : /* For num_images() == 1, handle as LCOBOUND. */
11721 1499 : if (expr->value.function.actual->expr
11722 526 : && flag_coarray == GFC_FCOARRAY_SINGLE)
11723 208 : conv_intrinsic_cobound (se, expr);
11724 : else
11725 1291 : trans_this_image (se, expr);
11726 : break;
11727 :
11728 193 : case GFC_ISYM_IMAGE_INDEX:
11729 193 : trans_image_index (se, expr);
11730 193 : break;
11731 :
11732 25 : case GFC_ISYM_IMAGE_STATUS:
11733 25 : conv_intrinsic_image_status (se, expr);
11734 25 : break;
11735 :
11736 806 : case GFC_ISYM_NUM_IMAGES:
11737 806 : trans_num_images (se, expr);
11738 806 : break;
11739 :
11740 1392 : case GFC_ISYM_ACCESS:
11741 1392 : case GFC_ISYM_CHDIR:
11742 1392 : case GFC_ISYM_CHMOD:
11743 1392 : case GFC_ISYM_DTIME:
11744 1392 : case GFC_ISYM_ETIME:
11745 1392 : case GFC_ISYM_EXTENDS_TYPE_OF:
11746 1392 : case GFC_ISYM_FGET:
11747 1392 : case GFC_ISYM_FGETC:
11748 1392 : case GFC_ISYM_FNUM:
11749 1392 : case GFC_ISYM_FPUT:
11750 1392 : case GFC_ISYM_FPUTC:
11751 1392 : case GFC_ISYM_FSTAT:
11752 1392 : case GFC_ISYM_FTELL:
11753 1392 : case GFC_ISYM_GETCWD:
11754 1392 : case GFC_ISYM_GETGID:
11755 1392 : case GFC_ISYM_GETPID:
11756 1392 : case GFC_ISYM_GETUID:
11757 1392 : case GFC_ISYM_GET_TEAM:
11758 1392 : case GFC_ISYM_HOSTNM:
11759 1392 : case GFC_ISYM_IERRNO:
11760 1392 : case GFC_ISYM_IRAND:
11761 1392 : case GFC_ISYM_ISATTY:
11762 1392 : case GFC_ISYM_JN2:
11763 1392 : case GFC_ISYM_LINK:
11764 1392 : case GFC_ISYM_LSTAT:
11765 1392 : case GFC_ISYM_MATMUL:
11766 1392 : case GFC_ISYM_MCLOCK:
11767 1392 : case GFC_ISYM_MCLOCK8:
11768 1392 : case GFC_ISYM_RAND:
11769 1392 : case GFC_ISYM_REDUCE:
11770 1392 : case GFC_ISYM_RENAME:
11771 1392 : case GFC_ISYM_SECOND:
11772 1392 : case GFC_ISYM_SECNDS:
11773 1392 : case GFC_ISYM_SIGNAL:
11774 1392 : case GFC_ISYM_STAT:
11775 1392 : case GFC_ISYM_SYMLNK:
11776 1392 : case GFC_ISYM_SYSTEM:
11777 1392 : case GFC_ISYM_TIME:
11778 1392 : case GFC_ISYM_TIME8:
11779 1392 : case GFC_ISYM_UMASK:
11780 1392 : case GFC_ISYM_UNLINK:
11781 1392 : case GFC_ISYM_YN2:
11782 1392 : gfc_conv_intrinsic_funcall (se, expr);
11783 1392 : break;
11784 :
11785 0 : case GFC_ISYM_EOSHIFT:
11786 0 : case GFC_ISYM_PACK:
11787 0 : case GFC_ISYM_RESHAPE:
11788 : /* For those, expr->rank should always be >0 and thus the if above the
11789 : switch should have matched. */
11790 0 : gcc_unreachable ();
11791 3859 : break;
11792 :
11793 3859 : default:
11794 3859 : gfc_conv_intrinsic_lib_function (se, expr);
11795 3859 : break;
11796 : }
11797 : }
11798 :
11799 :
11800 : static gfc_ss *
11801 1560 : walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11802 : {
11803 1560 : gfc_ss *arg_ss, *tmp_ss;
11804 1560 : gfc_actual_arglist *arg;
11805 :
11806 1560 : arg = expr->value.function.actual;
11807 :
11808 1560 : gcc_assert (arg->expr);
11809 :
11810 1560 : arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11811 1560 : gcc_assert (arg_ss != gfc_ss_terminator);
11812 :
11813 : for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11814 : {
11815 1665 : if (tmp_ss->info->type != GFC_SS_SCALAR
11816 : && tmp_ss->info->type != GFC_SS_REFERENCE)
11817 : {
11818 1628 : gcc_assert (tmp_ss->dimen == 2);
11819 :
11820 : /* We just invert dimensions. */
11821 1628 : std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
11822 : }
11823 :
11824 : /* Stop when tmp_ss points to the last valid element of the chain... */
11825 1665 : if (tmp_ss->next == gfc_ss_terminator)
11826 : break;
11827 : }
11828 :
11829 : /* ... so that we can attach the rest of the chain to it. */
11830 1560 : tmp_ss->next = ss;
11831 :
11832 1560 : return arg_ss;
11833 : }
11834 :
11835 :
11836 : /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11837 : This has the side effect of reversing the nested list, so there is no
11838 : need to call gfc_reverse_ss on it (the given list is assumed not to be
11839 : reversed yet). */
11840 :
11841 : static gfc_ss *
11842 3371 : nest_loop_dimension (gfc_ss *ss, int dim)
11843 : {
11844 3371 : int ss_dim, i;
11845 3371 : gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11846 3371 : gfc_loopinfo *new_loop;
11847 :
11848 3371 : gcc_assert (ss != gfc_ss_terminator);
11849 :
11850 8118 : for (; ss != gfc_ss_terminator; ss = ss->next)
11851 : {
11852 4747 : new_ss = gfc_get_ss ();
11853 4747 : new_ss->next = prev_ss;
11854 4747 : new_ss->parent = ss;
11855 4747 : new_ss->info = ss->info;
11856 4747 : new_ss->info->refcount++;
11857 4747 : if (ss->dimen != 0)
11858 : {
11859 4684 : gcc_assert (ss->info->type != GFC_SS_SCALAR
11860 : && ss->info->type != GFC_SS_REFERENCE);
11861 :
11862 4684 : new_ss->dimen = 1;
11863 4684 : new_ss->dim[0] = ss->dim[dim];
11864 :
11865 4684 : gcc_assert (dim < ss->dimen);
11866 :
11867 4684 : ss_dim = --ss->dimen;
11868 10430 : for (i = dim; i < ss_dim; i++)
11869 5746 : ss->dim[i] = ss->dim[i + 1];
11870 :
11871 4684 : ss->dim[ss_dim] = 0;
11872 : }
11873 4747 : prev_ss = new_ss;
11874 :
11875 4747 : if (ss->nested_ss)
11876 : {
11877 81 : ss->nested_ss->parent = new_ss;
11878 81 : new_ss->nested_ss = ss->nested_ss;
11879 : }
11880 4747 : ss->nested_ss = new_ss;
11881 : }
11882 :
11883 3371 : new_loop = gfc_get_loopinfo ();
11884 3371 : gfc_init_loopinfo (new_loop);
11885 :
11886 3371 : gcc_assert (prev_ss != NULL);
11887 3371 : gcc_assert (prev_ss != gfc_ss_terminator);
11888 3371 : gfc_add_ss_to_loop (new_loop, prev_ss);
11889 3371 : return new_ss->parent;
11890 : }
11891 :
11892 :
11893 : /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
11894 : is to be inlined. */
11895 :
11896 : static gfc_ss *
11897 575 : walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
11898 : {
11899 575 : gfc_ss *tmp_ss, *tail, *array_ss;
11900 575 : gfc_actual_arglist *arg1, *arg2, *arg3;
11901 575 : int sum_dim;
11902 575 : bool scalar_mask = false;
11903 :
11904 : /* The rank of the result will be determined later. */
11905 575 : arg1 = expr->value.function.actual;
11906 575 : arg2 = arg1->next;
11907 575 : arg3 = arg2->next;
11908 575 : gcc_assert (arg3 != NULL);
11909 :
11910 575 : if (expr->rank == 0)
11911 : return ss;
11912 :
11913 575 : tmp_ss = gfc_ss_terminator;
11914 :
11915 575 : if (arg3->expr)
11916 : {
11917 118 : gfc_ss *mask_ss;
11918 :
11919 118 : mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
11920 118 : if (mask_ss == tmp_ss)
11921 34 : scalar_mask = 1;
11922 :
11923 : tmp_ss = mask_ss;
11924 : }
11925 :
11926 575 : array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
11927 575 : gcc_assert (array_ss != tmp_ss);
11928 :
11929 : /* Odd thing: If the mask is scalar, it is used by the frontend after
11930 : the array (to make an if around the nested loop). Thus it shall
11931 : be after array_ss once the gfc_ss list is reversed. */
11932 575 : if (scalar_mask)
11933 34 : tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
11934 : else
11935 : tmp_ss = array_ss;
11936 :
11937 : /* "Hide" the dimension on which we will sum in the first arg's scalarization
11938 : chain. */
11939 575 : sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
11940 575 : tail = nest_loop_dimension (tmp_ss, sum_dim);
11941 575 : tail->next = ss;
11942 :
11943 575 : return tmp_ss;
11944 : }
11945 :
11946 :
11947 : /* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the
11948 : function is to be inlined. */
11949 :
11950 : static gfc_ss *
11951 6085 : walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
11952 : {
11953 6085 : if (expr->rank == 0)
11954 : return ss;
11955 :
11956 6085 : gfc_actual_arglist *array_arg = expr->value.function.actual;
11957 6085 : gfc_actual_arglist *dim_arg = array_arg->next;
11958 6085 : gfc_actual_arglist *mask_arg = dim_arg->next;
11959 6085 : gfc_actual_arglist *kind_arg = mask_arg->next;
11960 6085 : gfc_actual_arglist *back_arg = kind_arg->next;
11961 :
11962 6085 : gfc_expr *array = array_arg->expr;
11963 6085 : gfc_expr *dim = dim_arg->expr;
11964 6085 : gfc_expr *mask = mask_arg->expr;
11965 6085 : gfc_expr *back = back_arg->expr;
11966 :
11967 6085 : if (dim == nullptr)
11968 3289 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
11969 :
11970 2796 : gfc_ss *tmp_ss = gfc_ss_terminator;
11971 :
11972 2796 : bool scalar_mask = false;
11973 2796 : if (mask)
11974 : {
11975 1866 : gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
11976 1866 : if (mask_ss == tmp_ss)
11977 : scalar_mask = true;
11978 1174 : else if (maybe_absent_optional_variable (mask))
11979 20 : mask_ss->info->can_be_null_ref = true;
11980 :
11981 : tmp_ss = mask_ss;
11982 : }
11983 :
11984 2796 : gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
11985 2796 : gcc_assert (array_ss != tmp_ss);
11986 :
11987 2796 : tmp_ss = array_ss;
11988 :
11989 : /* Move the dimension on which we will sum to a separate nested scalarization
11990 : chain, "hiding" that dimension from the outer scalarization. */
11991 2796 : int dim_val = mpz_get_si (dim->value.integer);
11992 2796 : gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
11993 :
11994 2796 : if (back && array->rank > 1)
11995 : {
11996 : /* If there are nested scalarization loops, include BACK in the
11997 : scalarization chains to avoid evaluating it multiple times in a loop.
11998 : Otherwise, prefer to handle it outside of scalarization. */
11999 2796 : gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
12000 2796 : back_ss->info->type = GFC_SS_REFERENCE;
12001 2796 : if (maybe_absent_optional_variable (back))
12002 16 : back_ss->info->can_be_null_ref = true;
12003 :
12004 2796 : tail->next = back_ss;
12005 2796 : }
12006 : else
12007 0 : tail->next = ss;
12008 :
12009 2796 : if (scalar_mask)
12010 : {
12011 692 : tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
12012 : /* MASK can be a forwarded optional argument, so make the necessary setup
12013 : to avoid the scalarizer generating any unguarded pointer dereference in
12014 : that case. */
12015 692 : tmp_ss->info->type = GFC_SS_REFERENCE;
12016 692 : if (maybe_absent_optional_variable (mask))
12017 4 : tmp_ss->info->can_be_null_ref = true;
12018 : }
12019 :
12020 : return tmp_ss;
12021 : }
12022 :
12023 :
12024 : static gfc_ss *
12025 8220 : walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
12026 : {
12027 :
12028 8220 : switch (expr->value.function.isym->id)
12029 : {
12030 575 : case GFC_ISYM_PRODUCT:
12031 575 : case GFC_ISYM_SUM:
12032 575 : return walk_inline_intrinsic_arith (ss, expr);
12033 :
12034 1560 : case GFC_ISYM_TRANSPOSE:
12035 1560 : return walk_inline_intrinsic_transpose (ss, expr);
12036 :
12037 6085 : case GFC_ISYM_MAXLOC:
12038 6085 : case GFC_ISYM_MINLOC:
12039 6085 : return walk_inline_intrinsic_minmaxloc (ss, expr);
12040 :
12041 0 : default:
12042 0 : gcc_unreachable ();
12043 : }
12044 : gcc_unreachable ();
12045 : }
12046 :
12047 :
12048 : /* This generates code to execute before entering the scalarization loop.
12049 : Currently does nothing. */
12050 :
12051 : void
12052 11533 : gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
12053 : {
12054 11533 : switch (ss->info->expr->value.function.isym->id)
12055 : {
12056 11533 : case GFC_ISYM_UBOUND:
12057 11533 : case GFC_ISYM_LBOUND:
12058 11533 : case GFC_ISYM_COSHAPE:
12059 11533 : case GFC_ISYM_UCOBOUND:
12060 11533 : case GFC_ISYM_LCOBOUND:
12061 11533 : case GFC_ISYM_MAXLOC:
12062 11533 : case GFC_ISYM_MINLOC:
12063 11533 : case GFC_ISYM_THIS_IMAGE:
12064 11533 : case GFC_ISYM_SHAPE:
12065 11533 : break;
12066 :
12067 0 : default:
12068 0 : gcc_unreachable ();
12069 : }
12070 11533 : }
12071 :
12072 :
12073 : /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
12074 : one parameter are expanded into code inside the scalarization loop. */
12075 :
12076 : static gfc_ss *
12077 10089 : gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
12078 : {
12079 10089 : if (expr->value.function.actual->expr->ts.type == BT_CLASS)
12080 438 : gfc_add_class_array_ref (expr->value.function.actual->expr);
12081 :
12082 : /* The two argument version returns a scalar. */
12083 10089 : if (expr->value.function.isym->id != GFC_ISYM_SHAPE
12084 3522 : && expr->value.function.isym->id != GFC_ISYM_COSHAPE
12085 3518 : && expr->value.function.actual->next->expr)
12086 : return ss;
12087 :
12088 10089 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12089 : }
12090 :
12091 :
12092 : /* Walk an intrinsic array libcall. */
12093 :
12094 : static gfc_ss *
12095 14481 : gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
12096 : {
12097 14481 : gcc_assert (expr->rank > 0);
12098 14481 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12099 : }
12100 :
12101 :
12102 : /* Return whether the function call expression EXPR will be expanded
12103 : inline by gfc_conv_intrinsic_function. */
12104 :
12105 : bool
12106 300052 : gfc_inline_intrinsic_function_p (gfc_expr *expr)
12107 : {
12108 300052 : gfc_actual_arglist *args, *dim_arg, *mask_arg;
12109 300052 : gfc_expr *maskexpr;
12110 :
12111 300052 : gfc_intrinsic_sym *isym = expr->value.function.isym;
12112 300052 : if (!isym)
12113 : return false;
12114 :
12115 300010 : switch (isym->id)
12116 : {
12117 5104 : case GFC_ISYM_PRODUCT:
12118 5104 : case GFC_ISYM_SUM:
12119 : /* Disable inline expansion if code size matters. */
12120 5104 : if (optimize_size)
12121 : return false;
12122 :
12123 4249 : args = expr->value.function.actual;
12124 4249 : dim_arg = args->next;
12125 :
12126 : /* We need to be able to subset the SUM argument at compile-time. */
12127 4249 : if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
12128 : return false;
12129 :
12130 : /* FIXME: If MASK is optional for a more than two-dimensional
12131 : argument, the scalarizer gets confused if the mask is
12132 : absent. See PR 82995. For now, fall back to the library
12133 : function. */
12134 :
12135 3637 : mask_arg = dim_arg->next;
12136 3637 : maskexpr = mask_arg->expr;
12137 :
12138 3637 : if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
12139 276 : && maskexpr->symtree->n.sym->attr.dummy
12140 48 : && maskexpr->symtree->n.sym->attr.optional)
12141 : return false;
12142 :
12143 : return true;
12144 :
12145 : case GFC_ISYM_TRANSPOSE:
12146 : return true;
12147 :
12148 57188 : case GFC_ISYM_MINLOC:
12149 57188 : case GFC_ISYM_MAXLOC:
12150 57188 : {
12151 57188 : if ((isym->id == GFC_ISYM_MINLOC
12152 30521 : && (flag_inline_intrinsics
12153 30521 : & GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0)
12154 46611 : || (isym->id == GFC_ISYM_MAXLOC
12155 26667 : && (flag_inline_intrinsics
12156 26667 : & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0))
12157 : return false;
12158 :
12159 37638 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12160 37638 : gfc_actual_arglist *dim_arg = array_arg->next;
12161 :
12162 37638 : gfc_expr *array = array_arg->expr;
12163 37638 : gfc_expr *dim = dim_arg->expr;
12164 :
12165 37638 : if (!(array->ts.type == BT_INTEGER
12166 : || array->ts.type == BT_REAL))
12167 : return false;
12168 :
12169 34658 : if (array->rank == 1)
12170 : return true;
12171 :
12172 20711 : if (dim != nullptr
12173 13372 : && dim->expr_type != EXPR_CONSTANT)
12174 : return false;
12175 :
12176 : return true;
12177 : }
12178 :
12179 : default:
12180 : return false;
12181 : }
12182 : }
12183 :
12184 :
12185 : /* Returns nonzero if the specified intrinsic function call maps directly to
12186 : an external library call. Should only be used for functions that return
12187 : arrays. */
12188 :
12189 : int
12190 87704 : gfc_is_intrinsic_libcall (gfc_expr * expr)
12191 : {
12192 87704 : gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
12193 87704 : gcc_assert (expr->rank > 0);
12194 :
12195 87704 : if (gfc_inline_intrinsic_function_p (expr))
12196 : return 0;
12197 :
12198 73123 : switch (expr->value.function.isym->id)
12199 : {
12200 : case GFC_ISYM_ALL:
12201 : case GFC_ISYM_ANY:
12202 : case GFC_ISYM_COUNT:
12203 : case GFC_ISYM_FINDLOC:
12204 : case GFC_ISYM_JN2:
12205 : case GFC_ISYM_IANY:
12206 : case GFC_ISYM_IALL:
12207 : case GFC_ISYM_IPARITY:
12208 : case GFC_ISYM_MATMUL:
12209 : case GFC_ISYM_MAXLOC:
12210 : case GFC_ISYM_MAXVAL:
12211 : case GFC_ISYM_MINLOC:
12212 : case GFC_ISYM_MINVAL:
12213 : case GFC_ISYM_NORM2:
12214 : case GFC_ISYM_PARITY:
12215 : case GFC_ISYM_PRODUCT:
12216 : case GFC_ISYM_SUM:
12217 : case GFC_ISYM_SPREAD:
12218 : case GFC_ISYM_YN2:
12219 : /* Ignore absent optional parameters. */
12220 : return 1;
12221 :
12222 15765 : case GFC_ISYM_CSHIFT:
12223 15765 : case GFC_ISYM_EOSHIFT:
12224 15765 : case GFC_ISYM_GET_TEAM:
12225 15765 : case GFC_ISYM_FAILED_IMAGES:
12226 15765 : case GFC_ISYM_STOPPED_IMAGES:
12227 15765 : case GFC_ISYM_PACK:
12228 15765 : case GFC_ISYM_REDUCE:
12229 15765 : case GFC_ISYM_RESHAPE:
12230 15765 : case GFC_ISYM_UNPACK:
12231 : /* Pass absent optional parameters. */
12232 15765 : return 2;
12233 :
12234 : default:
12235 : return 0;
12236 : }
12237 : }
12238 :
12239 : /* Walk an intrinsic function. */
12240 : gfc_ss *
12241 55583 : gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
12242 : gfc_intrinsic_sym * isym)
12243 : {
12244 55583 : gcc_assert (isym);
12245 :
12246 55583 : if (isym->elemental)
12247 18333 : return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
12248 : expr->value.function.isym,
12249 18333 : GFC_SS_SCALAR);
12250 :
12251 37250 : if (expr->rank == 0 && expr->corank == 0)
12252 : return ss;
12253 :
12254 32790 : if (gfc_inline_intrinsic_function_p (expr))
12255 8220 : return walk_inline_intrinsic_function (ss, expr);
12256 :
12257 24570 : if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
12258 13498 : return gfc_walk_intrinsic_libfunc (ss, expr);
12259 :
12260 : /* Special cases. */
12261 11072 : switch (isym->id)
12262 : {
12263 10089 : case GFC_ISYM_COSHAPE:
12264 10089 : case GFC_ISYM_LBOUND:
12265 10089 : case GFC_ISYM_LCOBOUND:
12266 10089 : case GFC_ISYM_UBOUND:
12267 10089 : case GFC_ISYM_UCOBOUND:
12268 10089 : case GFC_ISYM_THIS_IMAGE:
12269 10089 : case GFC_ISYM_SHAPE:
12270 10089 : return gfc_walk_intrinsic_bound (ss, expr);
12271 :
12272 983 : case GFC_ISYM_TRANSFER:
12273 983 : case GFC_ISYM_CAF_GET:
12274 983 : return gfc_walk_intrinsic_libfunc (ss, expr);
12275 :
12276 0 : default:
12277 : /* This probably meant someone forgot to add an intrinsic to the above
12278 : list(s) when they implemented it, or something's gone horribly
12279 : wrong. */
12280 0 : gcc_unreachable ();
12281 : }
12282 : }
12283 :
12284 : static tree
12285 88 : conv_co_collective (gfc_code *code)
12286 : {
12287 88 : gfc_se argse;
12288 88 : stmtblock_t block, post_block;
12289 88 : tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
12290 88 : gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
12291 :
12292 88 : gfc_start_block (&block);
12293 88 : gfc_init_block (&post_block);
12294 :
12295 88 : if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
12296 : {
12297 17 : opr_expr = code->ext.actual->next->expr;
12298 17 : image_idx_expr = code->ext.actual->next->next->expr;
12299 17 : stat_expr = code->ext.actual->next->next->next->expr;
12300 17 : errmsg_expr = code->ext.actual->next->next->next->next->expr;
12301 : }
12302 : else
12303 : {
12304 71 : opr_expr = NULL;
12305 71 : image_idx_expr = code->ext.actual->next->expr;
12306 71 : stat_expr = code->ext.actual->next->next->expr;
12307 71 : errmsg_expr = code->ext.actual->next->next->next->expr;
12308 : }
12309 :
12310 : /* stat. */
12311 88 : if (stat_expr)
12312 : {
12313 59 : gfc_init_se (&argse, NULL);
12314 59 : gfc_conv_expr (&argse, stat_expr);
12315 59 : gfc_add_block_to_block (&block, &argse.pre);
12316 59 : gfc_add_block_to_block (&post_block, &argse.post);
12317 59 : stat = argse.expr;
12318 59 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
12319 32 : stat = gfc_build_addr_expr (NULL_TREE, stat);
12320 : }
12321 29 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
12322 : stat = NULL_TREE;
12323 : else
12324 20 : stat = null_pointer_node;
12325 :
12326 : /* Early exit for GFC_FCOARRAY_SINGLE. */
12327 88 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
12328 : {
12329 36 : if (stat != NULL_TREE)
12330 : {
12331 : /* For optional stats, check the pointer is valid before zero'ing. */
12332 27 : if (gfc_expr_attr (stat_expr).optional)
12333 : {
12334 12 : tree tmp;
12335 12 : stmtblock_t ass_block;
12336 12 : gfc_start_block (&ass_block);
12337 12 : gfc_add_modify (&ass_block, stat,
12338 12 : fold_convert (TREE_TYPE (stat),
12339 : integer_zero_node));
12340 12 : tmp = fold_build2 (NE_EXPR, logical_type_node,
12341 : gfc_build_addr_expr (NULL_TREE, stat),
12342 : null_pointer_node);
12343 12 : tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
12344 : gfc_finish_block (&ass_block),
12345 : build_empty_stmt (input_location));
12346 12 : gfc_add_expr_to_block (&block, tmp);
12347 : }
12348 : else
12349 15 : gfc_add_modify (&block, stat,
12350 15 : fold_convert (TREE_TYPE (stat), integer_zero_node));
12351 : }
12352 36 : return gfc_finish_block (&block);
12353 : }
12354 :
12355 5 : gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
12356 52 : ? code->ext.actual->expr->ts.u.derived : NULL;
12357 :
12358 : /* Handle the array. */
12359 52 : gfc_init_se (&argse, NULL);
12360 52 : if (!derived || !derived->attr.alloc_comp
12361 1 : || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
12362 : {
12363 51 : if (code->ext.actual->expr->rank == 0)
12364 : {
12365 22 : symbol_attribute attr;
12366 22 : gfc_clear_attr (&attr);
12367 22 : gfc_init_se (&argse, NULL);
12368 22 : gfc_conv_expr (&argse, code->ext.actual->expr);
12369 22 : gfc_add_block_to_block (&block, &argse.pre);
12370 22 : gfc_add_block_to_block (&post_block, &argse.post);
12371 22 : array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
12372 22 : array = gfc_build_addr_expr (NULL_TREE, array);
12373 : }
12374 : else
12375 : {
12376 29 : argse.want_pointer = 1;
12377 29 : gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
12378 29 : array = argse.expr;
12379 : }
12380 : }
12381 :
12382 52 : gfc_add_block_to_block (&block, &argse.pre);
12383 52 : gfc_add_block_to_block (&post_block, &argse.post);
12384 :
12385 52 : if (code->ext.actual->expr->ts.type == BT_CHARACTER)
12386 15 : strlen = argse.string_length;
12387 : else
12388 37 : strlen = integer_zero_node;
12389 :
12390 : /* image_index. */
12391 52 : if (image_idx_expr)
12392 : {
12393 35 : gfc_init_se (&argse, NULL);
12394 35 : gfc_conv_expr (&argse, image_idx_expr);
12395 35 : gfc_add_block_to_block (&block, &argse.pre);
12396 35 : gfc_add_block_to_block (&post_block, &argse.post);
12397 35 : image_index = fold_convert (integer_type_node, argse.expr);
12398 : }
12399 : else
12400 17 : image_index = integer_zero_node;
12401 :
12402 : /* errmsg. */
12403 52 : if (errmsg_expr)
12404 : {
12405 25 : gfc_init_se (&argse, NULL);
12406 25 : gfc_conv_expr (&argse, errmsg_expr);
12407 25 : gfc_add_block_to_block (&block, &argse.pre);
12408 25 : gfc_add_block_to_block (&post_block, &argse.post);
12409 25 : errmsg = argse.expr;
12410 25 : errmsg_len = fold_convert (size_type_node, argse.string_length);
12411 : }
12412 : else
12413 : {
12414 27 : errmsg = null_pointer_node;
12415 27 : errmsg_len = build_zero_cst (size_type_node);
12416 : }
12417 :
12418 : /* Generate the function call. */
12419 52 : switch (code->resolved_isym->id)
12420 : {
12421 20 : case GFC_ISYM_CO_BROADCAST:
12422 20 : fndecl = gfor_fndecl_co_broadcast;
12423 20 : break;
12424 8 : case GFC_ISYM_CO_MAX:
12425 8 : fndecl = gfor_fndecl_co_max;
12426 8 : break;
12427 6 : case GFC_ISYM_CO_MIN:
12428 6 : fndecl = gfor_fndecl_co_min;
12429 6 : break;
12430 12 : case GFC_ISYM_CO_REDUCE:
12431 12 : fndecl = gfor_fndecl_co_reduce;
12432 12 : break;
12433 6 : case GFC_ISYM_CO_SUM:
12434 6 : fndecl = gfor_fndecl_co_sum;
12435 6 : break;
12436 0 : default:
12437 0 : gcc_unreachable ();
12438 : }
12439 :
12440 52 : if (derived && derived->attr.alloc_comp
12441 1 : && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12442 : /* The derived type has the attribute 'alloc_comp'. */
12443 : {
12444 2 : tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
12445 1 : code->ext.actual->expr->rank,
12446 : image_index, stat, errmsg, errmsg_len);
12447 1 : gfc_add_expr_to_block (&block, tmp);
12448 1 : }
12449 : else
12450 : {
12451 51 : if (code->resolved_isym->id == GFC_ISYM_CO_SUM
12452 45 : || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12453 25 : fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
12454 : image_index, stat, errmsg, errmsg_len);
12455 26 : else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
12456 14 : fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
12457 : image_index, stat, errmsg,
12458 : strlen, errmsg_len);
12459 : else
12460 : {
12461 12 : tree opr, opr_flags;
12462 :
12463 : // FIXME: Handle TS29113's bind(C) strings with descriptor.
12464 12 : int opr_flag_int;
12465 12 : if (gfc_is_proc_ptr_comp (opr_expr))
12466 : {
12467 0 : gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
12468 0 : opr_flag_int = sym->attr.dimension
12469 0 : || (sym->ts.type == BT_CHARACTER
12470 0 : && !sym->attr.is_bind_c)
12471 0 : ? GFC_CAF_BYREF : 0;
12472 0 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12473 0 : && !sym->attr.is_bind_c
12474 0 : ? GFC_CAF_HIDDENLEN : 0;
12475 0 : opr_flag_int |= sym->formal->sym->attr.value
12476 0 : ? GFC_CAF_ARG_VALUE : 0;
12477 : }
12478 : else
12479 : {
12480 12 : opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
12481 12 : ? GFC_CAF_BYREF : 0;
12482 24 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12483 0 : && !opr_expr->symtree->n.sym->attr.is_bind_c
12484 12 : ? GFC_CAF_HIDDENLEN : 0;
12485 12 : opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
12486 12 : ? GFC_CAF_ARG_VALUE : 0;
12487 : }
12488 12 : opr_flags = build_int_cst (integer_type_node, opr_flag_int);
12489 12 : gfc_conv_expr (&argse, opr_expr);
12490 12 : opr = argse.expr;
12491 12 : fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
12492 : opr_flags, image_index, stat, errmsg,
12493 : strlen, errmsg_len);
12494 : }
12495 : }
12496 :
12497 52 : gfc_add_expr_to_block (&block, fndecl);
12498 52 : gfc_add_block_to_block (&block, &post_block);
12499 :
12500 52 : return gfc_finish_block (&block);
12501 : }
12502 :
12503 :
12504 : static tree
12505 95 : conv_intrinsic_atomic_op (gfc_code *code)
12506 : {
12507 95 : gfc_se argse;
12508 95 : tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
12509 95 : stmtblock_t block, post_block;
12510 95 : gfc_expr *atom_expr = code->ext.actual->expr;
12511 95 : gfc_expr *stat_expr;
12512 95 : built_in_function fn;
12513 :
12514 95 : if (atom_expr->expr_type == EXPR_FUNCTION
12515 0 : && atom_expr->value.function.isym
12516 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12517 0 : atom_expr = atom_expr->value.function.actual->expr;
12518 :
12519 95 : gfc_start_block (&block);
12520 95 : gfc_init_block (&post_block);
12521 :
12522 95 : gfc_init_se (&argse, NULL);
12523 95 : argse.want_pointer = 1;
12524 95 : gfc_conv_expr (&argse, atom_expr);
12525 95 : gfc_add_block_to_block (&block, &argse.pre);
12526 95 : gfc_add_block_to_block (&post_block, &argse.post);
12527 95 : atom = argse.expr;
12528 :
12529 95 : gfc_init_se (&argse, NULL);
12530 95 : if (flag_coarray == GFC_FCOARRAY_LIB
12531 56 : && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
12532 54 : argse.want_pointer = 1;
12533 95 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12534 95 : gfc_add_block_to_block (&block, &argse.pre);
12535 95 : gfc_add_block_to_block (&post_block, &argse.post);
12536 95 : value = argse.expr;
12537 :
12538 95 : switch (code->resolved_isym->id)
12539 : {
12540 58 : case GFC_ISYM_ATOMIC_ADD:
12541 58 : case GFC_ISYM_ATOMIC_AND:
12542 58 : case GFC_ISYM_ATOMIC_DEF:
12543 58 : case GFC_ISYM_ATOMIC_OR:
12544 58 : case GFC_ISYM_ATOMIC_XOR:
12545 58 : stat_expr = code->ext.actual->next->next->expr;
12546 58 : if (flag_coarray == GFC_FCOARRAY_LIB)
12547 34 : old = null_pointer_node;
12548 : break;
12549 37 : default:
12550 37 : gfc_init_se (&argse, NULL);
12551 37 : if (flag_coarray == GFC_FCOARRAY_LIB)
12552 22 : argse.want_pointer = 1;
12553 37 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12554 37 : gfc_add_block_to_block (&block, &argse.pre);
12555 37 : gfc_add_block_to_block (&post_block, &argse.post);
12556 37 : old = argse.expr;
12557 37 : stat_expr = code->ext.actual->next->next->next->expr;
12558 : }
12559 :
12560 : /* STAT= */
12561 95 : if (stat_expr != NULL)
12562 : {
12563 82 : gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
12564 82 : gfc_init_se (&argse, NULL);
12565 82 : if (flag_coarray == GFC_FCOARRAY_LIB)
12566 48 : argse.want_pointer = 1;
12567 82 : gfc_conv_expr_val (&argse, stat_expr);
12568 82 : gfc_add_block_to_block (&block, &argse.pre);
12569 82 : gfc_add_block_to_block (&post_block, &argse.post);
12570 82 : stat = argse.expr;
12571 : }
12572 13 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12573 8 : stat = null_pointer_node;
12574 :
12575 95 : if (flag_coarray == GFC_FCOARRAY_LIB)
12576 : {
12577 56 : tree image_index, caf_decl, offset, token;
12578 56 : int op;
12579 :
12580 56 : switch (code->resolved_isym->id)
12581 : {
12582 : case GFC_ISYM_ATOMIC_ADD:
12583 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12584 : op = (int) GFC_CAF_ATOMIC_ADD;
12585 : break;
12586 12 : case GFC_ISYM_ATOMIC_AND:
12587 12 : case GFC_ISYM_ATOMIC_FETCH_AND:
12588 12 : op = (int) GFC_CAF_ATOMIC_AND;
12589 12 : break;
12590 12 : case GFC_ISYM_ATOMIC_OR:
12591 12 : case GFC_ISYM_ATOMIC_FETCH_OR:
12592 12 : op = (int) GFC_CAF_ATOMIC_OR;
12593 12 : break;
12594 12 : case GFC_ISYM_ATOMIC_XOR:
12595 12 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12596 12 : op = (int) GFC_CAF_ATOMIC_XOR;
12597 12 : break;
12598 11 : case GFC_ISYM_ATOMIC_DEF:
12599 11 : op = 0; /* Unused. */
12600 11 : break;
12601 0 : default:
12602 0 : gcc_unreachable ();
12603 : }
12604 :
12605 56 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12606 56 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12607 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12608 :
12609 56 : if (gfc_is_coindexed (atom_expr))
12610 48 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12611 : else
12612 8 : image_index = integer_zero_node;
12613 :
12614 : /* Ensure VALUE names addressable storage: taking the address of a
12615 : constant is invalid in C, and scalars need a temporary as well. */
12616 56 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12617 : {
12618 42 : tree elem
12619 42 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value);
12620 42 : elem = gfc_trans_force_lval (&block, elem);
12621 42 : value = gfc_build_addr_expr (NULL_TREE, elem);
12622 : }
12623 14 : else if (TREE_CODE (value) == ADDR_EXPR
12624 14 : && TREE_CONSTANT (TREE_OPERAND (value, 0)))
12625 : {
12626 0 : tree elem
12627 0 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)),
12628 : build_fold_indirect_ref (value));
12629 0 : elem = gfc_trans_force_lval (&block, elem);
12630 0 : value = gfc_build_addr_expr (NULL_TREE, elem);
12631 : }
12632 :
12633 56 : gfc_init_se (&argse, NULL);
12634 56 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12635 : atom_expr);
12636 :
12637 56 : gfc_add_block_to_block (&block, &argse.pre);
12638 56 : if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
12639 11 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
12640 : token, offset, image_index, value, stat,
12641 : build_int_cst (integer_type_node,
12642 11 : (int) atom_expr->ts.type),
12643 : build_int_cst (integer_type_node,
12644 11 : (int) atom_expr->ts.kind));
12645 : else
12646 45 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
12647 45 : build_int_cst (integer_type_node, op),
12648 : token, offset, image_index, value, old, stat,
12649 : build_int_cst (integer_type_node,
12650 45 : (int) atom_expr->ts.type),
12651 : build_int_cst (integer_type_node,
12652 45 : (int) atom_expr->ts.kind));
12653 :
12654 56 : gfc_add_expr_to_block (&block, tmp);
12655 56 : gfc_add_block_to_block (&block, &argse.post);
12656 56 : gfc_add_block_to_block (&block, &post_block);
12657 56 : return gfc_finish_block (&block);
12658 : }
12659 :
12660 :
12661 39 : switch (code->resolved_isym->id)
12662 : {
12663 : case GFC_ISYM_ATOMIC_ADD:
12664 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12665 : fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
12666 : break;
12667 8 : case GFC_ISYM_ATOMIC_AND:
12668 8 : case GFC_ISYM_ATOMIC_FETCH_AND:
12669 8 : fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12670 8 : break;
12671 9 : case GFC_ISYM_ATOMIC_DEF:
12672 9 : fn = BUILT_IN_ATOMIC_STORE_N;
12673 9 : break;
12674 8 : case GFC_ISYM_ATOMIC_OR:
12675 8 : case GFC_ISYM_ATOMIC_FETCH_OR:
12676 8 : fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12677 8 : break;
12678 8 : case GFC_ISYM_ATOMIC_XOR:
12679 8 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12680 8 : fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12681 8 : break;
12682 0 : default:
12683 0 : gcc_unreachable ();
12684 : }
12685 :
12686 39 : tmp = TREE_TYPE (TREE_TYPE (atom));
12687 78 : fn = (built_in_function) ((int) fn
12688 39 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12689 39 : + 1);
12690 39 : tree itype = TREE_TYPE (TREE_TYPE (atom));
12691 39 : tmp = builtin_decl_explicit (fn);
12692 :
12693 39 : switch (code->resolved_isym->id)
12694 : {
12695 24 : case GFC_ISYM_ATOMIC_ADD:
12696 24 : case GFC_ISYM_ATOMIC_AND:
12697 24 : case GFC_ISYM_ATOMIC_DEF:
12698 24 : case GFC_ISYM_ATOMIC_OR:
12699 24 : case GFC_ISYM_ATOMIC_XOR:
12700 24 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12701 : fold_convert (itype, value),
12702 : build_int_cst (NULL, MEMMODEL_RELAXED));
12703 24 : gfc_add_expr_to_block (&block, tmp);
12704 24 : break;
12705 15 : default:
12706 15 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12707 : fold_convert (itype, value),
12708 : build_int_cst (NULL, MEMMODEL_RELAXED));
12709 15 : gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12710 15 : break;
12711 : }
12712 :
12713 39 : if (stat != NULL_TREE)
12714 34 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12715 39 : gfc_add_block_to_block (&block, &post_block);
12716 39 : return gfc_finish_block (&block);
12717 : }
12718 :
12719 :
12720 : static tree
12721 176 : conv_intrinsic_atomic_ref (gfc_code *code)
12722 : {
12723 176 : gfc_se argse;
12724 176 : tree tmp, atom, value, stat = NULL_TREE;
12725 176 : stmtblock_t block, post_block;
12726 176 : built_in_function fn;
12727 176 : gfc_expr *atom_expr = code->ext.actual->next->expr;
12728 :
12729 176 : if (atom_expr->expr_type == EXPR_FUNCTION
12730 0 : && atom_expr->value.function.isym
12731 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12732 0 : atom_expr = atom_expr->value.function.actual->expr;
12733 :
12734 176 : gfc_start_block (&block);
12735 176 : gfc_init_block (&post_block);
12736 176 : gfc_init_se (&argse, NULL);
12737 176 : argse.want_pointer = 1;
12738 176 : gfc_conv_expr (&argse, atom_expr);
12739 176 : gfc_add_block_to_block (&block, &argse.pre);
12740 176 : gfc_add_block_to_block (&post_block, &argse.post);
12741 176 : atom = argse.expr;
12742 :
12743 176 : gfc_init_se (&argse, NULL);
12744 176 : if (flag_coarray == GFC_FCOARRAY_LIB
12745 115 : && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12746 109 : argse.want_pointer = 1;
12747 176 : gfc_conv_expr (&argse, code->ext.actual->expr);
12748 176 : gfc_add_block_to_block (&block, &argse.pre);
12749 176 : gfc_add_block_to_block (&post_block, &argse.post);
12750 176 : value = argse.expr;
12751 :
12752 : /* STAT= */
12753 176 : if (code->ext.actual->next->next->expr != NULL)
12754 : {
12755 164 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12756 : == EXPR_VARIABLE);
12757 164 : gfc_init_se (&argse, NULL);
12758 164 : if (flag_coarray == GFC_FCOARRAY_LIB)
12759 108 : argse.want_pointer = 1;
12760 164 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12761 164 : gfc_add_block_to_block (&block, &argse.pre);
12762 164 : gfc_add_block_to_block (&post_block, &argse.post);
12763 164 : stat = argse.expr;
12764 : }
12765 12 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12766 7 : stat = null_pointer_node;
12767 :
12768 176 : if (flag_coarray == GFC_FCOARRAY_LIB)
12769 : {
12770 115 : tree image_index, caf_decl, offset, token;
12771 115 : tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12772 :
12773 115 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12774 115 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12775 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12776 :
12777 115 : if (gfc_is_coindexed (atom_expr))
12778 103 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12779 : else
12780 12 : image_index = integer_zero_node;
12781 :
12782 115 : gfc_init_se (&argse, NULL);
12783 115 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12784 : atom_expr);
12785 115 : gfc_add_block_to_block (&block, &argse.pre);
12786 :
12787 : /* Different type, need type conversion. */
12788 115 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12789 : {
12790 6 : vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12791 6 : orig_value = value;
12792 6 : value = gfc_build_addr_expr (NULL_TREE, vardecl);
12793 : }
12794 :
12795 115 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12796 : token, offset, image_index, value, stat,
12797 : build_int_cst (integer_type_node,
12798 115 : (int) atom_expr->ts.type),
12799 : build_int_cst (integer_type_node,
12800 115 : (int) atom_expr->ts.kind));
12801 115 : gfc_add_expr_to_block (&block, tmp);
12802 115 : if (vardecl != NULL_TREE)
12803 6 : gfc_add_modify (&block, orig_value,
12804 6 : fold_convert (TREE_TYPE (orig_value), vardecl));
12805 115 : gfc_add_block_to_block (&block, &argse.post);
12806 115 : gfc_add_block_to_block (&block, &post_block);
12807 115 : return gfc_finish_block (&block);
12808 : }
12809 :
12810 61 : tmp = TREE_TYPE (TREE_TYPE (atom));
12811 122 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12812 61 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12813 61 : + 1);
12814 61 : tmp = builtin_decl_explicit (fn);
12815 61 : tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12816 : build_int_cst (integer_type_node,
12817 : MEMMODEL_RELAXED));
12818 61 : gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12819 :
12820 61 : if (stat != NULL_TREE)
12821 56 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12822 61 : gfc_add_block_to_block (&block, &post_block);
12823 61 : return gfc_finish_block (&block);
12824 : }
12825 :
12826 :
12827 : static tree
12828 14 : conv_intrinsic_atomic_cas (gfc_code *code)
12829 : {
12830 14 : gfc_se argse;
12831 14 : tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12832 14 : stmtblock_t block, post_block;
12833 14 : built_in_function fn;
12834 14 : gfc_expr *atom_expr = code->ext.actual->expr;
12835 :
12836 14 : if (atom_expr->expr_type == EXPR_FUNCTION
12837 0 : && atom_expr->value.function.isym
12838 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12839 0 : atom_expr = atom_expr->value.function.actual->expr;
12840 :
12841 14 : gfc_init_block (&block);
12842 14 : gfc_init_block (&post_block);
12843 14 : gfc_init_se (&argse, NULL);
12844 14 : argse.want_pointer = 1;
12845 14 : gfc_conv_expr (&argse, atom_expr);
12846 14 : atom = argse.expr;
12847 :
12848 14 : gfc_init_se (&argse, NULL);
12849 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12850 8 : argse.want_pointer = 1;
12851 14 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12852 14 : gfc_add_block_to_block (&block, &argse.pre);
12853 14 : gfc_add_block_to_block (&post_block, &argse.post);
12854 14 : old = argse.expr;
12855 :
12856 14 : gfc_init_se (&argse, NULL);
12857 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12858 8 : argse.want_pointer = 1;
12859 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12860 14 : gfc_add_block_to_block (&block, &argse.pre);
12861 14 : gfc_add_block_to_block (&post_block, &argse.post);
12862 14 : comp = argse.expr;
12863 :
12864 14 : gfc_init_se (&argse, NULL);
12865 14 : if (flag_coarray == GFC_FCOARRAY_LIB
12866 8 : && code->ext.actual->next->next->next->expr->ts.kind
12867 8 : == atom_expr->ts.kind)
12868 8 : argse.want_pointer = 1;
12869 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
12870 14 : gfc_add_block_to_block (&block, &argse.pre);
12871 14 : gfc_add_block_to_block (&post_block, &argse.post);
12872 14 : new_val = argse.expr;
12873 :
12874 : /* STAT= */
12875 14 : if (code->ext.actual->next->next->next->next->expr != NULL)
12876 : {
12877 14 : gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
12878 : == EXPR_VARIABLE);
12879 14 : gfc_init_se (&argse, NULL);
12880 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12881 8 : argse.want_pointer = 1;
12882 14 : gfc_conv_expr_val (&argse,
12883 14 : code->ext.actual->next->next->next->next->expr);
12884 14 : gfc_add_block_to_block (&block, &argse.pre);
12885 14 : gfc_add_block_to_block (&post_block, &argse.post);
12886 14 : stat = argse.expr;
12887 : }
12888 0 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12889 0 : stat = null_pointer_node;
12890 :
12891 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12892 : {
12893 8 : tree image_index, caf_decl, offset, token;
12894 :
12895 8 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12896 8 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12897 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12898 :
12899 8 : if (gfc_is_coindexed (atom_expr))
12900 8 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12901 : else
12902 0 : image_index = integer_zero_node;
12903 :
12904 8 : if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
12905 : {
12906 0 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
12907 0 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
12908 0 : new_val = gfc_build_addr_expr (NULL_TREE, tmp);
12909 : }
12910 :
12911 8 : gfc_init_se (&argse, NULL);
12912 8 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12913 : atom_expr);
12914 8 : gfc_add_block_to_block (&block, &argse.pre);
12915 :
12916 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
12917 : token, offset, image_index, old, comp, new_val,
12918 : stat, build_int_cst (integer_type_node,
12919 8 : (int) atom_expr->ts.type),
12920 : build_int_cst (integer_type_node,
12921 8 : (int) atom_expr->ts.kind));
12922 8 : gfc_add_expr_to_block (&block, tmp);
12923 8 : gfc_add_block_to_block (&block, &argse.post);
12924 8 : gfc_add_block_to_block (&block, &post_block);
12925 8 : return gfc_finish_block (&block);
12926 : }
12927 :
12928 6 : tmp = TREE_TYPE (TREE_TYPE (atom));
12929 12 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
12930 6 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12931 6 : + 1);
12932 6 : tmp = builtin_decl_explicit (fn);
12933 :
12934 6 : gfc_add_modify (&block, old, comp);
12935 12 : tmp = build_call_expr_loc (input_location, tmp, 6, atom,
12936 : gfc_build_addr_expr (NULL, old),
12937 6 : fold_convert (TREE_TYPE (old), new_val),
12938 : boolean_false_node,
12939 : build_int_cst (NULL, MEMMODEL_RELAXED),
12940 : build_int_cst (NULL, MEMMODEL_RELAXED));
12941 6 : gfc_add_expr_to_block (&block, tmp);
12942 :
12943 6 : if (stat != NULL_TREE)
12944 6 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12945 6 : gfc_add_block_to_block (&block, &post_block);
12946 6 : return gfc_finish_block (&block);
12947 : }
12948 :
12949 : static tree
12950 105 : conv_intrinsic_event_query (gfc_code *code)
12951 : {
12952 105 : gfc_se se, argse;
12953 105 : tree stat = NULL_TREE, stat2 = NULL_TREE;
12954 105 : tree count = NULL_TREE, count2 = NULL_TREE;
12955 :
12956 105 : gfc_expr *event_expr = code->ext.actual->expr;
12957 :
12958 105 : if (code->ext.actual->next->next->expr)
12959 : {
12960 18 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12961 : == EXPR_VARIABLE);
12962 18 : gfc_init_se (&argse, NULL);
12963 18 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12964 18 : stat = argse.expr;
12965 : }
12966 87 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12967 58 : stat = null_pointer_node;
12968 :
12969 105 : if (code->ext.actual->next->expr)
12970 : {
12971 105 : gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
12972 105 : gfc_init_se (&argse, NULL);
12973 105 : gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
12974 105 : count = argse.expr;
12975 : }
12976 :
12977 105 : gfc_start_block (&se.pre);
12978 105 : if (flag_coarray == GFC_FCOARRAY_LIB)
12979 : {
12980 70 : tree tmp, token, image_index;
12981 70 : tree index = build_zero_cst (gfc_array_index_type);
12982 :
12983 70 : if (event_expr->expr_type == EXPR_FUNCTION
12984 0 : && event_expr->value.function.isym
12985 0 : && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12986 0 : event_expr = event_expr->value.function.actual->expr;
12987 :
12988 70 : tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
12989 :
12990 70 : if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
12991 70 : || event_expr->symtree->n.sym->ts.u.derived->from_intmod
12992 : != INTMOD_ISO_FORTRAN_ENV
12993 70 : || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
12994 : != ISOFORTRAN_EVENT_TYPE)
12995 : {
12996 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
12997 : "yet supported", &event_expr->where);
12998 0 : return NULL_TREE;
12999 : }
13000 :
13001 70 : if (gfc_is_coindexed (event_expr))
13002 : {
13003 0 : gfc_error ("The event variable at %L shall not be coindexed",
13004 : &event_expr->where);
13005 0 : return NULL_TREE;
13006 : }
13007 :
13008 70 : image_index = integer_zero_node;
13009 :
13010 70 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
13011 : event_expr);
13012 :
13013 : /* For arrays, obtain the array index. */
13014 70 : if (gfc_expr_attr (event_expr).dimension)
13015 : {
13016 52 : tree desc, tmp, extent, lbound, ubound;
13017 52 : gfc_array_ref *ar, ar2;
13018 52 : int i;
13019 :
13020 : /* TODO: Extend this, once DT components are supported. */
13021 52 : ar = &event_expr->ref->u.ar;
13022 52 : ar2 = *ar;
13023 52 : memset (ar, '\0', sizeof (*ar));
13024 52 : ar->as = ar2.as;
13025 52 : ar->type = AR_FULL;
13026 :
13027 52 : gfc_init_se (&argse, NULL);
13028 52 : argse.descriptor_only = 1;
13029 52 : gfc_conv_expr_descriptor (&argse, event_expr);
13030 52 : gfc_add_block_to_block (&se.pre, &argse.pre);
13031 52 : desc = argse.expr;
13032 52 : *ar = ar2;
13033 :
13034 52 : extent = build_one_cst (gfc_array_index_type);
13035 156 : for (i = 0; i < ar->dimen; i++)
13036 : {
13037 52 : gfc_init_se (&argse, NULL);
13038 52 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
13039 52 : gfc_add_block_to_block (&argse.pre, &argse.pre);
13040 52 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
13041 52 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
13042 52 : TREE_TYPE (lbound), argse.expr, lbound);
13043 52 : tmp = fold_build2_loc (input_location, MULT_EXPR,
13044 52 : TREE_TYPE (tmp), extent, tmp);
13045 52 : index = fold_build2_loc (input_location, PLUS_EXPR,
13046 52 : TREE_TYPE (tmp), index, tmp);
13047 52 : if (i < ar->dimen - 1)
13048 : {
13049 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
13050 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
13051 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
13052 0 : TREE_TYPE (tmp), extent, tmp);
13053 : }
13054 : }
13055 : }
13056 :
13057 70 : if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
13058 : {
13059 0 : count2 = count;
13060 0 : count = gfc_create_var (integer_type_node, "count");
13061 : }
13062 :
13063 70 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
13064 : {
13065 0 : stat2 = stat;
13066 0 : stat = gfc_create_var (integer_type_node, "stat");
13067 : }
13068 :
13069 70 : index = fold_convert (size_type_node, index);
13070 140 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
13071 : token, index, image_index, count
13072 70 : ? gfc_build_addr_expr (NULL, count) : count,
13073 70 : stat != null_pointer_node
13074 12 : ? gfc_build_addr_expr (NULL, stat) : stat);
13075 70 : gfc_add_expr_to_block (&se.pre, tmp);
13076 :
13077 70 : if (count2 != NULL_TREE)
13078 0 : gfc_add_modify (&se.pre, count2,
13079 0 : fold_convert (TREE_TYPE (count2), count));
13080 :
13081 70 : if (stat2 != NULL_TREE)
13082 0 : gfc_add_modify (&se.pre, stat2,
13083 0 : fold_convert (TREE_TYPE (stat2), stat));
13084 :
13085 70 : return gfc_finish_block (&se.pre);
13086 : }
13087 :
13088 35 : gfc_init_se (&argse, NULL);
13089 35 : gfc_conv_expr_val (&argse, code->ext.actual->expr);
13090 35 : gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
13091 :
13092 35 : if (stat != NULL_TREE)
13093 6 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
13094 :
13095 35 : return gfc_finish_block (&se.pre);
13096 : }
13097 :
13098 :
13099 : /* This is a peculiar case because of the need to do dependency checking.
13100 : It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
13101 : a special case and this function called instead of
13102 : gfc_conv_procedure_call. */
13103 : void
13104 197 : gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
13105 : gfc_loopinfo *loop)
13106 : {
13107 197 : gfc_actual_arglist *actual;
13108 197 : gfc_se argse[5];
13109 197 : gfc_expr *arg[5];
13110 197 : gfc_ss *lss;
13111 197 : int n;
13112 :
13113 197 : tree from, frompos, len, to, topos;
13114 197 : tree lenmask, oldbits, newbits, bitsize;
13115 197 : tree type, utype, above, mask1, mask2;
13116 :
13117 197 : if (loop)
13118 67 : lss = loop->ss;
13119 : else
13120 130 : lss = gfc_ss_terminator;
13121 :
13122 : actual = actual_args;
13123 1182 : for (n = 0; n < 5; n++, actual = actual->next)
13124 : {
13125 985 : arg[n] = actual->expr;
13126 985 : gfc_init_se (&argse[n], NULL);
13127 :
13128 985 : if (lss != gfc_ss_terminator)
13129 : {
13130 335 : gfc_copy_loopinfo_to_se (&argse[n], loop);
13131 : /* Find the ss for the expression if it is there. */
13132 335 : argse[n].ss = lss;
13133 335 : gfc_mark_ss_chain_used (lss, 1);
13134 : }
13135 :
13136 985 : gfc_conv_expr (&argse[n], arg[n]);
13137 :
13138 985 : if (loop)
13139 335 : lss = argse[n].ss;
13140 : }
13141 :
13142 197 : from = argse[0].expr;
13143 197 : frompos = argse[1].expr;
13144 197 : len = argse[2].expr;
13145 197 : to = argse[3].expr;
13146 197 : topos = argse[4].expr;
13147 :
13148 : /* The type of the result (TO). */
13149 197 : type = TREE_TYPE (to);
13150 197 : bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
13151 :
13152 : /* Optionally generate code for runtime argument check. */
13153 197 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
13154 : {
13155 18 : tree nbits, below, ccond;
13156 18 : tree fp = fold_convert (long_integer_type_node, frompos);
13157 18 : tree ln = fold_convert (long_integer_type_node, len);
13158 18 : tree tp = fold_convert (long_integer_type_node, topos);
13159 18 : below = fold_build2_loc (input_location, LT_EXPR,
13160 : logical_type_node, frompos,
13161 18 : build_int_cst (TREE_TYPE (frompos), 0));
13162 18 : above = fold_build2_loc (input_location, GT_EXPR,
13163 : logical_type_node, frompos,
13164 18 : fold_convert (TREE_TYPE (frompos), bitsize));
13165 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13166 : logical_type_node, below, above);
13167 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13168 18 : &arg[1]->where,
13169 : "FROMPOS argument (%ld) out of range 0:%d "
13170 : "in intrinsic MVBITS", fp, bitsize);
13171 18 : below = fold_build2_loc (input_location, LT_EXPR,
13172 : logical_type_node, len,
13173 18 : build_int_cst (TREE_TYPE (len), 0));
13174 18 : above = fold_build2_loc (input_location, GT_EXPR,
13175 : logical_type_node, len,
13176 18 : fold_convert (TREE_TYPE (len), bitsize));
13177 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13178 : logical_type_node, below, above);
13179 18 : gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
13180 18 : &arg[2]->where,
13181 : "LEN argument (%ld) out of range 0:%d "
13182 : "in intrinsic MVBITS", ln, bitsize);
13183 18 : below = fold_build2_loc (input_location, LT_EXPR,
13184 : logical_type_node, topos,
13185 18 : build_int_cst (TREE_TYPE (topos), 0));
13186 18 : above = fold_build2_loc (input_location, GT_EXPR,
13187 : logical_type_node, topos,
13188 18 : fold_convert (TREE_TYPE (topos), bitsize));
13189 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13190 : logical_type_node, below, above);
13191 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13192 18 : &arg[4]->where,
13193 : "TOPOS argument (%ld) out of range 0:%d "
13194 : "in intrinsic MVBITS", tp, bitsize);
13195 :
13196 : /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
13197 : integers. Additions below cannot overflow. */
13198 18 : nbits = fold_convert (long_integer_type_node, bitsize);
13199 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13200 : long_integer_type_node, fp, ln);
13201 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13202 : logical_type_node, above, nbits);
13203 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13204 : &arg[1]->where,
13205 : "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13206 : "in intrinsic MVBITS", fp, ln, bitsize);
13207 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13208 : long_integer_type_node, tp, ln);
13209 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13210 : logical_type_node, above, nbits);
13211 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13212 : &arg[4]->where,
13213 : "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13214 : "in intrinsic MVBITS", tp, ln, bitsize);
13215 : }
13216 :
13217 1182 : for (n = 0; n < 5; n++)
13218 : {
13219 985 : gfc_add_block_to_block (&se->pre, &argse[n].pre);
13220 985 : gfc_add_block_to_block (&se->post, &argse[n].post);
13221 : }
13222 :
13223 : /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
13224 197 : above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
13225 197 : len, fold_convert (TREE_TYPE (len), bitsize));
13226 197 : mask1 = build_int_cst (type, -1);
13227 197 : mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13228 : build_int_cst (type, 1), len);
13229 197 : mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
13230 : mask2, build_int_cst (type, 1));
13231 197 : lenmask = fold_build3_loc (input_location, COND_EXPR, type,
13232 : above, mask1, mask2);
13233 :
13234 : /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
13235 : * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
13236 : * not strictly necessary; artificial bits from rshift will be masked. */
13237 197 : utype = unsigned_type_for (type);
13238 197 : newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
13239 : fold_convert (utype, from), frompos);
13240 197 : newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
13241 : fold_convert (type, newbits), lenmask);
13242 197 : newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13243 : newbits, topos);
13244 :
13245 : /* oldbits = TO & (~(lenmask << TOPOS)). */
13246 197 : oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13247 : lenmask, topos);
13248 197 : oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
13249 197 : oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
13250 :
13251 : /* TO = newbits | oldbits. */
13252 197 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
13253 : oldbits, newbits);
13254 :
13255 : /* Return the assignment. */
13256 197 : se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
13257 : void_type_node, to, se->expr);
13258 197 : }
13259 :
13260 : /* Comes from trans-stmt.cc, but we don't want the whole header included. */
13261 : extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
13262 : tree *stat, tree *errmsg, tree *errmsg_len);
13263 :
13264 : static tree
13265 263 : conv_intrinsic_move_alloc (gfc_code *code)
13266 : {
13267 263 : stmtblock_t block;
13268 263 : gfc_expr *from_expr, *to_expr;
13269 263 : gfc_se from_se, to_se;
13270 263 : tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE;
13271 263 : bool coarray, from_is_class, from_is_scalar;
13272 263 : gfc_actual_arglist *arg = code->ext.actual;
13273 263 : sync_stat tmp_sync_stat = {nullptr, nullptr};
13274 :
13275 263 : gfc_start_block (&block);
13276 :
13277 263 : from_expr = arg->expr;
13278 263 : arg = arg->next;
13279 263 : to_expr = arg->expr;
13280 263 : arg = arg->next;
13281 :
13282 789 : while (arg)
13283 : {
13284 526 : if (arg->expr)
13285 : {
13286 0 : if (!strcmp ("stat", arg->name))
13287 0 : tmp_sync_stat.stat = arg->expr;
13288 0 : else if (!strcmp ("errmsg", arg->name))
13289 0 : tmp_sync_stat.errmsg = arg->expr;
13290 : }
13291 526 : arg = arg->next;
13292 : }
13293 :
13294 263 : gfc_init_se (&from_se, NULL);
13295 263 : gfc_init_se (&to_se, NULL);
13296 :
13297 263 : gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len);
13298 263 : if (stat != null_pointer_node)
13299 0 : fin_label = gfc_build_label_decl (NULL_TREE);
13300 :
13301 263 : gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
13302 263 : coarray = from_expr->corank != 0;
13303 :
13304 263 : from_is_class = from_expr->ts.type == BT_CLASS;
13305 263 : from_is_scalar = from_expr->rank == 0 && !coarray;
13306 263 : if (to_expr->ts.type == BT_CLASS || from_is_scalar)
13307 : {
13308 163 : from_se.want_pointer = 1;
13309 163 : if (from_is_scalar)
13310 115 : gfc_conv_expr (&from_se, from_expr);
13311 : else
13312 48 : gfc_conv_expr_descriptor (&from_se, from_expr);
13313 163 : if (from_is_class)
13314 64 : from_tree = gfc_class_data_get (from_se.expr);
13315 : else
13316 : {
13317 99 : gfc_symbol *vtab;
13318 99 : from_tree = from_se.expr;
13319 :
13320 99 : if (to_expr->ts.type == BT_CLASS)
13321 : {
13322 36 : vtab = gfc_find_vtab (&from_expr->ts);
13323 36 : gcc_assert (vtab);
13324 36 : from_se.expr = gfc_get_symbol_decl (vtab);
13325 : }
13326 : }
13327 163 : gfc_add_block_to_block (&block, &from_se.pre);
13328 :
13329 163 : to_se.want_pointer = 1;
13330 163 : if (to_expr->rank == 0)
13331 115 : gfc_conv_expr (&to_se, to_expr);
13332 : else
13333 48 : gfc_conv_expr_descriptor (&to_se, to_expr);
13334 163 : if (to_expr->ts.type == BT_CLASS)
13335 100 : to_tree = gfc_class_data_get (to_se.expr);
13336 : else
13337 63 : to_tree = to_se.expr;
13338 163 : gfc_add_block_to_block (&block, &to_se.pre);
13339 :
13340 : /* Deallocate "to". */
13341 163 : if (to_expr->rank == 0)
13342 : {
13343 115 : tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
13344 : true, to_expr, to_expr->ts,
13345 : NULL_TREE, false, true,
13346 : errmsg, errmsg_len);
13347 115 : gfc_add_expr_to_block (&block, tmp);
13348 : }
13349 :
13350 163 : if (from_is_scalar)
13351 : {
13352 : /* Assign (_data) pointers. */
13353 115 : gfc_add_modify_loc (input_location, &block, to_tree,
13354 115 : fold_convert (TREE_TYPE (to_tree), from_tree));
13355 :
13356 : /* Set "from" to NULL. */
13357 115 : gfc_add_modify_loc (input_location, &block, from_tree,
13358 115 : fold_convert (TREE_TYPE (from_tree),
13359 : null_pointer_node));
13360 :
13361 115 : gfc_add_block_to_block (&block, &from_se.post);
13362 : }
13363 163 : gfc_add_block_to_block (&block, &to_se.post);
13364 :
13365 : /* Set _vptr. */
13366 163 : if (to_expr->ts.type == BT_CLASS)
13367 : {
13368 100 : gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
13369 100 : if (from_is_class)
13370 64 : gfc_reset_vptr (&block, from_expr);
13371 100 : if (UNLIMITED_POLY (to_expr))
13372 : {
13373 20 : tree to_len = gfc_class_len_get (to_se.class_container);
13374 20 : tmp = from_expr->ts.type == BT_CHARACTER && from_se.string_length
13375 20 : ? from_se.string_length
13376 : : size_zero_node;
13377 20 : gfc_add_modify_loc (input_location, &block, to_len,
13378 20 : fold_convert (TREE_TYPE (to_len), tmp));
13379 : }
13380 : }
13381 :
13382 163 : if (from_is_scalar)
13383 : {
13384 115 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13385 : {
13386 6 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13387 6 : fold_convert (TREE_TYPE (to_se.string_length),
13388 : from_se.string_length));
13389 6 : if (from_expr->ts.deferred)
13390 6 : gfc_add_modify_loc (
13391 : input_location, &block, from_se.string_length,
13392 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13393 : }
13394 115 : if (UNLIMITED_POLY (from_expr))
13395 2 : gfc_reset_len (&block, from_expr);
13396 :
13397 115 : return gfc_finish_block (&block);
13398 : }
13399 :
13400 48 : gfc_init_se (&to_se, NULL);
13401 48 : gfc_init_se (&from_se, NULL);
13402 : }
13403 :
13404 : /* Deallocate "to". */
13405 148 : if (from_expr->rank == 0)
13406 : {
13407 4 : to_se.want_coarray = 1;
13408 4 : from_se.want_coarray = 1;
13409 : }
13410 148 : gfc_conv_expr_descriptor (&to_se, to_expr);
13411 148 : gfc_conv_expr_descriptor (&from_se, from_expr);
13412 148 : gfc_add_block_to_block (&block, &to_se.pre);
13413 148 : gfc_add_block_to_block (&block, &from_se.pre);
13414 :
13415 : /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
13416 : is an image control "statement", cf. IR F08/0040 in 12-006A. */
13417 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13418 : {
13419 6 : tree cond;
13420 :
13421 6 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13422 : fin_label, true, to_expr,
13423 : GFC_CAF_COARRAY_DEALLOCATE_ONLY,
13424 : NULL_TREE, NULL_TREE,
13425 : gfc_conv_descriptor_token (to_se.expr),
13426 : true);
13427 6 : gfc_add_expr_to_block (&block, tmp);
13428 :
13429 6 : tmp = gfc_conv_descriptor_data_get (to_se.expr);
13430 6 : cond = fold_build2_loc (input_location, EQ_EXPR,
13431 : logical_type_node, tmp,
13432 6 : fold_convert (TREE_TYPE (tmp),
13433 : null_pointer_node));
13434 6 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
13435 : 3, null_pointer_node, null_pointer_node,
13436 : integer_zero_node);
13437 :
13438 6 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
13439 : tmp, build_empty_stmt (input_location));
13440 6 : gfc_add_expr_to_block (&block, tmp);
13441 6 : }
13442 : else
13443 : {
13444 142 : if (to_expr->ts.type == BT_DERIVED
13445 25 : && to_expr->ts.u.derived->attr.alloc_comp)
13446 : {
13447 19 : tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
13448 : to_se.expr, to_expr->rank);
13449 19 : gfc_add_expr_to_block (&block, tmp);
13450 : }
13451 :
13452 142 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13453 : fin_label, true, to_expr,
13454 : GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
13455 : NULL_TREE, NULL_TREE, true);
13456 142 : gfc_add_expr_to_block (&block, tmp);
13457 : }
13458 :
13459 : /* Copy the array descriptor data. */
13460 148 : gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
13461 :
13462 : /* Set "from" to NULL. */
13463 148 : tmp = gfc_conv_descriptor_data_get (from_se.expr);
13464 148 : gfc_add_modify_loc (input_location, &block, tmp,
13465 148 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
13466 :
13467 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13468 : {
13469 : /* Copy the array descriptor data has overwritten the to-token and cleared
13470 : from.data. Now also clear the from.token. */
13471 6 : gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr),
13472 : null_pointer_node);
13473 : }
13474 :
13475 148 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13476 : {
13477 7 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13478 7 : fold_convert (TREE_TYPE (to_se.string_length),
13479 : from_se.string_length));
13480 7 : if (from_expr->ts.deferred)
13481 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
13482 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13483 : }
13484 148 : if (fin_label)
13485 0 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
13486 :
13487 148 : gfc_add_block_to_block (&block, &to_se.post);
13488 148 : gfc_add_block_to_block (&block, &from_se.post);
13489 :
13490 148 : return gfc_finish_block (&block);
13491 : }
13492 :
13493 :
13494 : tree
13495 6705 : gfc_conv_intrinsic_subroutine (gfc_code *code)
13496 : {
13497 6705 : tree res;
13498 :
13499 6705 : gcc_assert (code->resolved_isym);
13500 :
13501 6705 : switch (code->resolved_isym->id)
13502 : {
13503 263 : case GFC_ISYM_MOVE_ALLOC:
13504 263 : res = conv_intrinsic_move_alloc (code);
13505 263 : break;
13506 :
13507 14 : case GFC_ISYM_ATOMIC_CAS:
13508 14 : res = conv_intrinsic_atomic_cas (code);
13509 14 : break;
13510 :
13511 95 : case GFC_ISYM_ATOMIC_ADD:
13512 95 : case GFC_ISYM_ATOMIC_AND:
13513 95 : case GFC_ISYM_ATOMIC_DEF:
13514 95 : case GFC_ISYM_ATOMIC_OR:
13515 95 : case GFC_ISYM_ATOMIC_XOR:
13516 95 : case GFC_ISYM_ATOMIC_FETCH_ADD:
13517 95 : case GFC_ISYM_ATOMIC_FETCH_AND:
13518 95 : case GFC_ISYM_ATOMIC_FETCH_OR:
13519 95 : case GFC_ISYM_ATOMIC_FETCH_XOR:
13520 95 : res = conv_intrinsic_atomic_op (code);
13521 95 : break;
13522 :
13523 176 : case GFC_ISYM_ATOMIC_REF:
13524 176 : res = conv_intrinsic_atomic_ref (code);
13525 176 : break;
13526 :
13527 105 : case GFC_ISYM_EVENT_QUERY:
13528 105 : res = conv_intrinsic_event_query (code);
13529 105 : break;
13530 :
13531 3165 : case GFC_ISYM_C_F_POINTER:
13532 3165 : case GFC_ISYM_C_F_PROCPOINTER:
13533 3165 : res = conv_isocbinding_subroutine (code);
13534 3165 : break;
13535 :
13536 360 : case GFC_ISYM_CAF_SEND:
13537 360 : res = conv_caf_send_to_remote (code);
13538 360 : break;
13539 :
13540 140 : case GFC_ISYM_CAF_SENDGET:
13541 140 : res = conv_caf_sendget (code);
13542 140 : break;
13543 :
13544 88 : case GFC_ISYM_CO_BROADCAST:
13545 88 : case GFC_ISYM_CO_MIN:
13546 88 : case GFC_ISYM_CO_MAX:
13547 88 : case GFC_ISYM_CO_REDUCE:
13548 88 : case GFC_ISYM_CO_SUM:
13549 88 : res = conv_co_collective (code);
13550 88 : break;
13551 :
13552 10 : case GFC_ISYM_FREE:
13553 10 : res = conv_intrinsic_free (code);
13554 10 : break;
13555 :
13556 55 : case GFC_ISYM_FSTAT:
13557 55 : case GFC_ISYM_LSTAT:
13558 55 : case GFC_ISYM_STAT:
13559 55 : res = conv_intrinsic_fstat_lstat_stat_sub (code);
13560 55 : break;
13561 :
13562 90 : case GFC_ISYM_RANDOM_INIT:
13563 90 : res = conv_intrinsic_random_init (code);
13564 90 : break;
13565 :
13566 15 : case GFC_ISYM_KILL:
13567 15 : res = conv_intrinsic_kill_sub (code);
13568 15 : break;
13569 :
13570 : case GFC_ISYM_MVBITS:
13571 : res = NULL_TREE;
13572 : break;
13573 :
13574 194 : case GFC_ISYM_SYSTEM_CLOCK:
13575 194 : res = conv_intrinsic_system_clock (code);
13576 194 : break;
13577 :
13578 102 : case GFC_ISYM_SPLIT:
13579 102 : res = conv_intrinsic_split (code);
13580 102 : break;
13581 :
13582 : default:
13583 : res = NULL_TREE;
13584 : break;
13585 : }
13586 :
13587 6705 : return res;
13588 : }
13589 :
13590 : #include "gt-fortran-trans-intrinsic.h"
|
