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 "trans-descriptor.h"
43 : #include "dependency.h" /* For CAF array alias analysis. */
44 : #include "attribs.h"
45 : #include "realmpfr.h"
46 : #include "constructor.h"
47 :
48 : /* This maps Fortran intrinsic math functions to external library or GCC
49 : builtin functions. */
50 : typedef struct GTY(()) gfc_intrinsic_map_t {
51 : /* The explicit enum is required to work around inadequacies in the
52 : garbage collection/gengtype parsing mechanism. */
53 : enum gfc_isym_id id;
54 :
55 : /* Enum value from the "language-independent", aka C-centric, part
56 : of gcc, or END_BUILTINS of no such value set. */
57 : enum built_in_function float_built_in;
58 : enum built_in_function double_built_in;
59 : enum built_in_function long_double_built_in;
60 : enum built_in_function complex_float_built_in;
61 : enum built_in_function complex_double_built_in;
62 : enum built_in_function complex_long_double_built_in;
63 :
64 : /* True if the naming pattern is to prepend "c" for complex and
65 : append "f" for kind=4. False if the naming pattern is to
66 : prepend "_gfortran_" and append "[rc](4|8|10|16)". */
67 : bool libm_name;
68 :
69 : /* True if a complex version of the function exists. */
70 : bool complex_available;
71 :
72 : /* True if the function should be marked const. */
73 : bool is_constant;
74 :
75 : /* The base library name of this function. */
76 : const char *name;
77 :
78 : /* Cache decls created for the various operand types. */
79 : tree real4_decl;
80 : tree real8_decl;
81 : tree real10_decl;
82 : tree real16_decl;
83 : tree complex4_decl;
84 : tree complex8_decl;
85 : tree complex10_decl;
86 : tree complex16_decl;
87 : }
88 : gfc_intrinsic_map_t;
89 :
90 : /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
91 : defines complex variants of all of the entries in mathbuiltins.def
92 : except for atan2. */
93 : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
94 : { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
95 : BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
96 : true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
97 : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
98 :
99 : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
100 : { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
101 : BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
102 : BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
103 : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
104 :
105 : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
106 : { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
107 : END_BUILTINS, END_BUILTINS, END_BUILTINS, \
108 : false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
109 : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
110 :
111 : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
112 : { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
113 : BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
114 : true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
115 : NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
116 :
117 : static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
118 : {
119 : /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
120 : DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
121 : to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
122 : #include "mathbuiltins.def"
123 :
124 : /* Functions in libgfortran. */
125 : LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
126 : LIB_FUNCTION (SIND, "sind", false),
127 : LIB_FUNCTION (COSD, "cosd", false),
128 : LIB_FUNCTION (TAND, "tand", false),
129 :
130 : /* End the list. */
131 : LIB_FUNCTION (NONE, NULL, false)
132 :
133 : };
134 : #undef OTHER_BUILTIN
135 : #undef LIB_FUNCTION
136 : #undef DEFINE_MATH_BUILTIN
137 : #undef DEFINE_MATH_BUILTIN_C
138 :
139 :
140 : enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
141 :
142 :
143 : /* Find the correct variant of a given builtin from its argument. */
144 : static tree
145 11454 : builtin_decl_for_precision (enum built_in_function base_built_in,
146 : int precision)
147 : {
148 11454 : enum built_in_function i = END_BUILTINS;
149 :
150 11454 : gfc_intrinsic_map_t *m;
151 490551 : for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
152 : ;
153 :
154 11454 : if (precision == TYPE_PRECISION (float_type_node))
155 5814 : i = m->float_built_in;
156 5640 : else if (precision == TYPE_PRECISION (double_type_node))
157 : i = m->double_built_in;
158 1695 : else if (precision == TYPE_PRECISION (long_double_type_node)
159 1695 : && (!gfc_real16_is_float128
160 1571 : || long_double_type_node != gfc_float128_type_node))
161 1571 : i = m->long_double_built_in;
162 124 : else if (precision == TYPE_PRECISION (gfc_float128_type_node))
163 : {
164 : /* Special treatment, because it is not exactly a built-in, but
165 : a library function. */
166 124 : return m->real16_decl;
167 : }
168 :
169 11330 : return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
170 : }
171 :
172 :
173 : tree
174 10415 : gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
175 : int kind)
176 : {
177 10415 : int i = gfc_validate_kind (BT_REAL, kind, false);
178 :
179 10415 : if (gfc_real_kinds[i].c_float128)
180 : {
181 : /* For _Float128, the story is a bit different, because we return
182 : a decl to a library function rather than a built-in. */
183 : gfc_intrinsic_map_t *m;
184 36328 : for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
185 : ;
186 :
187 905 : return m->real16_decl;
188 : }
189 :
190 9510 : return builtin_decl_for_precision (double_built_in,
191 9510 : gfc_real_kinds[i].mode_precision);
192 : }
193 :
194 :
195 : /* Evaluate the arguments to an intrinsic function. The value
196 : of NARGS may be less than the actual number of arguments in EXPR
197 : to allow optional "KIND" arguments that are not included in the
198 : generated code to be ignored. */
199 :
200 : static void
201 82682 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
202 : tree *argarray, int nargs)
203 : {
204 82682 : gfc_actual_arglist *actual;
205 82682 : gfc_expr *e;
206 82682 : gfc_intrinsic_arg *formal;
207 82682 : gfc_se argse;
208 82682 : int curr_arg;
209 :
210 82682 : formal = expr->value.function.isym->formal;
211 82682 : actual = expr->value.function.actual;
212 :
213 186166 : for (curr_arg = 0; curr_arg < nargs; curr_arg++,
214 63731 : actual = actual->next,
215 103484 : formal = formal ? formal->next : NULL)
216 : {
217 103484 : gcc_assert (actual);
218 103484 : e = actual->expr;
219 : /* Skip omitted optional arguments. */
220 103484 : if (!e)
221 : {
222 31 : --curr_arg;
223 31 : continue;
224 : }
225 :
226 : /* Evaluate the parameter. This will substitute scalarized
227 : references automatically. */
228 103453 : gfc_init_se (&argse, se);
229 :
230 103453 : if (e->ts.type == BT_CHARACTER)
231 : {
232 9630 : gfc_conv_expr (&argse, e);
233 9630 : gfc_conv_string_parameter (&argse);
234 9630 : argarray[curr_arg++] = argse.string_length;
235 9630 : gcc_assert (curr_arg < nargs);
236 : }
237 : else
238 93823 : gfc_conv_expr_val (&argse, e);
239 :
240 : /* If an optional argument is itself an optional dummy argument,
241 : check its presence and substitute a null if absent. */
242 103453 : if (e->expr_type == EXPR_VARIABLE
243 52725 : && e->symtree->n.sym->attr.optional
244 203 : && formal
245 153 : && formal->optional)
246 80 : gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
247 :
248 103453 : gfc_add_block_to_block (&se->pre, &argse.pre);
249 103453 : gfc_add_block_to_block (&se->post, &argse.post);
250 103453 : argarray[curr_arg] = argse.expr;
251 : }
252 82682 : }
253 :
254 : /* Count the number of actual arguments to the intrinsic function EXPR
255 : including any "hidden" string length arguments. */
256 :
257 : static unsigned int
258 57362 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
259 : {
260 57362 : int n = 0;
261 57362 : gfc_actual_arglist *actual;
262 :
263 129956 : for (actual = expr->value.function.actual; actual; actual = actual->next)
264 : {
265 72594 : if (!actual->expr)
266 6358 : continue;
267 :
268 66236 : if (actual->expr->ts.type == BT_CHARACTER)
269 4551 : n += 2;
270 : else
271 61685 : n++;
272 : }
273 :
274 57362 : return n;
275 : }
276 :
277 :
278 : /* Conversions between different types are output by the frontend as
279 : intrinsic functions. We implement these directly with inline code. */
280 :
281 : static void
282 41184 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
283 : {
284 41184 : tree type;
285 41184 : tree *args;
286 41184 : int nargs;
287 :
288 41184 : nargs = gfc_intrinsic_argument_list_length (expr);
289 41184 : args = XALLOCAVEC (tree, nargs);
290 :
291 : /* Evaluate all the arguments passed. Whilst we're only interested in the
292 : first one here, there are other parts of the front-end that assume this
293 : and will trigger an ICE if it's not the case. */
294 41184 : type = gfc_typenode_for_spec (&expr->ts);
295 41184 : gcc_assert (expr->value.function.actual->expr);
296 41184 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
297 :
298 : /* Conversion between character kinds involves a call to a library
299 : function. */
300 41184 : if (expr->ts.type == BT_CHARACTER)
301 : {
302 248 : tree fndecl, var, addr, tmp;
303 :
304 248 : if (expr->ts.kind == 1
305 97 : && expr->value.function.actual->expr->ts.kind == 4)
306 97 : fndecl = gfor_fndecl_convert_char4_to_char1;
307 151 : else if (expr->ts.kind == 4
308 151 : && expr->value.function.actual->expr->ts.kind == 1)
309 151 : fndecl = gfor_fndecl_convert_char1_to_char4;
310 : else
311 0 : gcc_unreachable ();
312 :
313 : /* Create the variable storing the converted value. */
314 248 : type = gfc_get_pchar_type (expr->ts.kind);
315 248 : var = gfc_create_var (type, "str");
316 248 : addr = gfc_build_addr_expr (build_pointer_type (type), var);
317 :
318 : /* Call the library function that will perform the conversion. */
319 248 : gcc_assert (nargs >= 2);
320 248 : tmp = build_call_expr_loc (input_location,
321 : fndecl, 3, addr, args[0], args[1]);
322 248 : gfc_add_expr_to_block (&se->pre, tmp);
323 :
324 : /* Free the temporary afterwards. */
325 248 : tmp = gfc_call_free (var);
326 248 : gfc_add_expr_to_block (&se->post, tmp);
327 :
328 248 : se->expr = var;
329 248 : se->string_length = args[0];
330 :
331 248 : return;
332 : }
333 :
334 : /* Conversion from complex to non-complex involves taking the real
335 : component of the value. */
336 40936 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
337 40936 : && expr->ts.type != BT_COMPLEX)
338 : {
339 583 : tree artype;
340 :
341 583 : artype = TREE_TYPE (TREE_TYPE (args[0]));
342 583 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
343 : args[0]);
344 : }
345 :
346 40936 : se->expr = convert (type, args[0]);
347 : }
348 :
349 : /* This is needed because the gcc backend only implements
350 : FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
351 : FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
352 : Similarly for CEILING. */
353 :
354 : static tree
355 132 : build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
356 : {
357 132 : tree tmp;
358 132 : tree cond;
359 132 : tree argtype;
360 132 : tree intval;
361 :
362 132 : argtype = TREE_TYPE (arg);
363 132 : arg = gfc_evaluate_now (arg, pblock);
364 :
365 132 : intval = convert (type, arg);
366 132 : intval = gfc_evaluate_now (intval, pblock);
367 :
368 132 : tmp = convert (argtype, intval);
369 248 : cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
370 : logical_type_node, tmp, arg);
371 :
372 248 : tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
373 : intval, build_int_cst (type, 1));
374 132 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
375 132 : return tmp;
376 : }
377 :
378 :
379 : /* Round to nearest integer, away from zero. */
380 :
381 : static tree
382 516 : build_round_expr (tree arg, tree restype)
383 : {
384 516 : tree argtype;
385 516 : tree fn;
386 516 : int argprec, resprec;
387 :
388 516 : argtype = TREE_TYPE (arg);
389 516 : argprec = TYPE_PRECISION (argtype);
390 516 : resprec = TYPE_PRECISION (restype);
391 :
392 : /* Depending on the type of the result, choose the int intrinsic (iround,
393 : available only as a builtin, therefore cannot use it for _Float128), long
394 : int intrinsic (lround family) or long long intrinsic (llround). If we
395 : don't have an appropriate function that converts directly to the integer
396 : type (such as kind == 16), just use ROUND, and then convert the result to
397 : an integer. We might also need to convert the result afterwards. */
398 516 : if (resprec <= INT_TYPE_SIZE
399 516 : && argprec <= TYPE_PRECISION (long_double_type_node))
400 458 : fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
401 62 : else if (resprec <= LONG_TYPE_SIZE)
402 46 : fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
403 12 : else if (resprec <= LONG_LONG_TYPE_SIZE)
404 0 : fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
405 12 : else if (resprec >= argprec)
406 12 : fn = builtin_decl_for_precision (BUILT_IN_ROUND, argprec);
407 : else
408 0 : gcc_unreachable ();
409 :
410 516 : return convert (restype, build_call_expr_loc (input_location,
411 516 : fn, 1, arg));
412 : }
413 :
414 :
415 : /* Convert a real to an integer using a specific rounding mode.
416 : Ideally we would just build the corresponding GENERIC node,
417 : however the RTL expander only actually supports FIX_TRUNC_EXPR. */
418 :
419 : static tree
420 1603 : build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
421 : enum rounding_mode op)
422 : {
423 1603 : switch (op)
424 : {
425 116 : case RND_FLOOR:
426 116 : return build_fixbound_expr (pblock, arg, type, 0);
427 :
428 16 : case RND_CEIL:
429 16 : return build_fixbound_expr (pblock, arg, type, 1);
430 :
431 162 : case RND_ROUND:
432 162 : return build_round_expr (arg, type);
433 :
434 1309 : case RND_TRUNC:
435 1309 : return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
436 :
437 0 : default:
438 0 : gcc_unreachable ();
439 : }
440 : }
441 :
442 :
443 : /* Round a real value using the specified rounding mode.
444 : We use a temporary integer of that same kind size as the result.
445 : Values larger than those that can be represented by this kind are
446 : unchanged, as they will not be accurate enough to represent the
447 : rounding.
448 : huge = HUGE (KIND (a))
449 : aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
450 : */
451 :
452 : static void
453 220 : gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
454 : {
455 220 : tree type;
456 220 : tree itype;
457 220 : tree arg[2];
458 220 : tree tmp;
459 220 : tree cond;
460 220 : tree decl;
461 220 : mpfr_t huge;
462 220 : int n, nargs;
463 220 : int kind;
464 :
465 220 : kind = expr->ts.kind;
466 220 : nargs = gfc_intrinsic_argument_list_length (expr);
467 :
468 220 : decl = NULL_TREE;
469 : /* We have builtin functions for some cases. */
470 220 : switch (op)
471 : {
472 74 : case RND_ROUND:
473 74 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
474 74 : break;
475 :
476 146 : case RND_TRUNC:
477 146 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
478 146 : break;
479 :
480 0 : default:
481 0 : gcc_unreachable ();
482 : }
483 :
484 : /* Evaluate the argument. */
485 220 : gcc_assert (expr->value.function.actual->expr);
486 220 : gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
487 :
488 : /* Use a builtin function if one exists. */
489 220 : if (decl != NULL_TREE)
490 : {
491 220 : se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
492 220 : return;
493 : }
494 :
495 : /* This code is probably redundant, but we'll keep it lying around just
496 : in case. */
497 0 : type = gfc_typenode_for_spec (&expr->ts);
498 0 : arg[0] = gfc_evaluate_now (arg[0], &se->pre);
499 :
500 : /* Test if the value is too large to handle sensibly. */
501 0 : gfc_set_model_kind (kind);
502 0 : mpfr_init (huge);
503 0 : n = gfc_validate_kind (BT_INTEGER, kind, false);
504 0 : mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
505 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
506 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
507 : tmp);
508 :
509 0 : mpfr_neg (huge, huge, GFC_RND_MODE);
510 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
511 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
512 : tmp);
513 0 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
514 : cond, tmp);
515 0 : itype = gfc_get_int_type (kind);
516 :
517 0 : tmp = build_fix_expr (&se->pre, arg[0], itype, op);
518 0 : tmp = convert (type, tmp);
519 0 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
520 : arg[0]);
521 0 : mpfr_clear (huge);
522 : }
523 :
524 :
525 : /* Convert to an integer using the specified rounding mode. */
526 :
527 : static void
528 3130 : gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
529 : {
530 3130 : tree type;
531 3130 : tree *args;
532 3130 : int nargs;
533 :
534 3130 : nargs = gfc_intrinsic_argument_list_length (expr);
535 3130 : args = XALLOCAVEC (tree, nargs);
536 :
537 : /* Evaluate the argument, we process all arguments even though we only
538 : use the first one for code generation purposes. */
539 3130 : type = gfc_typenode_for_spec (&expr->ts);
540 3130 : gcc_assert (expr->value.function.actual->expr);
541 3130 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
542 :
543 3130 : if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
544 : {
545 : /* Conversion to a different integer kind. */
546 1527 : se->expr = convert (type, args[0]);
547 : }
548 : else
549 : {
550 : /* Conversion from complex to non-complex involves taking the real
551 : component of the value. */
552 1603 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
553 1603 : && expr->ts.type != BT_COMPLEX)
554 : {
555 192 : tree artype;
556 :
557 192 : artype = TREE_TYPE (TREE_TYPE (args[0]));
558 192 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
559 : args[0]);
560 : }
561 :
562 1603 : se->expr = build_fix_expr (&se->pre, args[0], type, op);
563 : }
564 3130 : }
565 :
566 :
567 : /* Get the imaginary component of a value. */
568 :
569 : static void
570 440 : gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
571 : {
572 440 : tree arg;
573 :
574 440 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
575 440 : se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
576 440 : TREE_TYPE (TREE_TYPE (arg)), arg);
577 440 : }
578 :
579 :
580 : /* Get the complex conjugate of a value. */
581 :
582 : static void
583 257 : gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
584 : {
585 257 : tree arg;
586 :
587 257 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
588 257 : se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
589 257 : }
590 :
591 :
592 :
593 : static tree
594 673659 : define_quad_builtin (const char *name, tree type, bool is_const)
595 : {
596 673659 : tree fndecl;
597 673659 : fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
598 : type);
599 :
600 : /* Mark the decl as external. */
601 673659 : DECL_EXTERNAL (fndecl) = 1;
602 673659 : TREE_PUBLIC (fndecl) = 1;
603 :
604 : /* Mark it __attribute__((const)). */
605 673659 : TREE_READONLY (fndecl) = is_const;
606 :
607 673659 : rest_of_decl_compilation (fndecl, 1, 0);
608 :
609 673659 : return fndecl;
610 : }
611 :
612 : /* Add SIMD attribute for FNDECL built-in if the built-in
613 : name is in VECTORIZED_BUILTINS. */
614 :
615 : static void
616 46234170 : add_simd_flag_for_built_in (tree fndecl)
617 : {
618 46234170 : if (gfc_vectorized_builtins == NULL
619 18505350 : || fndecl == NULL_TREE)
620 38236095 : return;
621 :
622 7998075 : const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
623 7998075 : int *clauses = gfc_vectorized_builtins->get (name);
624 7998075 : if (clauses)
625 : {
626 5017788 : for (unsigned i = 0; i < 3; i++)
627 3763341 : if (*clauses & (1 << i))
628 : {
629 1254452 : gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
630 1254452 : tree omp_clause = NULL_TREE;
631 1254452 : if (simd_type == SIMD_NONE)
632 : ; /* No SIMD clause. */
633 : else
634 : {
635 1254452 : omp_clause_code code
636 : = (simd_type == SIMD_INBRANCH
637 1254452 : ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
638 1254452 : omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
639 1254452 : omp_clause = build_tree_list (NULL_TREE, omp_clause);
640 : }
641 :
642 1254452 : DECL_ATTRIBUTES (fndecl)
643 2508904 : = tree_cons (get_identifier ("omp declare simd"), omp_clause,
644 1254452 : DECL_ATTRIBUTES (fndecl));
645 : }
646 : }
647 : }
648 :
649 : /* Set SIMD attribute to all built-in functions that are mentioned
650 : in gfc_vectorized_builtins vector. */
651 :
652 : void
653 78363 : gfc_adjust_builtins (void)
654 : {
655 78363 : gfc_intrinsic_map_t *m;
656 4701780 : for (m = gfc_intrinsic_map;
657 4701780 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
658 : {
659 4623417 : add_simd_flag_for_built_in (m->real4_decl);
660 4623417 : add_simd_flag_for_built_in (m->complex4_decl);
661 4623417 : add_simd_flag_for_built_in (m->real8_decl);
662 4623417 : add_simd_flag_for_built_in (m->complex8_decl);
663 4623417 : add_simd_flag_for_built_in (m->real10_decl);
664 4623417 : add_simd_flag_for_built_in (m->complex10_decl);
665 4623417 : add_simd_flag_for_built_in (m->real16_decl);
666 4623417 : add_simd_flag_for_built_in (m->complex16_decl);
667 4623417 : add_simd_flag_for_built_in (m->real16_decl);
668 4623417 : add_simd_flag_for_built_in (m->complex16_decl);
669 : }
670 :
671 : /* Release all strings. */
672 78363 : if (gfc_vectorized_builtins != NULL)
673 : {
674 1693501 : for (hash_map<nofree_string_hash, int>::iterator it
675 31365 : = gfc_vectorized_builtins->begin ();
676 1724866 : it != gfc_vectorized_builtins->end (); ++it)
677 1693501 : free (const_cast<char *> ((*it).first));
678 :
679 62730 : delete gfc_vectorized_builtins;
680 31365 : gfc_vectorized_builtins = NULL;
681 : }
682 78363 : }
683 :
684 : /* Initialize function decls for library functions. The external functions
685 : are created as required. Builtin functions are added here. */
686 :
687 : void
688 32079 : gfc_build_intrinsic_lib_fndecls (void)
689 : {
690 32079 : gfc_intrinsic_map_t *m;
691 32079 : tree quad_decls[END_BUILTINS + 1];
692 :
693 32079 : if (gfc_real16_is_float128)
694 : {
695 : /* If we have soft-float types, we create the decls for their
696 : C99-like library functions. For now, we only handle _Float128
697 : q-suffixed or IEC 60559 f128-suffixed functions. */
698 :
699 32079 : tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
700 32079 : tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
701 :
702 32079 : memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
703 :
704 32079 : type = gfc_float128_type_node;
705 32079 : complex_type = gfc_complex_float128_type_node;
706 : /* type (*) (type) */
707 32079 : func_1 = build_function_type_list (type, type, NULL_TREE);
708 : /* int (*) (type) */
709 32079 : func_iround = build_function_type_list (integer_type_node,
710 : type, NULL_TREE);
711 : /* long (*) (type) */
712 32079 : func_lround = build_function_type_list (long_integer_type_node,
713 : type, NULL_TREE);
714 : /* long long (*) (type) */
715 32079 : func_llround = build_function_type_list (long_long_integer_type_node,
716 : type, NULL_TREE);
717 : /* type (*) (type, type) */
718 32079 : func_2 = build_function_type_list (type, type, type, NULL_TREE);
719 : /* type (*) (type, type, type) */
720 32079 : func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
721 : /* type (*) (type, &int) */
722 32079 : func_frexp
723 32079 : = build_function_type_list (type,
724 : type,
725 : build_pointer_type (integer_type_node),
726 : NULL_TREE);
727 : /* type (*) (type, int) */
728 32079 : func_scalbn = build_function_type_list (type,
729 : type, integer_type_node, NULL_TREE);
730 : /* type (*) (complex type) */
731 32079 : func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
732 : /* complex type (*) (complex type, complex type) */
733 32079 : func_cpow
734 32079 : = build_function_type_list (complex_type,
735 : complex_type, complex_type, NULL_TREE);
736 :
737 : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
738 : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
739 : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
740 :
741 : /* Only these built-ins are actually needed here. These are used directly
742 : from the code, when calling builtin_decl_for_precision() or
743 : builtin_decl_for_float_type(). The others are all constructed by
744 : gfc_get_intrinsic_lib_fndecl(). */
745 : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
746 : quad_decls[BUILT_IN_ ## ID] \
747 : = define_quad_builtin (gfc_real16_use_iec_60559 \
748 : ? NAME "f128" : NAME "q", func_ ## TYPE, \
749 : CONST);
750 :
751 : #include "mathbuiltins.def"
752 :
753 : #undef OTHER_BUILTIN
754 : #undef LIB_FUNCTION
755 : #undef DEFINE_MATH_BUILTIN
756 : #undef DEFINE_MATH_BUILTIN_C
757 :
758 : /* There is one built-in we defined manually, because it gets called
759 : with builtin_decl_for_precision() or builtin_decl_for_float_type()
760 : even though it is not an OTHER_BUILTIN: it is SQRT. */
761 32079 : quad_decls[BUILT_IN_SQRT]
762 32079 : = define_quad_builtin (gfc_real16_use_iec_60559
763 : ? "sqrtf128" : "sqrtq", func_1, true);
764 : }
765 :
766 : /* Add GCC builtin functions. */
767 1924740 : for (m = gfc_intrinsic_map;
768 1924740 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
769 : {
770 1892661 : if (m->float_built_in != END_BUILTINS)
771 1764345 : m->real4_decl = builtin_decl_explicit (m->float_built_in);
772 1892661 : if (m->complex_float_built_in != END_BUILTINS)
773 513264 : m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
774 1892661 : if (m->double_built_in != END_BUILTINS)
775 1764345 : m->real8_decl = builtin_decl_explicit (m->double_built_in);
776 1892661 : if (m->complex_double_built_in != END_BUILTINS)
777 513264 : m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
778 :
779 : /* If real(kind=10) exists, it is always long double. */
780 1892661 : if (m->long_double_built_in != END_BUILTINS)
781 1764345 : m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
782 1892661 : if (m->complex_long_double_built_in != END_BUILTINS)
783 513264 : m->complex10_decl
784 513264 : = builtin_decl_explicit (m->complex_long_double_built_in);
785 :
786 1892661 : if (!gfc_real16_is_float128)
787 : {
788 0 : if (m->long_double_built_in != END_BUILTINS)
789 0 : m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
790 0 : if (m->complex_long_double_built_in != END_BUILTINS)
791 0 : m->complex16_decl
792 0 : = builtin_decl_explicit (m->complex_long_double_built_in);
793 : }
794 1892661 : else if (quad_decls[m->double_built_in] != NULL_TREE)
795 : {
796 : /* Quad-precision function calls are constructed when first
797 : needed by builtin_decl_for_precision(), except for those
798 : that will be used directly (define by OTHER_BUILTIN). */
799 673659 : m->real16_decl = quad_decls[m->double_built_in];
800 : }
801 1219002 : else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
802 : {
803 : /* Same thing for the complex ones. */
804 0 : m->complex16_decl = quad_decls[m->double_built_in];
805 : }
806 : }
807 32079 : }
808 :
809 :
810 : /* Create a fndecl for a simple intrinsic library function. */
811 :
812 : static tree
813 4546 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
814 : {
815 4546 : tree type;
816 4546 : vec<tree, va_gc> *argtypes;
817 4546 : tree fndecl;
818 4546 : gfc_actual_arglist *actual;
819 4546 : tree *pdecl;
820 4546 : gfc_typespec *ts;
821 4546 : char name[GFC_MAX_SYMBOL_LEN + 3];
822 :
823 4546 : ts = &expr->ts;
824 4546 : if (ts->type == BT_REAL)
825 : {
826 3684 : switch (ts->kind)
827 : {
828 1308 : case 4:
829 1308 : pdecl = &m->real4_decl;
830 1308 : break;
831 1307 : case 8:
832 1307 : pdecl = &m->real8_decl;
833 1307 : break;
834 598 : case 10:
835 598 : pdecl = &m->real10_decl;
836 598 : break;
837 471 : case 16:
838 471 : pdecl = &m->real16_decl;
839 471 : break;
840 0 : default:
841 0 : gcc_unreachable ();
842 : }
843 : }
844 862 : else if (ts->type == BT_COMPLEX)
845 : {
846 862 : gcc_assert (m->complex_available);
847 :
848 862 : switch (ts->kind)
849 : {
850 386 : case 4:
851 386 : pdecl = &m->complex4_decl;
852 386 : break;
853 405 : case 8:
854 405 : pdecl = &m->complex8_decl;
855 405 : break;
856 51 : case 10:
857 51 : pdecl = &m->complex10_decl;
858 51 : break;
859 20 : case 16:
860 20 : pdecl = &m->complex16_decl;
861 20 : break;
862 0 : default:
863 0 : gcc_unreachable ();
864 : }
865 : }
866 : else
867 0 : gcc_unreachable ();
868 :
869 4546 : if (*pdecl)
870 : return *pdecl;
871 :
872 410 : if (m->libm_name)
873 : {
874 179 : int n = gfc_validate_kind (BT_REAL, ts->kind, false);
875 179 : if (gfc_real_kinds[n].c_float)
876 0 : snprintf (name, sizeof (name), "%s%s%s",
877 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
878 179 : else if (gfc_real_kinds[n].c_double)
879 0 : snprintf (name, sizeof (name), "%s%s",
880 0 : ts->type == BT_COMPLEX ? "c" : "", m->name);
881 179 : else if (gfc_real_kinds[n].c_long_double)
882 0 : snprintf (name, sizeof (name), "%s%s%s",
883 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
884 179 : else if (gfc_real_kinds[n].c_float128)
885 179 : snprintf (name, sizeof (name), "%s%s%s",
886 179 : ts->type == BT_COMPLEX ? "c" : "", m->name,
887 179 : gfc_real_kinds[n].use_iec_60559 ? "f128" : "q");
888 : else
889 0 : gcc_unreachable ();
890 : }
891 : else
892 : {
893 462 : snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
894 231 : ts->type == BT_COMPLEX ? 'c' : 'r',
895 : gfc_type_abi_kind (ts));
896 : }
897 :
898 410 : argtypes = NULL;
899 840 : for (actual = expr->value.function.actual; actual; actual = actual->next)
900 : {
901 430 : type = gfc_typenode_for_spec (&actual->expr->ts);
902 430 : vec_safe_push (argtypes, type);
903 : }
904 1230 : type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
905 410 : fndecl = build_decl (input_location,
906 : FUNCTION_DECL, get_identifier (name), type);
907 :
908 : /* Mark the decl as external. */
909 410 : DECL_EXTERNAL (fndecl) = 1;
910 410 : TREE_PUBLIC (fndecl) = 1;
911 :
912 : /* Mark it __attribute__((const)), if possible. */
913 410 : TREE_READONLY (fndecl) = m->is_constant;
914 :
915 410 : rest_of_decl_compilation (fndecl, 1, 0);
916 :
917 410 : (*pdecl) = fndecl;
918 410 : return fndecl;
919 : }
920 :
921 :
922 : /* Convert an intrinsic function into an external or builtin call. */
923 :
924 : static void
925 3928 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
926 : {
927 3928 : gfc_intrinsic_map_t *m;
928 3928 : tree fndecl;
929 3928 : tree rettype;
930 3928 : tree *args;
931 3928 : unsigned int num_args;
932 3928 : gfc_isym_id id;
933 :
934 3928 : id = expr->value.function.isym->id;
935 : /* Find the entry for this function. */
936 82787 : for (m = gfc_intrinsic_map;
937 82787 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
938 : {
939 82787 : if (id == m->id)
940 : break;
941 : }
942 :
943 3928 : if (m->id == GFC_ISYM_NONE)
944 : {
945 0 : gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
946 : expr->value.function.name, id);
947 : }
948 :
949 : /* Get the decl and generate the call. */
950 3928 : num_args = gfc_intrinsic_argument_list_length (expr);
951 3928 : args = XALLOCAVEC (tree, num_args);
952 :
953 3928 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
954 3928 : fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
955 3928 : rettype = TREE_TYPE (TREE_TYPE (fndecl));
956 :
957 3928 : fndecl = build_addr (fndecl);
958 3928 : se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
959 3928 : }
960 :
961 :
962 : /* If bounds-checking is enabled, create code to verify at runtime that the
963 : string lengths for both expressions are the same (needed for e.g. MERGE).
964 : If bounds-checking is not enabled, does nothing. */
965 :
966 : void
967 1556 : gfc_trans_same_strlen_check (const char* intr_name, locus* where,
968 : tree a, tree b, stmtblock_t* target)
969 : {
970 1556 : tree cond;
971 1556 : tree name;
972 :
973 : /* If bounds-checking is disabled, do nothing. */
974 1556 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
975 : return;
976 :
977 : /* Compare the two string lengths. */
978 94 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
979 :
980 : /* Output the runtime-check. */
981 94 : name = gfc_build_cstring_const (intr_name);
982 94 : name = gfc_build_addr_expr (pchar_type_node, name);
983 94 : gfc_trans_runtime_check (true, false, cond, target, where,
984 : "Unequal character lengths (%ld/%ld) in %s",
985 : fold_convert (long_integer_type_node, a),
986 : fold_convert (long_integer_type_node, b), name);
987 : }
988 :
989 :
990 : /* The EXPONENT(X) intrinsic function is translated into
991 : int ret;
992 : return isfinite(X) ? (frexp (X, &ret) , ret) : huge
993 : so that if X is a NaN or infinity, the result is HUGE(0).
994 : */
995 :
996 : static void
997 228 : gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
998 : {
999 228 : tree arg, type, res, tmp, frexp, cond, huge;
1000 228 : int i;
1001 :
1002 456 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
1003 228 : expr->value.function.actual->expr->ts.kind);
1004 :
1005 228 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1006 228 : arg = gfc_evaluate_now (arg, &se->pre);
1007 :
1008 228 : i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1009 228 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1010 228 : cond = build_call_expr_loc (input_location,
1011 : builtin_decl_explicit (BUILT_IN_ISFINITE),
1012 : 1, arg);
1013 :
1014 228 : res = gfc_create_var (integer_type_node, NULL);
1015 228 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1016 : gfc_build_addr_expr (NULL_TREE, res));
1017 228 : tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
1018 : tmp, res);
1019 228 : se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1020 : cond, tmp, huge);
1021 :
1022 228 : type = gfc_typenode_for_spec (&expr->ts);
1023 228 : se->expr = fold_convert (type, se->expr);
1024 228 : }
1025 :
1026 :
1027 : static int caf_call_cnt = 0;
1028 :
1029 : static tree
1030 1506 : conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
1031 : gfc_expr *hash)
1032 : {
1033 1506 : char *name;
1034 1506 : gfc_se argse;
1035 1506 : gfc_expr func_index;
1036 1506 : gfc_symtree *index_st;
1037 1506 : tree func_index_tree;
1038 1506 : stmtblock_t blk;
1039 :
1040 : /* Need to get namespace where static variables are possible. */
1041 1506 : while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
1042 0 : ns = ns->parent;
1043 1506 : gcc_assert (ns);
1044 :
1045 1506 : name = xasprintf (pat, caf_call_cnt);
1046 1506 : gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
1047 1506 : free (name);
1048 :
1049 1506 : index_st->n.sym->attr.flavor = FL_VARIABLE;
1050 1506 : index_st->n.sym->attr.save = SAVE_EXPLICIT;
1051 1506 : index_st->n.sym->value
1052 1506 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1053 : &gfc_current_locus);
1054 1506 : mpz_set_si (index_st->n.sym->value->value.integer, -1);
1055 1506 : index_st->n.sym->ts.type = BT_INTEGER;
1056 1506 : index_st->n.sym->ts.kind = gfc_default_integer_kind;
1057 1506 : gfc_set_sym_referenced (index_st->n.sym);
1058 1506 : memset (&func_index, 0, sizeof (gfc_expr));
1059 1506 : gfc_clear_ts (&func_index.ts);
1060 1506 : func_index.expr_type = EXPR_VARIABLE;
1061 1506 : func_index.symtree = index_st;
1062 1506 : func_index.ts = index_st->n.sym->ts;
1063 1506 : gfc_commit_symbol (index_st->n.sym);
1064 :
1065 1506 : gfc_init_se (&argse, NULL);
1066 1506 : gfc_conv_expr (&argse, &func_index);
1067 1506 : gfc_add_block_to_block (block, &argse.pre);
1068 1506 : func_index_tree = argse.expr;
1069 :
1070 1506 : gfc_init_se (&argse, NULL);
1071 1506 : gfc_conv_expr (&argse, hash);
1072 :
1073 1506 : gfc_init_block (&blk);
1074 1506 : gfc_add_modify (&blk, func_index_tree,
1075 : build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1,
1076 : argse.expr));
1077 1506 : gfc_add_expr_to_block (
1078 : block,
1079 : build3 (COND_EXPR, void_type_node,
1080 : gfc_likely (build2 (EQ_EXPR, logical_type_node, func_index_tree,
1081 : build_int_cst (integer_type_node, -1)),
1082 : PRED_FIRST_MATCH),
1083 : gfc_finish_block (&blk), NULL_TREE));
1084 :
1085 1506 : return func_index_tree;
1086 : }
1087 :
1088 : static tree
1089 1506 : conv_caf_add_call_data (stmtblock_t *blk, gfc_namespace *ns, const char *pat,
1090 : gfc_symbol *data_sym, tree *data_size)
1091 : {
1092 1506 : char *name;
1093 1506 : gfc_symtree *data_st;
1094 1506 : gfc_constructor *con;
1095 1506 : gfc_expr data, data_init;
1096 1506 : gfc_se argse;
1097 1506 : tree data_tree;
1098 :
1099 1506 : memset (&data, 0, sizeof (gfc_expr));
1100 1506 : gfc_clear_ts (&data.ts);
1101 1506 : data.expr_type = EXPR_VARIABLE;
1102 1506 : name = xasprintf (pat, caf_call_cnt);
1103 1506 : gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false));
1104 1506 : free (name);
1105 1506 : data_st->n.sym->attr.flavor = FL_VARIABLE;
1106 1506 : data_st->n.sym->ts = data_sym->ts;
1107 1506 : data.symtree = data_st;
1108 1506 : gfc_set_sym_referenced (data.symtree->n.sym);
1109 1506 : data.ts = data_st->n.sym->ts;
1110 1506 : gfc_commit_symbol (data_st->n.sym);
1111 :
1112 1506 : memset (&data_init, 0, sizeof (gfc_expr));
1113 1506 : gfc_clear_ts (&data_init.ts);
1114 1506 : data_init.expr_type = EXPR_STRUCTURE;
1115 1506 : data_init.ts = data.ts;
1116 1822 : for (gfc_component *comp = data.ts.u.derived->components; comp;
1117 316 : comp = comp->next)
1118 : {
1119 316 : con = gfc_constructor_get ();
1120 316 : con->expr = comp->initializer;
1121 316 : comp->initializer = NULL;
1122 316 : gfc_constructor_append (&data_init.value.constructor, con);
1123 : }
1124 :
1125 1506 : if (data.ts.u.derived->components)
1126 : {
1127 110 : gfc_init_se (&argse, NULL);
1128 110 : gfc_conv_expr (&argse, &data);
1129 110 : data_tree = argse.expr;
1130 110 : gfc_add_expr_to_block (blk,
1131 : gfc_trans_structure_assign (data_tree, &data_init,
1132 : true, true));
1133 110 : gfc_constructor_free (data_init.value.constructor);
1134 110 : *data_size = TREE_TYPE (data_tree)->type_common.size_unit;
1135 110 : data_tree = gfc_build_addr_expr (pvoid_type_node, data_tree);
1136 : }
1137 : else
1138 : {
1139 1396 : data_tree = build_zero_cst (pvoid_type_node);
1140 1396 : *data_size = build_zero_cst (size_type_node);
1141 : }
1142 :
1143 1506 : return data_tree;
1144 : }
1145 :
1146 : static tree
1147 251 : conv_shape_to_cst (gfc_expr *e)
1148 : {
1149 251 : tree tmp = NULL;
1150 690 : for (int d = 0; d < e->rank; ++d)
1151 : {
1152 439 : if (!tmp)
1153 251 : tmp = gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind);
1154 : else
1155 188 : tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp,
1156 : gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind));
1157 : }
1158 251 : return fold_convert (size_type_node, tmp);
1159 : }
1160 :
1161 : static void
1162 1267 : conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team,
1163 : tree *team_no)
1164 : {
1165 1267 : gfc_expr *stat_e, *team_e;
1166 :
1167 1267 : stat_e = gfc_find_stat_co (expr);
1168 1267 : if (stat_e)
1169 : {
1170 33 : gfc_se stat_se;
1171 33 : gfc_init_se (&stat_se, NULL);
1172 33 : gfc_conv_expr_reference (&stat_se, stat_e);
1173 33 : *stat = stat_se.expr;
1174 33 : gfc_add_block_to_block (block, &stat_se.pre);
1175 33 : gfc_add_block_to_block (block, &stat_se.post);
1176 : }
1177 : else
1178 1234 : *stat = null_pointer_node;
1179 :
1180 1267 : team_e = gfc_find_team_co (expr, TEAM_TEAM);
1181 1267 : if (team_e)
1182 : {
1183 18 : gfc_se team_se;
1184 18 : gfc_init_se (&team_se, NULL);
1185 18 : gfc_conv_expr (&team_se, team_e);
1186 18 : *team
1187 18 : = gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre,
1188 : team_se.expr));
1189 18 : gfc_add_block_to_block (block, &team_se.pre);
1190 18 : gfc_add_block_to_block (block, &team_se.post);
1191 : }
1192 : else
1193 1249 : *team = null_pointer_node;
1194 :
1195 1267 : team_e = gfc_find_team_co (expr, TEAM_NUMBER);
1196 1267 : if (team_e)
1197 : {
1198 30 : gfc_se team_se;
1199 30 : gfc_init_se (&team_se, NULL);
1200 30 : gfc_conv_expr (&team_se, team_e);
1201 30 : *team_no = gfc_build_addr_expr (
1202 : NULL_TREE,
1203 : gfc_trans_force_lval (&team_se.pre,
1204 : fold_convert (integer_type_node, team_se.expr)));
1205 30 : gfc_add_block_to_block (block, &team_se.pre);
1206 30 : gfc_add_block_to_block (block, &team_se.post);
1207 : }
1208 : else
1209 1237 : *team_no = null_pointer_node;
1210 1267 : }
1211 :
1212 : /* Get data from a remote coarray. */
1213 :
1214 : static void
1215 1006 : gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
1216 : bool may_realloc, symbol_attribute *caf_attr)
1217 : {
1218 1006 : gfc_expr *array_expr;
1219 1006 : tree caf_decl, token, image_index, tmp, res_var, type, stat, dest_size,
1220 : dest_data, opt_dest_desc, get_fn_index_tree, add_data_tree, add_data_size,
1221 : opt_src_desc, opt_src_charlen, opt_dest_charlen, team, team_no;
1222 1006 : symbol_attribute caf_attr_store;
1223 1006 : gfc_namespace *ns;
1224 1006 : gfc_expr *get_fn_hash = expr->value.function.actual->next->expr,
1225 1006 : *get_fn_expr = expr->value.function.actual->next->next->expr;
1226 1006 : gfc_symbol *add_data_sym = get_fn_expr->symtree->n.sym->formal->sym;
1227 :
1228 1006 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1229 :
1230 1006 : if (se->ss && se->ss->info->useflags)
1231 : {
1232 : /* Access the previously obtained result. */
1233 379 : gfc_conv_tmp_array_ref (se);
1234 379 : return;
1235 : }
1236 :
1237 627 : array_expr = expr->value.function.actual->expr;
1238 627 : ns = array_expr->expr_type == EXPR_VARIABLE
1239 627 : && !array_expr->symtree->n.sym->attr.associate_var
1240 571 : && !array_expr->symtree->n.sym->module
1241 627 : ? array_expr->symtree->n.sym->ns
1242 : : gfc_current_ns;
1243 627 : type = gfc_typenode_for_spec (&array_expr->ts);
1244 :
1245 627 : if (caf_attr == NULL)
1246 : {
1247 627 : caf_attr_store = gfc_caf_attr (array_expr);
1248 627 : caf_attr = &caf_attr_store;
1249 : }
1250 :
1251 627 : res_var = lhs;
1252 :
1253 627 : conv_stat_and_team (&se->pre, expr, &stat, &team, &team_no);
1254 :
1255 627 : get_fn_index_tree
1256 627 : = conv_caf_func_index (&se->pre, ns, "__caf_get_from_remote_fn_index_%d",
1257 : get_fn_hash);
1258 627 : add_data_tree
1259 627 : = conv_caf_add_call_data (&se->pre, ns, "__caf_get_from_remote_add_data_%d",
1260 : add_data_sym, &add_data_size);
1261 627 : ++caf_call_cnt;
1262 :
1263 627 : if (array_expr->rank == 0)
1264 : {
1265 246 : res_var = gfc_create_var (type, "caf_res");
1266 246 : 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 213 : dest_size = res_var->typed.type->type_common.size_unit;
1277 213 : opt_src_charlen
1278 213 : = build_zero_cst (build_pointer_type (size_type_node));
1279 : }
1280 246 : dest_data
1281 246 : = gfc_evaluate_now (gfc_build_addr_expr (NULL_TREE, res_var), &se->pre);
1282 246 : res_var = build_fold_indirect_ref (dest_data);
1283 246 : dest_data = gfc_build_addr_expr (pvoid_type_node, dest_data);
1284 246 : 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 627 : opt_dest_charlen = opt_src_charlen;
1332 627 : caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1333 627 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1334 2 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1335 :
1336 627 : if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank
1337 627 : || GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)))
1338 546 : 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 627 : image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1343 627 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, array_expr);
1344 :
1345 : /* It guarantees memory consistency within the same segment. */
1346 627 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1347 627 : 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 627 : ASM_VOLATILE_P (tmp) = 1;
1351 627 : gfc_add_expr_to_block (&se->pre, tmp);
1352 :
1353 627 : 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 627 : gfc_add_expr_to_block (&se->pre, tmp);
1360 :
1361 627 : if (se->ss)
1362 381 : gfc_advance_se_ss_chain (se);
1363 :
1364 627 : se->expr = res_var;
1365 :
1366 627 : return;
1367 : }
1368 :
1369 : /* Generate call to caf_is_present_on_remote for allocated (coarrary[...])
1370 : calls. */
1371 :
1372 : static void
1373 239 : gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
1374 : {
1375 239 : gfc_expr *caf_expr, *hash, *present_fn;
1376 239 : gfc_symbol *add_data_sym;
1377 239 : tree fn_index, add_data_tree, add_data_size, caf_decl, image_index, token;
1378 :
1379 239 : gcc_assert (e->expr_type == EXPR_FUNCTION
1380 : && e->value.function.isym->id
1381 : == GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE);
1382 239 : caf_expr = e->value.function.actual->expr;
1383 239 : hash = e->value.function.actual->next->expr;
1384 239 : present_fn = e->value.function.actual->next->next->expr;
1385 239 : add_data_sym = present_fn->symtree->n.sym->formal->sym;
1386 :
1387 239 : fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns,
1388 : "__caf_present_on_remote_fn_index_%d", hash);
1389 239 : 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 239 : ++caf_call_cnt;
1393 :
1394 239 : caf_decl = gfc_get_tree_for_caf_expr (caf_expr);
1395 239 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1396 4 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1397 :
1398 239 : image_index = gfc_caf_get_image_index (&se->pre, caf_expr, caf_decl);
1399 239 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, caf_expr);
1400 :
1401 239 : se->expr
1402 239 : = 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 239 : }
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 1306 : trans_this_image (gfc_se * se, gfc_expr *expr)
1825 : {
1826 1306 : stmtblock_t loop;
1827 1306 : tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound,
1828 : ubound, extent, ml, team;
1829 1306 : gfc_se argse;
1830 1306 : int rank, corank;
1831 :
1832 : /* The case -fcoarray=single is handled elsewhere. */
1833 1306 : gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
1834 :
1835 : /* Translate team, if present. */
1836 1306 : 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 1288 : team = null_pointer_node;
1846 :
1847 : /* Argument-free version: THIS_IMAGE(). */
1848 1306 : if (expr->value.function.actual->expr == NULL)
1849 : {
1850 988 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1851 : team);
1852 988 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1853 : tmp);
1854 996 : 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 = fold_convert_loc (input_location, gfc_array_dim_rank_type,
1880 : se->loop->loopvar[0]);
1881 70 : dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1882 : gfc_array_dim_rank_type, dim_arg,
1883 : gfc_rank_cst[1]);
1884 70 : gfc_advance_se_ss_chain (se);
1885 : }
1886 : else
1887 : {
1888 : /* Use the passed DIM= argument. */
1889 248 : gcc_assert (expr->value.function.actual->next->expr);
1890 248 : gfc_init_se (&argse, NULL);
1891 248 : gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1892 : gfc_array_dim_rank_type);
1893 248 : gfc_add_block_to_block (&se->pre, &argse.pre);
1894 248 : dim_arg = argse.expr;
1895 :
1896 248 : if (INTEGER_CST_P (dim_arg))
1897 : {
1898 132 : if (wi::ltu_p (wi::to_wide (dim_arg), 1)
1899 264 : || wi::gtu_p (wi::to_wide (dim_arg),
1900 132 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
1901 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1902 0 : "dimension index", expr->value.function.isym->name,
1903 : &expr->where);
1904 : }
1905 116 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1906 : {
1907 0 : dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1908 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1909 : dim_arg, gfc_rank_cst[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 (gfc_array_dim_rank_type, NULL);
1966 310 : min_var = gfc_create_var (gfc_array_dim_rank_type, 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, signed_char_type_node,
1973 : fold_convert_loc (input_location,
1974 : signed_char_type_node, dim_arg),
1975 310 : build_int_cst (signed_char_type_node, rank - 1));
1976 310 : tmp = fold_convert_loc (input_location, gfc_array_dim_rank_type, tmp);
1977 620 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_dim_rank_type,
1978 310 : gfc_rank_cst[rank + corank - 2], tmp);
1979 310 : gfc_add_modify (&se->pre, min_var, tmp);
1980 :
1981 : /* i = rank. */
1982 310 : tmp = gfc_rank_cst[rank];
1983 310 : gfc_add_modify (&se->pre, loop_var, tmp);
1984 :
1985 310 : exit_label = gfc_build_label_decl (NULL_TREE);
1986 310 : TREE_USED (exit_label) = 1;
1987 :
1988 : /* Loop body. */
1989 310 : gfc_init_block (&loop);
1990 :
1991 : /* ml = m. */
1992 310 : gfc_add_modify (&loop, ml, m);
1993 :
1994 : /* extent = ... */
1995 310 : lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1996 310 : ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1997 310 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1998 310 : extent = fold_convert (type, extent);
1999 :
2000 : /* m = m/extent. */
2001 310 : gfc_add_modify (&loop, m,
2002 : fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2003 : m, extent));
2004 :
2005 : /* Exit condition: if (i >= min_var) goto exit_label. */
2006 310 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2007 : min_var);
2008 310 : tmp = build1_v (GOTO_EXPR, exit_label);
2009 310 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2010 : build_empty_stmt (input_location));
2011 310 : gfc_add_expr_to_block (&loop, tmp);
2012 :
2013 : /* Increment loop variable: i++. */
2014 310 : gfc_add_modify (&loop, loop_var,
2015 : fold_build2_loc (input_location, PLUS_EXPR,
2016 310 : TREE_TYPE (loop_var), loop_var,
2017 : gfc_rank_cst[1]));
2018 :
2019 : /* Making the loop... actually loop! */
2020 310 : tmp = gfc_finish_block (&loop);
2021 310 : tmp = build1_v (LOOP_EXPR, tmp);
2022 310 : gfc_add_expr_to_block (&se->pre, tmp);
2023 :
2024 : /* The exit label. */
2025 310 : tmp = build1_v (LABEL_EXPR, exit_label);
2026 310 : gfc_add_expr_to_block (&se->pre, tmp);
2027 :
2028 : /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2029 : : m + lcobound(corank) */
2030 :
2031 310 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2032 310 : build_int_cst (TREE_TYPE (dim_arg), corank));
2033 :
2034 620 : lbound = gfc_conv_descriptor_lbound_get (desc,
2035 : fold_build2_loc (input_location, PLUS_EXPR,
2036 310 : TREE_TYPE (dim_arg), dim_arg,
2037 310 : build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2038 310 : lbound = fold_convert (type, lbound);
2039 :
2040 310 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2041 : fold_build2_loc (input_location, MULT_EXPR, type,
2042 : m, extent));
2043 310 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2044 :
2045 310 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2046 : fold_build2_loc (input_location, PLUS_EXPR, type,
2047 : m, lbound));
2048 : }
2049 :
2050 :
2051 : /* Convert a call to image_status. */
2052 :
2053 : static void
2054 25 : conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2055 : {
2056 25 : unsigned int num_args;
2057 25 : tree *args, tmp;
2058 :
2059 25 : num_args = gfc_intrinsic_argument_list_length (expr);
2060 25 : args = XALLOCAVEC (tree, num_args);
2061 25 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2062 : /* In args[0] the number of the image the status is desired for has to be
2063 : given. */
2064 :
2065 25 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2066 : {
2067 0 : tree arg;
2068 0 : arg = gfc_evaluate_now (args[0], &se->pre);
2069 0 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2070 : fold_convert (integer_type_node, arg),
2071 : integer_one_node);
2072 0 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2073 : tmp, integer_zero_node,
2074 : build_int_cst (integer_type_node,
2075 : GFC_STAT_STOPPED_IMAGE));
2076 : }
2077 25 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2078 : /* The team is optional and therefore needs to be a pointer to the opaque
2079 : pointer. */
2080 29 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2081 : args[0],
2082 : num_args < 2
2083 : ? null_pointer_node
2084 4 : : gfc_build_addr_expr (NULL_TREE, args[1]));
2085 : else
2086 0 : gcc_unreachable ();
2087 :
2088 25 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2089 25 : }
2090 :
2091 : static void
2092 21 : conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2093 : {
2094 21 : unsigned int num_args;
2095 :
2096 21 : tree *args, tmp;
2097 :
2098 21 : num_args = gfc_intrinsic_argument_list_length (expr);
2099 21 : args = XALLOCAVEC (tree, num_args);
2100 21 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2101 :
2102 21 : if (flag_coarray ==
2103 18 : GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2104 0 : tmp = gfc_evaluate_now (args[0], &se->pre);
2105 21 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2106 : {
2107 : // the value -1 represents that no team has been created yet
2108 18 : tmp = build_int_cst (integer_type_node, -1);
2109 : }
2110 3 : else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2111 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2112 : args[0]);
2113 3 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2114 3 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2115 : null_pointer_node);
2116 : else
2117 0 : gcc_unreachable ();
2118 :
2119 21 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2120 21 : }
2121 :
2122 :
2123 : static void
2124 193 : trans_image_index (gfc_se * se, gfc_expr *expr)
2125 : {
2126 193 : tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp,
2127 193 : invalid_bound, team = null_pointer_node, team_number = null_pointer_node;
2128 193 : gfc_se argse, subse;
2129 193 : int rank, corank, codim;
2130 :
2131 193 : type = gfc_get_int_type (gfc_default_integer_kind);
2132 193 : corank = expr->value.function.actual->expr->corank;
2133 193 : rank = expr->value.function.actual->expr->rank;
2134 :
2135 : /* Obtain the descriptor of the COARRAY. */
2136 193 : gfc_init_se (&argse, NULL);
2137 193 : argse.want_coarray = 1;
2138 193 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2139 193 : gfc_add_block_to_block (&se->pre, &argse.pre);
2140 193 : gfc_add_block_to_block (&se->post, &argse.post);
2141 193 : desc = argse.expr;
2142 :
2143 : /* Obtain a handle to the SUB argument. */
2144 193 : gfc_init_se (&subse, NULL);
2145 193 : gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2146 193 : gfc_add_block_to_block (&se->pre, &subse.pre);
2147 193 : gfc_add_block_to_block (&se->post, &subse.post);
2148 193 : subdesc = build_fold_indirect_ref_loc (input_location,
2149 : gfc_conv_descriptor_data_get (subse.expr));
2150 :
2151 193 : if (expr->value.function.actual->next->next->expr)
2152 : {
2153 0 : gfc_init_se (&argse, NULL);
2154 0 : gfc_conv_expr_descriptor (&argse,
2155 0 : expr->value.function.actual->next->next->expr);
2156 0 : if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED)
2157 0 : team = argse.expr;
2158 : else
2159 0 : team_number = gfc_build_addr_expr (
2160 : NULL_TREE,
2161 : gfc_trans_force_lval (&argse.pre,
2162 : fold_convert (integer_type_node, argse.expr)));
2163 0 : gfc_add_block_to_block (&se->pre, &argse.pre);
2164 0 : gfc_add_block_to_block (&se->post, &argse.post);
2165 : }
2166 :
2167 : /* Fortran 2008 does not require that the values remain in the cobounds,
2168 : thus we need explicitly check this - and return 0 if they are exceeded. */
2169 :
2170 193 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2171 193 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2172 193 : invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2173 : fold_convert (gfc_array_index_type, tmp),
2174 : lbound);
2175 :
2176 443 : for (codim = corank + rank - 2; codim >= rank; codim--)
2177 : {
2178 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2179 250 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2180 250 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2181 250 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2182 : fold_convert (gfc_array_index_type, tmp),
2183 : lbound);
2184 250 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2185 : logical_type_node, invalid_bound, cond);
2186 250 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2187 : fold_convert (gfc_array_index_type, tmp),
2188 : ubound);
2189 250 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2190 : logical_type_node, invalid_bound, cond);
2191 : }
2192 :
2193 193 : invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2194 :
2195 : /* See Fortran 2008, C.10 for the following algorithm. */
2196 :
2197 : /* coindex = sub(corank) - lcobound(n). */
2198 193 : coindex = fold_convert (gfc_array_index_type,
2199 : gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2200 : NULL));
2201 193 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2202 193 : coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2203 : fold_convert (gfc_array_index_type, coindex),
2204 : lbound);
2205 :
2206 636 : for (codim = corank + rank - 2; codim >= rank; codim--)
2207 : {
2208 250 : tree extent, ubound;
2209 :
2210 : /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2211 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2212 250 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2213 250 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2214 :
2215 : /* coindex *= extent. */
2216 250 : coindex = fold_build2_loc (input_location, MULT_EXPR,
2217 : gfc_array_index_type, coindex, extent);
2218 :
2219 : /* coindex += sub(codim). */
2220 250 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2221 250 : coindex = fold_build2_loc (input_location, PLUS_EXPR,
2222 : gfc_array_index_type, coindex,
2223 : fold_convert (gfc_array_index_type, tmp));
2224 :
2225 : /* coindex -= lbound(codim). */
2226 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2227 250 : coindex = fold_build2_loc (input_location, MINUS_EXPR,
2228 : gfc_array_index_type, coindex, lbound);
2229 : }
2230 :
2231 193 : coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2232 : fold_convert(type, coindex),
2233 : build_int_cst (type, 1));
2234 :
2235 : /* Return 0 if "coindex" exceeds num_images(). */
2236 :
2237 193 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2238 108 : num_images = build_int_cst (type, 1);
2239 : else
2240 : {
2241 85 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2242 : team, team_number);
2243 85 : num_images = fold_convert (type, tmp);
2244 : }
2245 :
2246 193 : tmp = gfc_create_var (type, NULL);
2247 193 : gfc_add_modify (&se->pre, tmp, coindex);
2248 :
2249 193 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2250 : num_images);
2251 193 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2252 : cond,
2253 : fold_convert (logical_type_node, invalid_bound));
2254 193 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2255 : build_int_cst (type, 0), tmp);
2256 193 : }
2257 :
2258 : static void
2259 812 : trans_num_images (gfc_se * se, gfc_expr *expr)
2260 : {
2261 812 : tree tmp, team = null_pointer_node, team_number = null_pointer_node;
2262 812 : gfc_se argse;
2263 :
2264 812 : if (expr->value.function.actual->expr)
2265 : {
2266 18 : gfc_init_se (&argse, NULL);
2267 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2268 18 : if (expr->value.function.actual->expr->ts.type == BT_DERIVED)
2269 6 : team = argse.expr;
2270 : else
2271 12 : team_number = gfc_build_addr_expr (
2272 : NULL_TREE,
2273 : gfc_trans_force_lval (&se->pre,
2274 : fold_convert (integer_type_node, argse.expr)));
2275 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
2276 18 : gfc_add_block_to_block (&se->post, &argse.post);
2277 : }
2278 :
2279 812 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2280 : team, team_number);
2281 812 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2282 812 : }
2283 :
2284 :
2285 : static void
2286 13346 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2287 : {
2288 13346 : gfc_se argse;
2289 :
2290 13346 : gfc_init_se (&argse, NULL);
2291 13346 : argse.data_not_needed = 1;
2292 13346 : argse.descriptor_only = 1;
2293 :
2294 13346 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2295 13346 : gfc_add_block_to_block (&se->pre, &argse.pre);
2296 13346 : gfc_add_block_to_block (&se->post, &argse.post);
2297 :
2298 13346 : se->expr = gfc_conv_descriptor_rank_get (argse.expr);
2299 13346 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2300 : se->expr);
2301 13346 : }
2302 :
2303 :
2304 : static void
2305 754 : gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2306 : {
2307 754 : gfc_expr *arg;
2308 754 : arg = expr->value.function.actual->expr;
2309 754 : gfc_conv_is_contiguous_expr (se, arg);
2310 754 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2311 754 : }
2312 :
2313 : /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2314 : plus it can be called directly. */
2315 :
2316 : void
2317 2190 : gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2318 : {
2319 2190 : gfc_ss *ss;
2320 2190 : gfc_se argse;
2321 2190 : tree desc, tmp, stride, extent, cond;
2322 2190 : int i;
2323 2190 : tree fncall0;
2324 2190 : gfc_array_spec *as;
2325 2190 : gfc_symbol *sym = NULL;
2326 :
2327 2190 : if (arg->ts.type == BT_CLASS)
2328 96 : gfc_add_class_array_ref (arg);
2329 :
2330 2190 : if (arg->expr_type == EXPR_VARIABLE)
2331 2154 : sym = arg->symtree->n.sym;
2332 :
2333 2190 : ss = gfc_walk_expr (arg);
2334 2190 : gcc_assert (ss != gfc_ss_terminator);
2335 2190 : gfc_init_se (&argse, NULL);
2336 2190 : argse.data_not_needed = 1;
2337 2190 : gfc_conv_expr_descriptor (&argse, arg);
2338 :
2339 2190 : as = gfc_get_full_arrayspec_from_expr (arg);
2340 :
2341 : /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2342 : Note in addition that zero-sized arrays don't count as contiguous. */
2343 :
2344 2190 : if (as && as->type == AS_ASSUMED_RANK)
2345 : {
2346 : /* Build the call to is_contiguous0. */
2347 250 : argse.want_pointer = 1;
2348 250 : gfc_conv_expr_descriptor (&argse, arg);
2349 250 : gfc_add_block_to_block (&se->pre, &argse.pre);
2350 250 : gfc_add_block_to_block (&se->post, &argse.post);
2351 250 : tree ptr = gfc_evaluate_now (argse.expr, &se->pre);
2352 250 : fncall0 = build_call_expr_loc (input_location,
2353 : gfor_fndecl_is_contiguous0, 1, ptr);
2354 250 : desc = build_fold_indirect_ref_loc (input_location, ptr);
2355 250 : se->expr = fncall0;
2356 250 : se->expr = convert (boolean_type_node, se->expr);
2357 250 : }
2358 : else
2359 : {
2360 1940 : gfc_add_block_to_block (&se->pre, &argse.pre);
2361 1940 : gfc_add_block_to_block (&se->post, &argse.post);
2362 1940 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2363 :
2364 1940 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2365 1940 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2366 1940 : stride, build_int_cst (TREE_TYPE (stride), 1));
2367 :
2368 2269 : for (i = 0; i < arg->rank - 1; i++)
2369 : {
2370 329 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2371 329 : extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2372 329 : extent = fold_build2_loc (input_location, MINUS_EXPR,
2373 : gfc_array_index_type, extent, tmp);
2374 329 : extent = fold_build2_loc (input_location, PLUS_EXPR,
2375 : gfc_array_index_type, extent,
2376 : gfc_index_one_node);
2377 329 : tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2378 329 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2379 : tmp, extent);
2380 329 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2381 329 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2382 : stride, tmp);
2383 329 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2384 : boolean_type_node, cond, tmp);
2385 : }
2386 1940 : se->expr = cond;
2387 : }
2388 :
2389 : /* An array that is addressed by the span of its descriptor needs to be
2390 : checked if that span differs from the element size. */
2391 919 : if (as && sym && !sym->attr.contiguous
2392 3109 : && (IS_POINTER (sym) || gfc_is_span_addressed_dummy (sym)))
2393 : {
2394 284 : tree span = gfc_conv_descriptor_span_get (desc);
2395 284 : tmp = fold_convert (TREE_TYPE (span),
2396 : gfc_conv_descriptor_elem_len_get (desc));
2397 284 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2398 : span, tmp);
2399 284 : se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2400 : boolean_type_node, cond,
2401 : convert (boolean_type_node, se->expr));
2402 : }
2403 :
2404 2190 : if (as && as->type == AS_ASSUMED_RANK)
2405 : {
2406 250 : tree rank = gfc_conv_descriptor_rank_get (desc);
2407 250 : tree scalar = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2408 : rank, gfc_rank_cst[0]);
2409 250 : se->expr = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2410 250 : TREE_TYPE (se->expr), scalar, se->expr);
2411 : }
2412 :
2413 2190 : gfc_free_ss_chain (ss);
2414 2190 : }
2415 :
2416 :
2417 : /* Evaluate a single upper or lower bound. */
2418 : /* TODO: bound intrinsic generates way too much unnecessary code. */
2419 :
2420 : static void
2421 16349 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2422 : {
2423 16349 : gfc_actual_arglist *arg;
2424 16349 : gfc_actual_arglist *arg2;
2425 16349 : tree desc;
2426 16349 : tree type;
2427 16349 : tree bound;
2428 16349 : tree tmp;
2429 16349 : tree cond, cond1;
2430 16349 : tree ubound;
2431 16349 : tree lbound;
2432 16349 : tree size;
2433 16349 : gfc_se argse;
2434 16349 : gfc_array_spec * as;
2435 16349 : bool assumed_rank_lb_one;
2436 :
2437 16349 : arg = expr->value.function.actual;
2438 16349 : arg2 = arg->next;
2439 :
2440 16349 : if (se->ss)
2441 : {
2442 : /* Create an implicit second parameter from the loop variable. */
2443 8016 : gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2444 8016 : gcc_assert (se->loop->dimen == 1);
2445 8016 : gcc_assert (se->ss->info->expr == expr);
2446 8016 : gfc_advance_se_ss_chain (se);
2447 8016 : bound = se->loop->loopvar[0];
2448 8016 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2449 : gfc_array_index_type, bound,
2450 : se->loop->from[0]);
2451 8016 : bound = fold_convert_loc (input_location, gfc_array_dim_rank_type,
2452 : bound);
2453 : }
2454 : else
2455 : {
2456 : /* use the passed argument. */
2457 8333 : gcc_assert (arg2->expr);
2458 8333 : gfc_init_se (&argse, NULL);
2459 8333 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_dim_rank_type);
2460 8333 : gfc_add_block_to_block (&se->pre, &argse.pre);
2461 8333 : bound = argse.expr;
2462 : /* Convert from one based to zero based. */
2463 8333 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2464 : gfc_array_dim_rank_type, bound,
2465 : gfc_rank_cst[1]);
2466 : }
2467 :
2468 : /* TODO: don't re-evaluate the descriptor on each iteration. */
2469 : /* Get a descriptor for the first parameter. */
2470 16349 : gfc_init_se (&argse, NULL);
2471 16349 : gfc_conv_expr_descriptor (&argse, arg->expr);
2472 16349 : gfc_add_block_to_block (&se->pre, &argse.pre);
2473 16349 : gfc_add_block_to_block (&se->post, &argse.post);
2474 :
2475 16349 : desc = argse.expr;
2476 :
2477 16349 : as = gfc_get_full_arrayspec_from_expr (arg->expr);
2478 :
2479 16349 : if (INTEGER_CST_P (bound))
2480 : {
2481 8213 : gcc_assert (op != GFC_ISYM_SHAPE);
2482 7976 : if (((!as || as->type != AS_ASSUMED_RANK)
2483 7305 : && wi::geu_p (wi::to_wide (bound),
2484 7305 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2485 16426 : || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2486 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2487 : "dimension index",
2488 : (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
2489 : &expr->where);
2490 : }
2491 :
2492 16349 : if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2493 : {
2494 9044 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2495 : {
2496 651 : bound = gfc_evaluate_now (bound, &se->pre);
2497 651 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2498 : bound, gfc_rank_cst[0]);
2499 651 : if (as && as->type == AS_ASSUMED_RANK)
2500 546 : tmp = gfc_conv_descriptor_rank_get (desc);
2501 : else
2502 105 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2503 651 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2504 : bound, tmp);
2505 651 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2506 : logical_type_node, cond, tmp);
2507 651 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2508 : gfc_msg_fault);
2509 : }
2510 : }
2511 :
2512 : /* Take care of the lbound shift for assumed-rank arrays that are
2513 : nonallocatable and nonpointers. Those have a lbound of 1. */
2514 15765 : assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2515 11229 : && ((arg->expr->ts.type != BT_CLASS
2516 1987 : && !arg->expr->symtree->n.sym->attr.allocatable
2517 1644 : && !arg->expr->symtree->n.sym->attr.pointer)
2518 920 : || (arg->expr->ts.type == BT_CLASS
2519 198 : && !CLASS_DATA (arg->expr)->attr.allocatable
2520 162 : && !CLASS_DATA (arg->expr)->attr.class_pointer));
2521 :
2522 16349 : ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2523 16349 : lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2524 16349 : size = fold_build2_loc (input_location, MINUS_EXPR,
2525 : gfc_array_index_type, ubound, lbound);
2526 16349 : size = fold_build2_loc (input_location, PLUS_EXPR,
2527 : gfc_array_index_type, size, gfc_index_one_node);
2528 :
2529 : /* 13.14.53: Result value for LBOUND
2530 :
2531 : Case (i): For an array section or for an array expression other than a
2532 : whole array or array structure component, LBOUND(ARRAY, DIM)
2533 : has the value 1. For a whole array or array structure
2534 : component, LBOUND(ARRAY, DIM) has the value:
2535 : (a) equal to the lower bound for subscript DIM of ARRAY if
2536 : dimension DIM of ARRAY does not have extent zero
2537 : or if ARRAY is an assumed-size array of rank DIM,
2538 : or (b) 1 otherwise.
2539 :
2540 : 13.14.113: Result value for UBOUND
2541 :
2542 : Case (i): For an array section or for an array expression other than a
2543 : whole array or array structure component, UBOUND(ARRAY, DIM)
2544 : has the value equal to the number of elements in the given
2545 : dimension; otherwise, it has a value equal to the upper bound
2546 : for subscript DIM of ARRAY if dimension DIM of ARRAY does
2547 : not have size zero and has value zero if dimension DIM has
2548 : size zero. */
2549 :
2550 16349 : if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
2551 556 : se->expr = gfc_index_one_node;
2552 15793 : else if (as)
2553 : {
2554 15209 : if (op == GFC_ISYM_UBOUND)
2555 : {
2556 5407 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2557 : size, gfc_index_zero_node);
2558 10186 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2559 : gfc_array_index_type, cond,
2560 : (assumed_rank_lb_one ? size : ubound),
2561 : gfc_index_zero_node);
2562 : }
2563 9802 : else if (op == GFC_ISYM_LBOUND)
2564 : {
2565 4931 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2566 : size, gfc_index_zero_node);
2567 4931 : if (as->type == AS_ASSUMED_SIZE)
2568 : {
2569 98 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2570 : logical_type_node, bound,
2571 98 : build_int_cst (TREE_TYPE (bound),
2572 98 : arg->expr->rank - 1));
2573 98 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2574 : logical_type_node, cond, cond1);
2575 : }
2576 4931 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2577 : gfc_array_index_type, cond,
2578 : lbound, gfc_index_one_node);
2579 : }
2580 4871 : else if (op == GFC_ISYM_SHAPE)
2581 4871 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2582 : gfc_array_index_type, size,
2583 : gfc_index_zero_node);
2584 : else
2585 0 : gcc_unreachable ();
2586 :
2587 : /* According to F2018 16.9.172, para 5, an assumed rank object,
2588 : argument associated with and assumed size array, has the ubound
2589 : of the final dimension set to -1 and UBOUND must return this.
2590 : Similarly for the SHAPE intrinsic. */
2591 15209 : if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
2592 : {
2593 835 : tree minus_one = build_int_cst (gfc_array_index_type, -1);
2594 835 : tree rank = gfc_conv_descriptor_rank_get (desc);
2595 835 : rank = fold_build2_loc (input_location, MINUS_EXPR,
2596 : gfc_array_dim_rank_type, rank,
2597 : gfc_rank_cst[1]);
2598 :
2599 : /* Fix the expression to stop it from becoming even more
2600 : complicated. */
2601 835 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
2602 :
2603 : /* Descriptors for assumed-size arrays have ubound = -1
2604 : in the last dimension. */
2605 835 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2606 : logical_type_node, ubound, minus_one);
2607 835 : cond = fold_build2_loc (input_location, EQ_EXPR,
2608 : logical_type_node, bound, rank);
2609 835 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2610 : logical_type_node, cond, cond1);
2611 835 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2612 : gfc_array_index_type, cond,
2613 : minus_one, se->expr);
2614 : }
2615 : }
2616 : else /* as is null; this is an old-fashioned 1-based array. */
2617 : {
2618 584 : if (op != GFC_ISYM_LBOUND)
2619 : {
2620 482 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2621 : gfc_array_index_type, size,
2622 : gfc_index_zero_node);
2623 : }
2624 : else
2625 102 : se->expr = gfc_index_one_node;
2626 : }
2627 :
2628 :
2629 16349 : type = gfc_typenode_for_spec (&expr->ts);
2630 16349 : se->expr = convert (type, se->expr);
2631 16349 : }
2632 :
2633 :
2634 : static void
2635 666 : conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2636 : {
2637 666 : gfc_actual_arglist *arg;
2638 666 : gfc_actual_arglist *arg2;
2639 666 : gfc_se argse;
2640 666 : tree bound, lbound, resbound, resbound2, desc, cond, tmp;
2641 666 : tree type;
2642 666 : int corank;
2643 :
2644 666 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2645 : || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2646 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE
2647 : || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2648 :
2649 666 : arg = expr->value.function.actual;
2650 666 : arg2 = arg->next;
2651 :
2652 666 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2653 666 : corank = arg->expr->corank;
2654 :
2655 666 : gfc_init_se (&argse, NULL);
2656 666 : argse.want_coarray = 1;
2657 :
2658 666 : gfc_conv_expr_descriptor (&argse, arg->expr);
2659 666 : gfc_add_block_to_block (&se->pre, &argse.pre);
2660 666 : gfc_add_block_to_block (&se->post, &argse.post);
2661 666 : desc = argse.expr;
2662 :
2663 666 : if (se->ss)
2664 : {
2665 : /* Create an implicit second parameter from the loop variable. */
2666 238 : gcc_assert (!arg2->expr
2667 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE);
2668 238 : gcc_assert (corank > 0);
2669 238 : gcc_assert (se->loop->dimen == 1);
2670 238 : gcc_assert (se->ss->info->expr == expr);
2671 :
2672 238 : bound = fold_convert_loc (input_location, gfc_array_dim_rank_type,
2673 : se->loop->loopvar[0]);
2674 238 : tree rank = gfc_rank_cst[arg->expr->rank];
2675 238 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2676 : gfc_array_dim_rank_type, bound, rank);
2677 238 : gfc_advance_se_ss_chain (se);
2678 : }
2679 428 : else if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2680 0 : bound = gfc_rank_cst[1];
2681 : else
2682 : {
2683 428 : gcc_assert (arg2->expr);
2684 428 : gfc_init_se (&argse, NULL);
2685 428 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_dim_rank_type);
2686 428 : gfc_add_block_to_block (&se->pre, &argse.pre);
2687 428 : bound = argse.expr;
2688 :
2689 428 : if (INTEGER_CST_P (bound))
2690 : {
2691 334 : if (wi::ltu_p (wi::to_wide (bound), 1)
2692 668 : || wi::gtu_p (wi::to_wide (bound),
2693 334 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2694 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2695 0 : "dimension index", expr->value.function.isym->name,
2696 : &expr->where);
2697 : }
2698 94 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2699 : {
2700 36 : bound = gfc_evaluate_now (bound, &se->pre);
2701 36 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2702 : bound, gfc_rank_cst[1]);
2703 36 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2704 36 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2705 : bound, rank);
2706 36 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2707 : logical_type_node, cond, tmp);
2708 36 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2709 : gfc_msg_fault);
2710 : }
2711 :
2712 :
2713 : /* Subtract 1 to get to zero based and add dimensions. */
2714 428 : switch (arg->expr->rank)
2715 : {
2716 70 : case 0:
2717 70 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2718 : gfc_array_dim_rank_type, bound,
2719 : gfc_rank_cst[1]);
2720 : case 1:
2721 : break;
2722 38 : default:
2723 38 : {
2724 38 : tree rank = gfc_rank_cst[arg->expr->rank - 1];
2725 38 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2726 : gfc_array_dim_rank_type, bound, rank);
2727 : }
2728 : }
2729 : }
2730 :
2731 666 : resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2732 :
2733 : /* COSHAPE needs the lower cobound and so it is stashed here before resbound
2734 : is overwritten. */
2735 666 : lbound = NULL_TREE;
2736 666 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2737 4 : lbound = resbound;
2738 :
2739 : /* Handle UCOBOUND with special handling of the last codimension. */
2740 666 : if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2741 422 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2742 : {
2743 : /* Last codimension: For -fcoarray=single just return
2744 : the lcobound - otherwise add
2745 : ceiling (real (num_images ()) / real (size)) - 1
2746 : = (num_images () + size - 1) / size - 1
2747 : = (num_images - 1) / size(),
2748 : where size is the product of the extent of all but the last
2749 : codimension. */
2750 :
2751 248 : if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2752 : {
2753 64 : tree cosize;
2754 :
2755 64 : cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2756 64 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2757 : 2, null_pointer_node, null_pointer_node);
2758 64 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2759 : gfc_array_index_type,
2760 : fold_convert (gfc_array_index_type, tmp),
2761 : build_int_cst (gfc_array_index_type, 1));
2762 64 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2763 : gfc_array_index_type, tmp,
2764 : fold_convert (gfc_array_index_type, cosize));
2765 64 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2766 : gfc_array_index_type, resbound, tmp);
2767 64 : }
2768 184 : else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2769 : {
2770 : /* ubound = lbound + num_images() - 1. */
2771 44 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2772 : 2, null_pointer_node, null_pointer_node);
2773 44 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2774 : gfc_array_index_type,
2775 : fold_convert (gfc_array_index_type, tmp),
2776 : build_int_cst (gfc_array_index_type, 1));
2777 44 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2778 : gfc_array_index_type, resbound, tmp);
2779 : }
2780 :
2781 248 : if (corank > 1)
2782 : {
2783 171 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2784 : bound,
2785 171 : build_int_cst (TREE_TYPE (bound),
2786 171 : arg->expr->rank + corank - 1));
2787 :
2788 171 : resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2789 171 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2790 : gfc_array_index_type, cond,
2791 : resbound, resbound2);
2792 : }
2793 : else
2794 : se->expr = resbound;
2795 :
2796 : /* Get the coshape for this dimension. */
2797 248 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2798 : {
2799 4 : gcc_assert (lbound != NULL_TREE);
2800 4 : se->expr = fold_build2_loc (input_location, MINUS_EXPR,
2801 : gfc_array_index_type,
2802 : se->expr, lbound);
2803 4 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2804 : gfc_array_index_type,
2805 : se->expr, gfc_index_one_node);
2806 : }
2807 : }
2808 : else
2809 418 : se->expr = resbound;
2810 :
2811 666 : type = gfc_typenode_for_spec (&expr->ts);
2812 666 : se->expr = convert (type, se->expr);
2813 666 : }
2814 :
2815 :
2816 : static void
2817 2423 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2818 : {
2819 2423 : gfc_actual_arglist *array_arg;
2820 2423 : gfc_actual_arglist *dim_arg;
2821 2423 : gfc_se argse;
2822 2423 : tree desc, tmp;
2823 :
2824 2423 : array_arg = expr->value.function.actual;
2825 2423 : dim_arg = array_arg->next;
2826 :
2827 2423 : gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2828 :
2829 2423 : gfc_init_se (&argse, NULL);
2830 2423 : gfc_conv_expr_descriptor (&argse, array_arg->expr);
2831 2423 : gfc_add_block_to_block (&se->pre, &argse.pre);
2832 2423 : gfc_add_block_to_block (&se->post, &argse.post);
2833 2423 : desc = argse.expr;
2834 :
2835 2423 : gcc_assert (dim_arg->expr);
2836 2423 : gfc_init_se (&argse, NULL);
2837 2423 : gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2838 2423 : gfc_add_block_to_block (&se->pre, &argse.pre);
2839 2423 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2840 : argse.expr, gfc_index_one_node);
2841 2423 : se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2842 2423 : }
2843 :
2844 : static void
2845 7992 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2846 : {
2847 7992 : tree arg, cabs;
2848 :
2849 7992 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2850 :
2851 7992 : switch (expr->value.function.actual->expr->ts.type)
2852 : {
2853 6986 : case BT_INTEGER:
2854 6986 : case BT_REAL:
2855 6986 : se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2856 : arg);
2857 6986 : break;
2858 :
2859 1006 : case BT_COMPLEX:
2860 1006 : cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
2861 1006 : se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2862 1006 : break;
2863 :
2864 0 : default:
2865 0 : gcc_unreachable ();
2866 : }
2867 7992 : }
2868 :
2869 :
2870 : /* Create a complex value from one or two real components. */
2871 :
2872 : static void
2873 491 : gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2874 : {
2875 491 : tree real;
2876 491 : tree imag;
2877 491 : tree type;
2878 491 : tree *args;
2879 491 : unsigned int num_args;
2880 :
2881 491 : num_args = gfc_intrinsic_argument_list_length (expr);
2882 491 : args = XALLOCAVEC (tree, num_args);
2883 :
2884 491 : type = gfc_typenode_for_spec (&expr->ts);
2885 491 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2886 491 : real = convert (TREE_TYPE (type), args[0]);
2887 491 : if (both)
2888 447 : imag = convert (TREE_TYPE (type), args[1]);
2889 44 : else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
2890 : {
2891 30 : imag = fold_build1_loc (input_location, IMAGPART_EXPR,
2892 30 : TREE_TYPE (TREE_TYPE (args[0])), args[0]);
2893 30 : imag = convert (TREE_TYPE (type), imag);
2894 : }
2895 : else
2896 14 : imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
2897 :
2898 491 : se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
2899 491 : }
2900 :
2901 :
2902 : /* Remainder function MOD(A, P) = A - INT(A / P) * P
2903 : MODULO(A, P) = A - FLOOR (A / P) * P
2904 :
2905 : The obvious algorithms above are numerically instable for large
2906 : arguments, hence these intrinsics are instead implemented via calls
2907 : to the fmod family of functions. It is the responsibility of the
2908 : user to ensure that the second argument is non-zero. */
2909 :
2910 : static void
2911 3821 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2912 : {
2913 3821 : tree type;
2914 3821 : tree tmp;
2915 3821 : tree test;
2916 3821 : tree test2;
2917 3821 : tree fmod;
2918 3821 : tree zero;
2919 3821 : tree args[2];
2920 :
2921 3821 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
2922 :
2923 3821 : switch (expr->ts.type)
2924 : {
2925 3668 : case BT_INTEGER:
2926 : /* Integer case is easy, we've got a builtin op. */
2927 3668 : type = TREE_TYPE (args[0]);
2928 :
2929 3668 : if (modulo)
2930 411 : se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2931 : args[0], args[1]);
2932 : else
2933 3257 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2934 : args[0], args[1]);
2935 : break;
2936 :
2937 30 : case BT_UNSIGNED:
2938 : /* Even easier, we only need one. */
2939 30 : type = TREE_TYPE (args[0]);
2940 30 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2941 : args[0], args[1]);
2942 30 : break;
2943 :
2944 123 : case BT_REAL:
2945 123 : fmod = NULL_TREE;
2946 : /* Check if we have a builtin fmod. */
2947 123 : fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
2948 :
2949 : /* The builtin should always be available. */
2950 123 : gcc_assert (fmod != NULL_TREE);
2951 :
2952 123 : tmp = build_addr (fmod);
2953 123 : se->expr = build_call_array_loc (input_location,
2954 123 : TREE_TYPE (TREE_TYPE (fmod)),
2955 : tmp, 2, args);
2956 123 : if (modulo == 0)
2957 123 : return;
2958 :
2959 25 : type = TREE_TYPE (args[0]);
2960 :
2961 25 : args[0] = gfc_evaluate_now (args[0], &se->pre);
2962 25 : args[1] = gfc_evaluate_now (args[1], &se->pre);
2963 :
2964 : /* Definition:
2965 : modulo = arg - floor (arg/arg2) * arg2
2966 :
2967 : In order to calculate the result accurately, we use the fmod
2968 : function as follows.
2969 :
2970 : res = fmod (arg, arg2);
2971 : if (res)
2972 : {
2973 : if ((arg < 0) xor (arg2 < 0))
2974 : res += arg2;
2975 : }
2976 : else
2977 : res = copysign (0., arg2);
2978 :
2979 : => As two nested ternary exprs:
2980 :
2981 : res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2982 : : copysign (0., arg2);
2983 :
2984 : */
2985 :
2986 25 : zero = gfc_build_const (type, integer_zero_node);
2987 25 : tmp = gfc_evaluate_now (se->expr, &se->pre);
2988 25 : if (!flag_signed_zeros)
2989 : {
2990 1 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2991 : args[0], zero);
2992 1 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2993 : args[1], zero);
2994 1 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2995 : logical_type_node, test, test2);
2996 1 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2997 : tmp, zero);
2998 1 : test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2999 : logical_type_node, test, test2);
3000 1 : test = gfc_evaluate_now (test, &se->pre);
3001 1 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3002 : fold_build2_loc (input_location,
3003 : PLUS_EXPR,
3004 : type, tmp, args[1]),
3005 : tmp);
3006 : }
3007 : else
3008 : {
3009 24 : tree expr1, copysign, cscall;
3010 24 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3011 : expr->ts.kind);
3012 24 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3013 : args[0], zero);
3014 24 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3015 : args[1], zero);
3016 24 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3017 : logical_type_node, test, test2);
3018 24 : expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3019 : fold_build2_loc (input_location,
3020 : PLUS_EXPR,
3021 : type, tmp, args[1]),
3022 : tmp);
3023 24 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3024 : tmp, zero);
3025 24 : cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3026 : args[1]);
3027 24 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3028 : expr1, cscall);
3029 : }
3030 : return;
3031 :
3032 0 : default:
3033 0 : gcc_unreachable ();
3034 : }
3035 : }
3036 :
3037 : /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3038 : DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3039 : where the right shifts are logical (i.e. 0's are shifted in).
3040 : Because SHIFT_EXPR's want shifts strictly smaller than the integral
3041 : type width, we have to special-case both S == 0 and S == BITSIZE(J):
3042 : DSHIFTL(I,J,0) = I
3043 : DSHIFTL(I,J,BITSIZE) = J
3044 : DSHIFTR(I,J,0) = J
3045 : DSHIFTR(I,J,BITSIZE) = I. */
3046 :
3047 : static void
3048 132 : gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3049 : {
3050 132 : tree type, utype, stype, arg1, arg2, shift, res, left, right;
3051 132 : tree args[3], cond, tmp;
3052 132 : int bitsize;
3053 :
3054 132 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
3055 :
3056 132 : gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3057 132 : type = TREE_TYPE (args[0]);
3058 132 : bitsize = TYPE_PRECISION (type);
3059 132 : utype = unsigned_type_for (type);
3060 132 : stype = TREE_TYPE (args[2]);
3061 :
3062 132 : arg1 = gfc_evaluate_now (args[0], &se->pre);
3063 132 : arg2 = gfc_evaluate_now (args[1], &se->pre);
3064 132 : shift = gfc_evaluate_now (args[2], &se->pre);
3065 :
3066 : /* The generic case. */
3067 132 : tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3068 132 : build_int_cst (stype, bitsize), shift);
3069 198 : left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3070 : arg1, dshiftl ? shift : tmp);
3071 :
3072 198 : right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3073 : fold_convert (utype, arg2), dshiftl ? tmp : shift);
3074 132 : right = fold_convert (type, right);
3075 :
3076 132 : res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3077 :
3078 : /* Special cases. */
3079 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3080 : build_int_cst (stype, 0));
3081 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3082 : dshiftl ? arg1 : arg2, res);
3083 :
3084 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3085 132 : build_int_cst (stype, bitsize));
3086 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3087 : dshiftl ? arg2 : arg1, res);
3088 :
3089 132 : se->expr = res;
3090 132 : }
3091 :
3092 :
3093 : /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3094 :
3095 : static void
3096 96 : gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3097 : {
3098 96 : tree val;
3099 96 : tree tmp;
3100 96 : tree type;
3101 96 : tree zero;
3102 96 : tree args[2];
3103 :
3104 96 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3105 96 : type = TREE_TYPE (args[0]);
3106 :
3107 96 : val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3108 96 : val = gfc_evaluate_now (val, &se->pre);
3109 :
3110 96 : zero = gfc_build_const (type, integer_zero_node);
3111 96 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3112 96 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3113 96 : }
3114 :
3115 :
3116 : /* SIGN(A, B) is absolute value of A times sign of B.
3117 : The real value versions use library functions to ensure the correct
3118 : handling of negative zero. Integer case implemented as:
3119 : SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3120 : */
3121 :
3122 : static void
3123 423 : gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3124 : {
3125 423 : tree tmp;
3126 423 : tree type;
3127 423 : tree args[2];
3128 :
3129 423 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3130 423 : if (expr->ts.type == BT_REAL)
3131 : {
3132 161 : tree abs;
3133 :
3134 161 : tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3135 161 : abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3136 :
3137 : /* We explicitly have to ignore the minus sign. We do so by using
3138 : result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3139 161 : if (!flag_sign_zero
3140 197 : && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3141 : {
3142 12 : tree cond, zero;
3143 12 : zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3144 12 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3145 : args[1], zero);
3146 24 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3147 12 : TREE_TYPE (args[0]), cond,
3148 : build_call_expr_loc (input_location, abs, 1,
3149 : args[0]),
3150 : build_call_expr_loc (input_location, tmp, 2,
3151 : args[0], args[1]));
3152 : }
3153 : else
3154 149 : se->expr = build_call_expr_loc (input_location, tmp, 2,
3155 : args[0], args[1]);
3156 161 : return;
3157 : }
3158 :
3159 : /* Having excluded floating point types, we know we are now dealing
3160 : with signed integer types. */
3161 262 : type = TREE_TYPE (args[0]);
3162 :
3163 : /* Args[0] is used multiple times below. */
3164 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3165 :
3166 : /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3167 : the signs of A and B are the same, and of all ones if they differ. */
3168 262 : tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3169 262 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3170 262 : build_int_cst (type, TYPE_PRECISION (type) - 1));
3171 262 : tmp = gfc_evaluate_now (tmp, &se->pre);
3172 :
3173 : /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3174 : is all ones (i.e. -1). */
3175 262 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3176 : fold_build2_loc (input_location, PLUS_EXPR,
3177 : type, args[0], tmp), tmp);
3178 : }
3179 :
3180 :
3181 : /* Test for the presence of an optional argument. */
3182 :
3183 : static void
3184 5088 : gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3185 : {
3186 5088 : gfc_expr *arg;
3187 :
3188 5088 : arg = expr->value.function.actual->expr;
3189 5088 : gcc_assert (arg->expr_type == EXPR_VARIABLE);
3190 5088 : se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3191 5088 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3192 5088 : }
3193 :
3194 :
3195 : /* Calculate the double precision product of two single precision values. */
3196 :
3197 : static void
3198 13 : gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3199 : {
3200 13 : tree type;
3201 13 : tree args[2];
3202 :
3203 13 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3204 :
3205 : /* Convert the args to double precision before multiplying. */
3206 13 : type = gfc_typenode_for_spec (&expr->ts);
3207 13 : args[0] = convert (type, args[0]);
3208 13 : args[1] = convert (type, args[1]);
3209 13 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3210 : args[1]);
3211 13 : }
3212 :
3213 :
3214 : /* Return a length one character string containing an ascii character. */
3215 :
3216 : static void
3217 2020 : gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3218 : {
3219 2020 : tree arg[2];
3220 2020 : tree var;
3221 2020 : tree type;
3222 2020 : unsigned int num_args;
3223 :
3224 2020 : num_args = gfc_intrinsic_argument_list_length (expr);
3225 2020 : gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3226 :
3227 2020 : type = gfc_get_char_type (expr->ts.kind);
3228 2020 : var = gfc_create_var (type, "char");
3229 :
3230 2020 : arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3231 2020 : gfc_add_modify (&se->pre, var, arg[0]);
3232 2020 : se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3233 2020 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3234 2020 : }
3235 :
3236 :
3237 : static void
3238 0 : gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3239 : {
3240 0 : tree var;
3241 0 : tree len;
3242 0 : tree tmp;
3243 0 : tree cond;
3244 0 : tree fndecl;
3245 0 : tree *args;
3246 0 : unsigned int num_args;
3247 :
3248 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3249 0 : args = XALLOCAVEC (tree, num_args);
3250 :
3251 0 : var = gfc_create_var (pchar_type_node, "pstr");
3252 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3253 :
3254 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3255 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3256 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3257 :
3258 0 : fndecl = build_addr (gfor_fndecl_ctime);
3259 0 : tmp = build_call_array_loc (input_location,
3260 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3261 : fndecl, num_args, args);
3262 0 : gfc_add_expr_to_block (&se->pre, tmp);
3263 :
3264 : /* Free the temporary afterwards, if necessary. */
3265 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3266 0 : len, build_int_cst (TREE_TYPE (len), 0));
3267 0 : tmp = gfc_call_free (var);
3268 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3269 0 : gfc_add_expr_to_block (&se->post, tmp);
3270 :
3271 0 : se->expr = var;
3272 0 : se->string_length = len;
3273 0 : }
3274 :
3275 :
3276 : static void
3277 0 : gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3278 : {
3279 0 : tree var;
3280 0 : tree len;
3281 0 : tree tmp;
3282 0 : tree cond;
3283 0 : tree fndecl;
3284 0 : tree *args;
3285 0 : unsigned int num_args;
3286 :
3287 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3288 0 : args = XALLOCAVEC (tree, num_args);
3289 :
3290 0 : var = gfc_create_var (pchar_type_node, "pstr");
3291 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3292 :
3293 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3294 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3295 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3296 :
3297 0 : fndecl = build_addr (gfor_fndecl_fdate);
3298 0 : tmp = build_call_array_loc (input_location,
3299 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3300 : fndecl, num_args, args);
3301 0 : gfc_add_expr_to_block (&se->pre, tmp);
3302 :
3303 : /* Free the temporary afterwards, if necessary. */
3304 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3305 0 : len, build_int_cst (TREE_TYPE (len), 0));
3306 0 : tmp = gfc_call_free (var);
3307 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3308 0 : gfc_add_expr_to_block (&se->post, tmp);
3309 :
3310 0 : se->expr = var;
3311 0 : se->string_length = len;
3312 0 : }
3313 :
3314 :
3315 : /* Generate a direct call to free() for the FREE subroutine. */
3316 :
3317 : static tree
3318 10 : conv_intrinsic_free (gfc_code *code)
3319 : {
3320 10 : stmtblock_t block;
3321 10 : gfc_se argse;
3322 10 : tree arg, call;
3323 :
3324 10 : gfc_init_se (&argse, NULL);
3325 10 : gfc_conv_expr (&argse, code->ext.actual->expr);
3326 10 : arg = fold_convert (ptr_type_node, argse.expr);
3327 :
3328 10 : gfc_init_block (&block);
3329 10 : call = build_call_expr_loc (input_location,
3330 : builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3331 10 : gfc_add_expr_to_block (&block, call);
3332 10 : return gfc_finish_block (&block);
3333 : }
3334 :
3335 :
3336 : /* Call the RANDOM_INIT library subroutine with a hidden argument for
3337 : handling seeding on coarray images. */
3338 :
3339 : static tree
3340 90 : conv_intrinsic_random_init (gfc_code *code)
3341 : {
3342 90 : stmtblock_t block;
3343 90 : gfc_se se;
3344 90 : tree arg1, arg2, tmp;
3345 : /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3346 90 : tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3347 90 : ? logical_type_node
3348 90 : : gfc_get_logical_type (4);
3349 :
3350 : /* Make the function call. */
3351 90 : gfc_init_block (&block);
3352 90 : gfc_init_se (&se, NULL);
3353 :
3354 : /* Convert REPEATABLE to the desired LOGICAL entity. */
3355 90 : gfc_conv_expr (&se, code->ext.actual->expr);
3356 90 : gfc_add_block_to_block (&block, &se.pre);
3357 90 : arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3358 90 : gfc_add_block_to_block (&block, &se.post);
3359 :
3360 : /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3361 90 : gfc_conv_expr (&se, code->ext.actual->next->expr);
3362 90 : gfc_add_block_to_block (&block, &se.pre);
3363 90 : arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3364 90 : gfc_add_block_to_block (&block, &se.post);
3365 :
3366 90 : if (flag_coarray == GFC_FCOARRAY_LIB)
3367 : {
3368 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3369 : 2, arg1, arg2);
3370 : }
3371 : else
3372 : {
3373 : /* The ABI for libgfortran needs to be maintained, so a hidden
3374 : argument must be include if code is compiled with -fcoarray=single
3375 : or without the option. Set to 0. */
3376 90 : tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3377 90 : tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3378 : 3, arg1, arg2, arg3);
3379 : }
3380 :
3381 90 : gfc_add_expr_to_block (&block, tmp);
3382 :
3383 90 : return gfc_finish_block (&block);
3384 : }
3385 :
3386 :
3387 : /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3388 : conversions. */
3389 :
3390 : static tree
3391 196 : conv_intrinsic_system_clock (gfc_code *code)
3392 : {
3393 196 : stmtblock_t block;
3394 196 : gfc_se count_se, count_rate_se, count_max_se;
3395 196 : tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3396 196 : tree tmp;
3397 196 : int least;
3398 :
3399 196 : gfc_expr *count = code->ext.actual->expr;
3400 196 : gfc_expr *count_rate = code->ext.actual->next->expr;
3401 196 : gfc_expr *count_max = code->ext.actual->next->next->expr;
3402 :
3403 : /* Evaluate our arguments. */
3404 196 : if (count)
3405 : {
3406 196 : gfc_init_se (&count_se, NULL);
3407 196 : gfc_conv_expr (&count_se, count);
3408 : }
3409 :
3410 196 : if (count_rate)
3411 : {
3412 181 : gfc_init_se (&count_rate_se, NULL);
3413 181 : gfc_conv_expr (&count_rate_se, count_rate);
3414 : }
3415 :
3416 196 : if (count_max)
3417 : {
3418 180 : gfc_init_se (&count_max_se, NULL);
3419 180 : gfc_conv_expr (&count_max_se, count_max);
3420 : }
3421 :
3422 : /* Find the smallest kind found of the arguments. */
3423 196 : least = 16;
3424 196 : least = (count && count->ts.kind < least) ? count->ts.kind : least;
3425 196 : least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3426 : : least;
3427 196 : least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3428 : : least;
3429 :
3430 : /* Prepare temporary variables. */
3431 :
3432 196 : if (count)
3433 : {
3434 196 : if (least >= 8)
3435 18 : arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3436 178 : else if (least == 4)
3437 154 : arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3438 24 : else if (count->ts.kind == 1)
3439 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3440 : count->ts.kind);
3441 : else
3442 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3443 : count->ts.kind);
3444 : }
3445 :
3446 196 : if (count_rate)
3447 : {
3448 181 : if (least >= 8)
3449 18 : arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3450 163 : else if (least == 4)
3451 139 : arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3452 : else
3453 24 : arg2 = integer_zero_node;
3454 : }
3455 :
3456 196 : if (count_max)
3457 : {
3458 180 : if (least >= 8)
3459 18 : arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3460 162 : else if (least == 4)
3461 138 : arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3462 : else
3463 24 : arg3 = integer_zero_node;
3464 : }
3465 :
3466 : /* Make the function call. */
3467 196 : gfc_init_block (&block);
3468 :
3469 196 : if (least <= 2)
3470 : {
3471 24 : if (least == 1)
3472 : {
3473 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3474 : : null_pointer_node;
3475 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3476 : : null_pointer_node;
3477 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3478 : : null_pointer_node;
3479 : }
3480 :
3481 24 : if (least == 2)
3482 : {
3483 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3484 : : null_pointer_node;
3485 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3486 : : null_pointer_node;
3487 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3488 : : null_pointer_node;
3489 : }
3490 : }
3491 : else
3492 : {
3493 172 : if (least == 4)
3494 : {
3495 585 : tmp = build_call_expr_loc (input_location,
3496 : gfor_fndecl_system_clock4, 3,
3497 154 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3498 : : null_pointer_node,
3499 139 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3500 : : null_pointer_node,
3501 138 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3502 : : null_pointer_node);
3503 154 : gfc_add_expr_to_block (&block, tmp);
3504 : }
3505 : /* Handle kind>=8, 10, or 16 arguments */
3506 172 : if (least >= 8)
3507 : {
3508 72 : tmp = build_call_expr_loc (input_location,
3509 : gfor_fndecl_system_clock8, 3,
3510 18 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3511 : : null_pointer_node,
3512 18 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3513 : : null_pointer_node,
3514 18 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3515 : : null_pointer_node);
3516 18 : gfc_add_expr_to_block (&block, tmp);
3517 : }
3518 : }
3519 :
3520 : /* And store values back if needed. */
3521 196 : if (arg1 && arg1 != count_se.expr)
3522 196 : gfc_add_modify (&block, count_se.expr,
3523 196 : fold_convert (TREE_TYPE (count_se.expr), arg1));
3524 196 : if (arg2 && arg2 != count_rate_se.expr)
3525 181 : gfc_add_modify (&block, count_rate_se.expr,
3526 181 : fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3527 196 : if (arg3 && arg3 != count_max_se.expr)
3528 180 : gfc_add_modify (&block, count_max_se.expr,
3529 180 : fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3530 :
3531 196 : return gfc_finish_block (&block);
3532 : }
3533 :
3534 : static tree
3535 102 : conv_intrinsic_split (gfc_code *code)
3536 : {
3537 102 : stmtblock_t block, post_block;
3538 102 : gfc_se se;
3539 102 : gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
3540 102 : tree string, string_len;
3541 102 : tree set, set_len;
3542 102 : tree pos, pos_for_call;
3543 102 : tree back;
3544 102 : tree fndecl, call;
3545 :
3546 102 : string_expr = code->ext.actual->expr;
3547 102 : set_expr = code->ext.actual->next->expr;
3548 102 : pos_expr = code->ext.actual->next->next->expr;
3549 102 : back_expr = code->ext.actual->next->next->next->expr;
3550 :
3551 102 : gfc_start_block (&block);
3552 102 : gfc_init_block (&post_block);
3553 :
3554 102 : gfc_init_se (&se, NULL);
3555 102 : gfc_conv_expr (&se, string_expr);
3556 102 : gfc_conv_string_parameter (&se);
3557 102 : gfc_add_block_to_block (&block, &se.pre);
3558 102 : gfc_add_block_to_block (&post_block, &se.post);
3559 102 : string = se.expr;
3560 102 : string_len = se.string_length;
3561 :
3562 102 : gfc_init_se (&se, NULL);
3563 102 : gfc_conv_expr (&se, set_expr);
3564 102 : gfc_conv_string_parameter (&se);
3565 102 : gfc_add_block_to_block (&block, &se.pre);
3566 102 : gfc_add_block_to_block (&post_block, &se.post);
3567 102 : set = se.expr;
3568 102 : set_len = se.string_length;
3569 :
3570 102 : gfc_init_se (&se, NULL);
3571 102 : gfc_conv_expr (&se, pos_expr);
3572 102 : gfc_add_block_to_block (&block, &se.pre);
3573 102 : gfc_add_block_to_block (&post_block, &se.post);
3574 102 : pos = se.expr;
3575 102 : pos_for_call = fold_convert (gfc_charlen_type_node, pos);
3576 :
3577 102 : if (back_expr)
3578 : {
3579 48 : gfc_init_se (&se, NULL);
3580 48 : gfc_conv_expr (&se, back_expr);
3581 48 : gfc_add_block_to_block (&block, &se.pre);
3582 48 : gfc_add_block_to_block (&post_block, &se.post);
3583 48 : back = se.expr;
3584 : }
3585 : else
3586 54 : back = logical_false_node;
3587 :
3588 102 : if (string_expr->ts.kind == 1)
3589 66 : fndecl = gfor_fndecl_string_split;
3590 36 : else if (string_expr->ts.kind == 4)
3591 36 : fndecl = gfor_fndecl_string_split_char4;
3592 : else
3593 0 : gcc_unreachable ();
3594 :
3595 102 : call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
3596 : set_len, set, pos_for_call, back);
3597 102 : gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
3598 :
3599 102 : gfc_add_block_to_block (&block, &post_block);
3600 102 : return gfc_finish_block (&block);
3601 : }
3602 :
3603 : /* Return a character string containing the tty name. */
3604 :
3605 : static void
3606 0 : gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3607 : {
3608 0 : tree var;
3609 0 : tree len;
3610 0 : tree tmp;
3611 0 : tree cond;
3612 0 : tree fndecl;
3613 0 : tree *args;
3614 0 : unsigned int num_args;
3615 :
3616 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3617 0 : args = XALLOCAVEC (tree, num_args);
3618 :
3619 0 : var = gfc_create_var (pchar_type_node, "pstr");
3620 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3621 :
3622 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3623 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3624 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3625 :
3626 0 : fndecl = build_addr (gfor_fndecl_ttynam);
3627 0 : tmp = build_call_array_loc (input_location,
3628 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3629 : fndecl, num_args, args);
3630 0 : gfc_add_expr_to_block (&se->pre, tmp);
3631 :
3632 : /* Free the temporary afterwards, if necessary. */
3633 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3634 0 : len, build_int_cst (TREE_TYPE (len), 0));
3635 0 : tmp = gfc_call_free (var);
3636 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3637 0 : gfc_add_expr_to_block (&se->post, tmp);
3638 :
3639 0 : se->expr = var;
3640 0 : se->string_length = len;
3641 0 : }
3642 :
3643 :
3644 : /* Get the minimum/maximum value of all the parameters.
3645 : minmax (a1, a2, a3, ...)
3646 : {
3647 : mvar = a1;
3648 : mvar = COMP (mvar, a2)
3649 : mvar = COMP (mvar, a3)
3650 : ...
3651 : return mvar;
3652 : }
3653 : Where COMP is MIN/MAX_EXPR for integral types or when we don't
3654 : care about NaNs, or IFN_FMIN/MAX when the target has support for
3655 : fast NaN-honouring min/max. When neither holds expand a sequence
3656 : of explicit comparisons. */
3657 :
3658 : /* TODO: Mismatching types can occur when specific names are used.
3659 : These should be handled during resolution. */
3660 : static void
3661 1365 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3662 : {
3663 1365 : tree tmp;
3664 1365 : tree mvar;
3665 1365 : tree val;
3666 1365 : tree *args;
3667 1365 : tree type;
3668 1365 : tree argtype;
3669 1365 : gfc_actual_arglist *argexpr;
3670 1365 : unsigned int i, nargs;
3671 :
3672 1365 : nargs = gfc_intrinsic_argument_list_length (expr);
3673 1365 : args = XALLOCAVEC (tree, nargs);
3674 :
3675 1365 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3676 1365 : type = gfc_typenode_for_spec (&expr->ts);
3677 :
3678 : /* Only evaluate the argument once. */
3679 1365 : if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3680 368 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3681 :
3682 : /* Determine suitable type of temporary, as a GNU extension allows
3683 : different argument kinds. */
3684 1365 : argtype = TREE_TYPE (args[0]);
3685 1365 : argexpr = expr->value.function.actual;
3686 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3687 : {
3688 1584 : tree tmptype = TREE_TYPE (args[i]);
3689 1584 : if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
3690 1 : argtype = tmptype;
3691 : }
3692 1365 : mvar = gfc_create_var (argtype, "M");
3693 1365 : gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
3694 :
3695 1365 : argexpr = expr->value.function.actual;
3696 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3697 : {
3698 1584 : tree cond = NULL_TREE;
3699 1584 : val = args[i];
3700 :
3701 : /* Handle absent optional arguments by ignoring the comparison. */
3702 1584 : if (argexpr->expr->expr_type == EXPR_VARIABLE
3703 920 : && argexpr->expr->symtree->n.sym->attr.optional
3704 45 : && INDIRECT_REF_P (val))
3705 : {
3706 84 : cond = fold_build2_loc (input_location,
3707 : NE_EXPR, logical_type_node,
3708 42 : TREE_OPERAND (val, 0),
3709 42 : build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3710 : }
3711 1542 : else if (!VAR_P (val) && !TREE_CONSTANT (val))
3712 : /* Only evaluate the argument once. */
3713 599 : val = gfc_evaluate_now (val, &se->pre);
3714 :
3715 1584 : tree calc;
3716 : /* For floating point types, the question is what MAX(a, NaN) or
3717 : MIN(a, NaN) should return (where "a" is a normal number).
3718 : There are valid use case for returning either one, but the
3719 : Fortran standard doesn't specify which one should be chosen.
3720 : Also, there is no consensus among other tested compilers. In
3721 : short, it's a mess. So lets just do whatever is fastest. */
3722 1584 : tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
3723 1584 : calc = fold_build2_loc (input_location, code, argtype,
3724 : convert (argtype, val), mvar);
3725 1584 : tmp = build2_v (MODIFY_EXPR, mvar, calc);
3726 :
3727 1584 : if (cond != NULL_TREE)
3728 42 : tmp = build3_v (COND_EXPR, cond, tmp,
3729 : build_empty_stmt (input_location));
3730 1584 : gfc_add_expr_to_block (&se->pre, tmp);
3731 : }
3732 1365 : se->expr = convert (type, mvar);
3733 1365 : }
3734 :
3735 :
3736 : /* Generate library calls for MIN and MAX intrinsics for character
3737 : variables. */
3738 : static void
3739 282 : gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3740 : {
3741 282 : tree *args;
3742 282 : tree var, len, fndecl, tmp, cond, function;
3743 282 : unsigned int nargs;
3744 :
3745 282 : nargs = gfc_intrinsic_argument_list_length (expr);
3746 282 : args = XALLOCAVEC (tree, nargs + 4);
3747 282 : gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3748 :
3749 : /* Create the result variables. */
3750 282 : len = gfc_create_var (gfc_charlen_type_node, "len");
3751 282 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
3752 282 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3753 282 : args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3754 282 : args[2] = build_int_cst (integer_type_node, op);
3755 282 : args[3] = build_int_cst (integer_type_node, nargs / 2);
3756 :
3757 282 : if (expr->ts.kind == 1)
3758 210 : function = gfor_fndecl_string_minmax;
3759 72 : else if (expr->ts.kind == 4)
3760 72 : function = gfor_fndecl_string_minmax_char4;
3761 : else
3762 0 : gcc_unreachable ();
3763 :
3764 : /* Make the function call. */
3765 282 : fndecl = build_addr (function);
3766 282 : tmp = build_call_array_loc (input_location,
3767 282 : TREE_TYPE (TREE_TYPE (function)), fndecl,
3768 : nargs + 4, args);
3769 282 : gfc_add_expr_to_block (&se->pre, tmp);
3770 :
3771 : /* Free the temporary afterwards, if necessary. */
3772 282 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3773 282 : len, build_int_cst (TREE_TYPE (len), 0));
3774 282 : tmp = gfc_call_free (var);
3775 282 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3776 282 : gfc_add_expr_to_block (&se->post, tmp);
3777 :
3778 282 : se->expr = var;
3779 282 : se->string_length = len;
3780 282 : }
3781 :
3782 :
3783 : /* Create a symbol node for this intrinsic. The symbol from the frontend
3784 : has the generic name. */
3785 :
3786 : static gfc_symbol *
3787 11321 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3788 : {
3789 11321 : gfc_symbol *sym;
3790 :
3791 : /* TODO: Add symbols for intrinsic function to the global namespace. */
3792 11321 : gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3793 11321 : sym = gfc_new_symbol (expr->value.function.name, NULL);
3794 :
3795 11321 : sym->ts = expr->ts;
3796 11321 : if (sym->ts.type == BT_CHARACTER)
3797 1784 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3798 11321 : sym->attr.external = 1;
3799 11321 : sym->attr.function = 1;
3800 11321 : sym->attr.always_explicit = 1;
3801 11321 : sym->attr.proc = PROC_INTRINSIC;
3802 11321 : sym->attr.flavor = FL_PROCEDURE;
3803 11321 : sym->result = sym;
3804 11321 : if (expr->rank > 0)
3805 : {
3806 9921 : sym->attr.dimension = 1;
3807 9921 : sym->as = gfc_get_array_spec ();
3808 9921 : sym->as->type = AS_ASSUMED_SHAPE;
3809 9921 : sym->as->rank = expr->rank;
3810 : }
3811 :
3812 11321 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3813 : ignore_optional ? expr->value.function.actual
3814 : : NULL);
3815 :
3816 11321 : return sym;
3817 : }
3818 :
3819 : /* Remove empty actual arguments. */
3820 :
3821 : static void
3822 8277 : remove_empty_actual_arguments (gfc_actual_arglist **ap)
3823 : {
3824 44456 : while (*ap)
3825 : {
3826 36179 : if ((*ap)->expr == NULL)
3827 : {
3828 11076 : gfc_actual_arglist *r = *ap;
3829 11076 : *ap = r->next;
3830 11076 : r->next = NULL;
3831 11076 : gfc_free_actual_arglist (r);
3832 : }
3833 : else
3834 25103 : ap = &((*ap)->next);
3835 : }
3836 8277 : }
3837 :
3838 : #define MAX_SPEC_ARG 12
3839 :
3840 : /* Make up an fn spec that's right for intrinsic functions that we
3841 : want to call. */
3842 :
3843 : static char *
3844 1939 : intrinsic_fnspec (gfc_expr *expr)
3845 : {
3846 1939 : static char fnspec_buf[MAX_SPEC_ARG*2+1];
3847 1939 : char *fp;
3848 1939 : int i;
3849 1939 : int num_char_args;
3850 :
3851 : #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
3852 :
3853 : /* Set the fndecl. */
3854 1939 : fp = fnspec_buf;
3855 : /* Function return value. FIXME: Check if the second letter could
3856 : be something other than a space, for further optimization. */
3857 1939 : ADD_CHAR ('.');
3858 1939 : if (expr->rank == 0)
3859 : {
3860 238 : if (expr->ts.type == BT_CHARACTER)
3861 : {
3862 84 : ADD_CHAR ('w'); /* Address of character. */
3863 84 : ADD_CHAR ('.'); /* Length of character. */
3864 : }
3865 : }
3866 : else
3867 1701 : ADD_CHAR ('w'); /* Return value is a descriptor. */
3868 :
3869 1939 : num_char_args = 0;
3870 10224 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
3871 : {
3872 8285 : if (a->expr == NULL)
3873 2565 : continue;
3874 :
3875 5720 : if (a->name && strcmp (a->name,"%VAL") == 0)
3876 1300 : ADD_CHAR ('.');
3877 : else
3878 : {
3879 4420 : if (a->expr->rank > 0)
3880 2575 : ADD_CHAR ('r');
3881 : else
3882 1845 : ADD_CHAR ('R');
3883 : }
3884 5720 : num_char_args += a->expr->ts.type == BT_CHARACTER;
3885 5720 : gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
3886 : }
3887 :
3888 2743 : for (i = 0; i < num_char_args; i++)
3889 804 : ADD_CHAR ('.');
3890 :
3891 1939 : *fp = '\0';
3892 1939 : return fnspec_buf;
3893 : }
3894 :
3895 : #undef MAX_SPEC_ARG
3896 : #undef ADD_CHAR
3897 :
3898 : /* Generate the right symbol for the specific intrinsic function and
3899 : modify the expr accordingly. This assumes that absent optional
3900 : arguments should be removed. */
3901 :
3902 : gfc_symbol *
3903 8277 : specific_intrinsic_symbol (gfc_expr *expr)
3904 : {
3905 8277 : gfc_symbol *sym;
3906 :
3907 8277 : sym = gfc_find_intrinsic_symbol (expr);
3908 8277 : if (sym == NULL)
3909 : {
3910 1939 : sym = gfc_get_intrinsic_function_symbol (expr);
3911 1939 : sym->ts = expr->ts;
3912 1939 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
3913 240 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
3914 :
3915 1939 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3916 : expr->value.function.actual, true);
3917 1939 : sym->backend_decl
3918 1939 : = gfc_get_extern_function_decl (sym, expr->value.function.actual,
3919 1939 : intrinsic_fnspec (expr));
3920 : }
3921 :
3922 8277 : remove_empty_actual_arguments (&(expr->value.function.actual));
3923 :
3924 8277 : return sym;
3925 : }
3926 :
3927 : /* Generate a call to an external intrinsic function. FIXME: So far,
3928 : this only works for functions which are called with well-defined
3929 : types; CSHIFT and friends will come later. */
3930 :
3931 : static void
3932 13731 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3933 : {
3934 13731 : gfc_symbol *sym;
3935 13731 : vec<tree, va_gc> *append_args;
3936 13731 : bool specific_symbol;
3937 :
3938 13731 : gcc_assert (!se->ss || se->ss->info->expr == expr);
3939 :
3940 13731 : if (se->ss)
3941 11769 : gcc_assert (expr->rank > 0);
3942 : else
3943 1962 : gcc_assert (expr->rank == 0);
3944 :
3945 13731 : switch (expr->value.function.isym->id)
3946 : {
3947 : case GFC_ISYM_ANY:
3948 : case GFC_ISYM_ALL:
3949 : case GFC_ISYM_FINDLOC:
3950 : case GFC_ISYM_MAXLOC:
3951 : case GFC_ISYM_MINLOC:
3952 : case GFC_ISYM_MAXVAL:
3953 : case GFC_ISYM_MINVAL:
3954 : case GFC_ISYM_NORM2:
3955 : case GFC_ISYM_PRODUCT:
3956 : case GFC_ISYM_SUM:
3957 : specific_symbol = true;
3958 : break;
3959 5454 : default:
3960 5454 : specific_symbol = false;
3961 : }
3962 :
3963 13731 : if (specific_symbol)
3964 : {
3965 : /* Need to copy here because specific_intrinsic_symbol modifies
3966 : expr to omit the absent optional arguments. */
3967 8277 : expr = gfc_copy_expr (expr);
3968 8277 : sym = specific_intrinsic_symbol (expr);
3969 : }
3970 : else
3971 5454 : sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
3972 :
3973 : /* Calls to libgfortran_matmul need to be appended special arguments,
3974 : to be able to call the BLAS ?gemm functions if required and possible. */
3975 13731 : append_args = NULL;
3976 13731 : if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3977 860 : && !expr->external_blas
3978 822 : && sym->ts.type != BT_LOGICAL)
3979 : {
3980 806 : tree cint = gfc_get_int_type (gfc_c_int_kind);
3981 :
3982 806 : if (flag_external_blas
3983 0 : && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3984 0 : && (sym->ts.kind == 4 || sym->ts.kind == 8))
3985 : {
3986 0 : tree gemm_fndecl;
3987 :
3988 0 : if (sym->ts.type == BT_REAL)
3989 : {
3990 0 : if (sym->ts.kind == 4)
3991 0 : gemm_fndecl = gfor_fndecl_sgemm;
3992 : else
3993 0 : gemm_fndecl = gfor_fndecl_dgemm;
3994 : }
3995 : else
3996 : {
3997 0 : if (sym->ts.kind == 4)
3998 0 : gemm_fndecl = gfor_fndecl_cgemm;
3999 : else
4000 0 : gemm_fndecl = gfor_fndecl_zgemm;
4001 : }
4002 :
4003 0 : vec_alloc (append_args, 3);
4004 0 : append_args->quick_push (build_int_cst (cint, 1));
4005 0 : append_args->quick_push (build_int_cst (cint,
4006 0 : flag_blas_matmul_limit));
4007 0 : append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
4008 : gemm_fndecl));
4009 0 : }
4010 : else
4011 : {
4012 806 : vec_alloc (append_args, 3);
4013 806 : append_args->quick_push (build_int_cst (cint, 0));
4014 806 : append_args->quick_push (build_int_cst (cint, 0));
4015 806 : append_args->quick_push (null_pointer_node);
4016 : }
4017 : }
4018 : /* Non-character scalar reduce returns a pointer to a result of size set by
4019 : the element size of 'array'. Setting 'sym' allocatable ensures that the
4020 : result is deallocated at the appropriate time. */
4021 12925 : else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
4022 108 : && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
4023 102 : sym->attr.allocatable = 1;
4024 :
4025 :
4026 13731 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4027 : append_args);
4028 :
4029 13731 : if (specific_symbol)
4030 8277 : gfc_free_expr (expr);
4031 : else
4032 5454 : gfc_free_symbol (sym);
4033 13731 : }
4034 :
4035 : /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4036 : Implemented as
4037 : any(a)
4038 : {
4039 : forall (i=...)
4040 : if (a[i] != 0)
4041 : return 1
4042 : end forall
4043 : return 0
4044 : }
4045 : all(a)
4046 : {
4047 : forall (i=...)
4048 : if (a[i] == 0)
4049 : return 0
4050 : end forall
4051 : return 1
4052 : }
4053 : */
4054 : static void
4055 38818 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4056 : {
4057 38818 : tree resvar;
4058 38818 : stmtblock_t block;
4059 38818 : stmtblock_t body;
4060 38818 : tree type;
4061 38818 : tree tmp;
4062 38818 : tree found;
4063 38818 : gfc_loopinfo loop;
4064 38818 : gfc_actual_arglist *actual;
4065 38818 : gfc_ss *arrayss;
4066 38818 : gfc_se arrayse;
4067 38818 : tree exit_label;
4068 :
4069 38818 : if (se->ss)
4070 : {
4071 0 : gfc_conv_intrinsic_funcall (se, expr);
4072 0 : return;
4073 : }
4074 :
4075 38818 : actual = expr->value.function.actual;
4076 38818 : type = gfc_typenode_for_spec (&expr->ts);
4077 : /* Initialize the result. */
4078 38818 : resvar = gfc_create_var (type, "test");
4079 38818 : if (op == EQ_EXPR)
4080 432 : tmp = convert (type, boolean_true_node);
4081 : else
4082 38386 : tmp = convert (type, boolean_false_node);
4083 38818 : gfc_add_modify (&se->pre, resvar, tmp);
4084 :
4085 : /* Walk the arguments. */
4086 38818 : arrayss = gfc_walk_expr (actual->expr);
4087 38818 : gcc_assert (arrayss != gfc_ss_terminator);
4088 :
4089 : /* Initialize the scalarizer. */
4090 38818 : gfc_init_loopinfo (&loop);
4091 38818 : exit_label = gfc_build_label_decl (NULL_TREE);
4092 38818 : TREE_USED (exit_label) = 1;
4093 38818 : gfc_add_ss_to_loop (&loop, arrayss);
4094 :
4095 : /* Initialize the loop. */
4096 38818 : gfc_conv_ss_startstride (&loop);
4097 38818 : gfc_conv_loop_setup (&loop, &expr->where);
4098 :
4099 38818 : gfc_mark_ss_chain_used (arrayss, 1);
4100 : /* Generate the loop body. */
4101 38818 : gfc_start_scalarized_body (&loop, &body);
4102 :
4103 : /* If the condition matches then set the return value. */
4104 38818 : gfc_start_block (&block);
4105 38818 : if (op == EQ_EXPR)
4106 432 : tmp = convert (type, boolean_false_node);
4107 : else
4108 38386 : tmp = convert (type, boolean_true_node);
4109 38818 : gfc_add_modify (&block, resvar, tmp);
4110 :
4111 : /* And break out of the loop. */
4112 38818 : tmp = build1_v (GOTO_EXPR, exit_label);
4113 38818 : gfc_add_expr_to_block (&block, tmp);
4114 :
4115 38818 : found = gfc_finish_block (&block);
4116 :
4117 : /* Check this element. */
4118 38818 : gfc_init_se (&arrayse, NULL);
4119 38818 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4120 38818 : arrayse.ss = arrayss;
4121 38818 : gfc_conv_expr_val (&arrayse, actual->expr);
4122 :
4123 38818 : gfc_add_block_to_block (&body, &arrayse.pre);
4124 38818 : tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4125 38818 : build_int_cst (TREE_TYPE (arrayse.expr), 0));
4126 38818 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4127 38818 : gfc_add_expr_to_block (&body, tmp);
4128 38818 : gfc_add_block_to_block (&body, &arrayse.post);
4129 :
4130 38818 : gfc_trans_scalarizing_loops (&loop, &body);
4131 :
4132 : /* Add the exit label. */
4133 38818 : tmp = build1_v (LABEL_EXPR, exit_label);
4134 38818 : gfc_add_expr_to_block (&loop.pre, tmp);
4135 :
4136 38818 : gfc_add_block_to_block (&se->pre, &loop.pre);
4137 38818 : gfc_add_block_to_block (&se->pre, &loop.post);
4138 38818 : gfc_cleanup_loop (&loop);
4139 :
4140 38818 : se->expr = resvar;
4141 : }
4142 :
4143 :
4144 : /* Generate the constant 180 / pi, which is used in the conversion
4145 : of acosd(), asind(), atand(), atan2d(). */
4146 :
4147 : static tree
4148 408 : rad2deg (int kind)
4149 : {
4150 408 : tree retval;
4151 408 : mpfr_t pi, t0;
4152 :
4153 408 : gfc_set_model_kind (kind);
4154 408 : mpfr_init (pi);
4155 408 : mpfr_init (t0);
4156 408 : mpfr_set_si (t0, 180, GFC_RND_MODE);
4157 408 : mpfr_const_pi (pi, GFC_RND_MODE);
4158 408 : mpfr_div (t0, t0, pi, GFC_RND_MODE);
4159 408 : retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4160 408 : mpfr_clear (t0);
4161 408 : mpfr_clear (pi);
4162 408 : return retval;
4163 : }
4164 :
4165 :
4166 : static gfc_intrinsic_map_t *
4167 618 : gfc_lookup_intrinsic (gfc_isym_id id)
4168 : {
4169 618 : gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4170 11514 : for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4171 11514 : if (id == m->id)
4172 : break;
4173 618 : gcc_assert (id == m->id);
4174 618 : return m;
4175 : }
4176 :
4177 :
4178 : /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4179 : ASIND(x) is translated into ASIN(x) * 180 / pi.
4180 : ATAND(x) is translated into ATAN(x) * 180 / pi. */
4181 :
4182 : static void
4183 270 : gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4184 : {
4185 270 : tree arg;
4186 270 : tree atrigd;
4187 270 : tree type;
4188 270 : gfc_intrinsic_map_t *m;
4189 :
4190 270 : type = gfc_typenode_for_spec (&expr->ts);
4191 :
4192 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4193 :
4194 270 : switch (id)
4195 : {
4196 90 : case GFC_ISYM_ACOSD:
4197 90 : m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
4198 90 : break;
4199 90 : case GFC_ISYM_ASIND:
4200 90 : m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
4201 90 : break;
4202 90 : case GFC_ISYM_ATAND:
4203 90 : m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
4204 90 : break;
4205 0 : default:
4206 0 : gcc_unreachable ();
4207 : }
4208 270 : atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4209 270 : atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4210 :
4211 270 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4212 : fold_convert (type, rad2deg (expr->ts.kind)));
4213 270 : }
4214 :
4215 :
4216 : /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4217 : COS(X) / SIN(X) for COMPLEX argument. */
4218 :
4219 : static void
4220 102 : gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4221 : {
4222 102 : gfc_intrinsic_map_t *m;
4223 102 : tree arg;
4224 102 : tree type;
4225 :
4226 102 : type = gfc_typenode_for_spec (&expr->ts);
4227 102 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4228 :
4229 102 : if (expr->ts.type == BT_REAL)
4230 : {
4231 102 : tree tan;
4232 102 : tree tmp;
4233 102 : mpfr_t pio2;
4234 :
4235 : /* Create pi/2. */
4236 102 : gfc_set_model_kind (expr->ts.kind);
4237 102 : mpfr_init (pio2);
4238 102 : mpfr_const_pi (pio2, GFC_RND_MODE);
4239 102 : mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4240 102 : tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4241 102 : mpfr_clear (pio2);
4242 :
4243 : /* Find tan builtin function. */
4244 102 : m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
4245 102 : tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4246 102 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4247 102 : tan = build_call_expr_loc (input_location, tan, 1, tmp);
4248 102 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4249 : }
4250 : else
4251 : {
4252 0 : tree sin;
4253 0 : tree cos;
4254 :
4255 : /* Find cos builtin function. */
4256 0 : m = gfc_lookup_intrinsic (GFC_ISYM_COS);
4257 0 : cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4258 0 : cos = build_call_expr_loc (input_location, cos, 1, arg);
4259 :
4260 : /* Find sin builtin function. */
4261 0 : m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
4262 0 : sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4263 0 : sin = build_call_expr_loc (input_location, sin, 1, arg);
4264 :
4265 : /* Divide cos by sin. */
4266 0 : se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4267 : }
4268 102 : }
4269 :
4270 :
4271 : /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4272 :
4273 : static void
4274 108 : gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4275 : {
4276 108 : tree arg;
4277 108 : tree type;
4278 108 : tree ninety_tree;
4279 108 : mpfr_t ninety;
4280 :
4281 108 : type = gfc_typenode_for_spec (&expr->ts);
4282 108 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4283 :
4284 108 : gfc_set_model_kind (expr->ts.kind);
4285 :
4286 : /* Build the tree for x + 90. */
4287 108 : mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4288 108 : ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4289 108 : arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4290 108 : mpfr_clear (ninety);
4291 :
4292 : /* Find tand. */
4293 108 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
4294 108 : tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4295 108 : tand = build_call_expr_loc (input_location, tand, 1, arg);
4296 :
4297 108 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4298 108 : }
4299 :
4300 :
4301 : /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4302 :
4303 : static void
4304 138 : gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4305 : {
4306 138 : tree args[2];
4307 138 : tree atan2d;
4308 138 : tree type;
4309 :
4310 138 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
4311 138 : type = TREE_TYPE (args[0]);
4312 :
4313 138 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
4314 138 : atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4315 138 : atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4316 :
4317 138 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4318 : rad2deg (expr->ts.kind));
4319 138 : }
4320 :
4321 :
4322 : /* COUNT(A) = Number of true elements in A. */
4323 : static void
4324 143 : gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4325 : {
4326 143 : tree resvar;
4327 143 : tree type;
4328 143 : stmtblock_t body;
4329 143 : tree tmp;
4330 143 : gfc_loopinfo loop;
4331 143 : gfc_actual_arglist *actual;
4332 143 : gfc_ss *arrayss;
4333 143 : gfc_se arrayse;
4334 :
4335 143 : if (se->ss)
4336 : {
4337 0 : gfc_conv_intrinsic_funcall (se, expr);
4338 0 : return;
4339 : }
4340 :
4341 143 : actual = expr->value.function.actual;
4342 :
4343 143 : type = gfc_typenode_for_spec (&expr->ts);
4344 : /* Initialize the result. */
4345 143 : resvar = gfc_create_var (type, "count");
4346 143 : gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4347 :
4348 : /* Walk the arguments. */
4349 143 : arrayss = gfc_walk_expr (actual->expr);
4350 143 : gcc_assert (arrayss != gfc_ss_terminator);
4351 :
4352 : /* Initialize the scalarizer. */
4353 143 : gfc_init_loopinfo (&loop);
4354 143 : gfc_add_ss_to_loop (&loop, arrayss);
4355 :
4356 : /* Initialize the loop. */
4357 143 : gfc_conv_ss_startstride (&loop);
4358 143 : gfc_conv_loop_setup (&loop, &expr->where);
4359 :
4360 143 : gfc_mark_ss_chain_used (arrayss, 1);
4361 : /* Generate the loop body. */
4362 143 : gfc_start_scalarized_body (&loop, &body);
4363 :
4364 143 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4365 143 : resvar, build_int_cst (TREE_TYPE (resvar), 1));
4366 143 : tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4367 :
4368 143 : gfc_init_se (&arrayse, NULL);
4369 143 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4370 143 : arrayse.ss = arrayss;
4371 143 : gfc_conv_expr_val (&arrayse, actual->expr);
4372 143 : tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4373 : build_empty_stmt (input_location));
4374 :
4375 143 : gfc_add_block_to_block (&body, &arrayse.pre);
4376 143 : gfc_add_expr_to_block (&body, tmp);
4377 143 : gfc_add_block_to_block (&body, &arrayse.post);
4378 :
4379 143 : gfc_trans_scalarizing_loops (&loop, &body);
4380 :
4381 143 : gfc_add_block_to_block (&se->pre, &loop.pre);
4382 143 : gfc_add_block_to_block (&se->pre, &loop.post);
4383 143 : gfc_cleanup_loop (&loop);
4384 :
4385 143 : se->expr = resvar;
4386 : }
4387 :
4388 :
4389 : /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4390 : struct and return the corresponding loopinfo. */
4391 :
4392 : static gfc_loopinfo *
4393 3374 : enter_nested_loop (gfc_se *se)
4394 : {
4395 3374 : se->ss = se->ss->nested_ss;
4396 3374 : gcc_assert (se->ss == se->ss->loop->ss);
4397 :
4398 3374 : return se->ss->loop;
4399 : }
4400 :
4401 : /* Build the condition for a mask, which may be optional. */
4402 :
4403 : static tree
4404 12763 : conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4405 : bool optional_mask)
4406 : {
4407 12763 : tree present;
4408 12763 : tree type;
4409 :
4410 12763 : if (optional_mask)
4411 : {
4412 206 : type = TREE_TYPE (maskse->expr);
4413 206 : present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4414 206 : present = convert (type, present);
4415 206 : present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4416 : present);
4417 206 : return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4418 206 : type, present, maskse->expr);
4419 : }
4420 : else
4421 12557 : return maskse->expr;
4422 : }
4423 :
4424 : /* Inline implementation of the sum and product intrinsics. */
4425 : static void
4426 2521 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4427 : bool norm2)
4428 : {
4429 2521 : tree resvar;
4430 2521 : tree scale = NULL_TREE;
4431 2521 : tree type;
4432 2521 : stmtblock_t body;
4433 2521 : stmtblock_t block;
4434 2521 : tree tmp;
4435 2521 : gfc_loopinfo loop, *ploop;
4436 2521 : gfc_actual_arglist *arg_array, *arg_mask;
4437 2521 : gfc_ss *arrayss = NULL;
4438 2521 : gfc_ss *maskss = NULL;
4439 2521 : gfc_se arrayse;
4440 2521 : gfc_se maskse;
4441 2521 : gfc_se *parent_se;
4442 2521 : gfc_expr *arrayexpr;
4443 2521 : gfc_expr *maskexpr;
4444 2521 : bool optional_mask;
4445 :
4446 2521 : if (expr->rank > 0)
4447 : {
4448 578 : gcc_assert (gfc_inline_intrinsic_function_p (expr));
4449 : parent_se = se;
4450 : }
4451 : else
4452 : parent_se = NULL;
4453 :
4454 2521 : type = gfc_typenode_for_spec (&expr->ts);
4455 : /* Initialize the result. */
4456 2521 : resvar = gfc_create_var (type, "val");
4457 2521 : if (norm2)
4458 : {
4459 : /* result = 0.0;
4460 : scale = 1.0. */
4461 68 : scale = gfc_create_var (type, "scale");
4462 68 : gfc_add_modify (&se->pre, scale,
4463 : gfc_build_const (type, integer_one_node));
4464 68 : tmp = gfc_build_const (type, integer_zero_node);
4465 : }
4466 2453 : else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4467 2035 : tmp = gfc_build_const (type, integer_zero_node);
4468 418 : else if (op == NE_EXPR)
4469 : /* PARITY. */
4470 36 : tmp = convert (type, boolean_false_node);
4471 382 : else if (op == BIT_AND_EXPR)
4472 24 : tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4473 : type, integer_one_node));
4474 : else
4475 358 : tmp = gfc_build_const (type, integer_one_node);
4476 :
4477 2521 : gfc_add_modify (&se->pre, resvar, tmp);
4478 :
4479 2521 : arg_array = expr->value.function.actual;
4480 :
4481 2521 : arrayexpr = arg_array->expr;
4482 :
4483 2521 : if (op == NE_EXPR || norm2)
4484 : {
4485 : /* PARITY and NORM2. */
4486 : maskexpr = NULL;
4487 : optional_mask = false;
4488 : }
4489 : else
4490 : {
4491 2417 : arg_mask = arg_array->next->next;
4492 2417 : gcc_assert (arg_mask != NULL);
4493 2417 : maskexpr = arg_mask->expr;
4494 371 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4495 266 : && maskexpr->symtree->n.sym->attr.dummy
4496 2435 : && maskexpr->symtree->n.sym->attr.optional;
4497 : }
4498 :
4499 2521 : if (expr->rank == 0)
4500 : {
4501 : /* Walk the arguments. */
4502 1943 : arrayss = gfc_walk_expr (arrayexpr);
4503 1943 : gcc_assert (arrayss != gfc_ss_terminator);
4504 :
4505 1943 : if (maskexpr && maskexpr->rank > 0)
4506 : {
4507 223 : maskss = gfc_walk_expr (maskexpr);
4508 223 : gcc_assert (maskss != gfc_ss_terminator);
4509 : }
4510 : else
4511 : maskss = NULL;
4512 :
4513 : /* Initialize the scalarizer. */
4514 1943 : gfc_init_loopinfo (&loop);
4515 :
4516 : /* We add the mask first because the number of iterations is
4517 : taken from the last ss, and this breaks if an absent
4518 : optional argument is used for mask. */
4519 :
4520 1943 : if (maskexpr && maskexpr->rank > 0)
4521 223 : gfc_add_ss_to_loop (&loop, maskss);
4522 1943 : gfc_add_ss_to_loop (&loop, arrayss);
4523 :
4524 : /* Initialize the loop. */
4525 1943 : gfc_conv_ss_startstride (&loop);
4526 1943 : gfc_conv_loop_setup (&loop, &expr->where);
4527 :
4528 1943 : if (maskexpr && maskexpr->rank > 0)
4529 223 : gfc_mark_ss_chain_used (maskss, 1);
4530 1943 : gfc_mark_ss_chain_used (arrayss, 1);
4531 :
4532 1943 : ploop = &loop;
4533 : }
4534 : else
4535 : /* All the work has been done in the parent loops. */
4536 578 : ploop = enter_nested_loop (se);
4537 :
4538 2521 : gcc_assert (ploop);
4539 :
4540 : /* Generate the loop body. */
4541 2521 : gfc_start_scalarized_body (ploop, &body);
4542 :
4543 : /* If we have a mask, only add this element if the mask is set. */
4544 2521 : if (maskexpr && maskexpr->rank > 0)
4545 : {
4546 307 : gfc_init_se (&maskse, parent_se);
4547 307 : gfc_copy_loopinfo_to_se (&maskse, ploop);
4548 307 : if (expr->rank == 0)
4549 223 : maskse.ss = maskss;
4550 307 : gfc_conv_expr_val (&maskse, maskexpr);
4551 307 : gfc_add_block_to_block (&body, &maskse.pre);
4552 :
4553 307 : gfc_start_block (&block);
4554 : }
4555 : else
4556 2214 : gfc_init_block (&block);
4557 :
4558 : /* Do the actual summation/product. */
4559 2521 : gfc_init_se (&arrayse, parent_se);
4560 2521 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
4561 2521 : if (expr->rank == 0)
4562 1943 : arrayse.ss = arrayss;
4563 2521 : gfc_conv_expr_val (&arrayse, arrayexpr);
4564 2521 : gfc_add_block_to_block (&block, &arrayse.pre);
4565 :
4566 2521 : if (norm2)
4567 : {
4568 : /* if (x (i) != 0.0)
4569 : {
4570 : absX = abs(x(i))
4571 : if (absX > scale)
4572 : {
4573 : val = scale/absX;
4574 : result = 1.0 + result * val * val;
4575 : scale = absX;
4576 : }
4577 : else
4578 : {
4579 : val = absX/scale;
4580 : result += val * val;
4581 : }
4582 : } */
4583 68 : tree res1, res2, cond, absX, val;
4584 68 : stmtblock_t ifblock1, ifblock2, ifblock3;
4585 :
4586 68 : gfc_init_block (&ifblock1);
4587 :
4588 68 : absX = gfc_create_var (type, "absX");
4589 68 : gfc_add_modify (&ifblock1, absX,
4590 : fold_build1_loc (input_location, ABS_EXPR, type,
4591 : arrayse.expr));
4592 68 : val = gfc_create_var (type, "val");
4593 68 : gfc_add_expr_to_block (&ifblock1, val);
4594 :
4595 68 : gfc_init_block (&ifblock2);
4596 68 : gfc_add_modify (&ifblock2, val,
4597 : fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4598 : absX));
4599 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4600 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4601 68 : res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4602 : gfc_build_const (type, integer_one_node));
4603 68 : gfc_add_modify (&ifblock2, resvar, res1);
4604 68 : gfc_add_modify (&ifblock2, scale, absX);
4605 68 : res1 = gfc_finish_block (&ifblock2);
4606 :
4607 68 : gfc_init_block (&ifblock3);
4608 68 : gfc_add_modify (&ifblock3, val,
4609 : fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4610 : scale));
4611 68 : res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4612 68 : res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4613 68 : gfc_add_modify (&ifblock3, resvar, res2);
4614 68 : res2 = gfc_finish_block (&ifblock3);
4615 :
4616 68 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4617 : absX, scale);
4618 68 : tmp = build3_v (COND_EXPR, cond, res1, res2);
4619 68 : gfc_add_expr_to_block (&ifblock1, tmp);
4620 68 : tmp = gfc_finish_block (&ifblock1);
4621 :
4622 68 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4623 : arrayse.expr,
4624 : gfc_build_const (type, integer_zero_node));
4625 :
4626 68 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4627 68 : gfc_add_expr_to_block (&block, tmp);
4628 : }
4629 : else
4630 : {
4631 2453 : tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4632 2453 : gfc_add_modify (&block, resvar, tmp);
4633 : }
4634 :
4635 2521 : gfc_add_block_to_block (&block, &arrayse.post);
4636 :
4637 2521 : if (maskexpr && maskexpr->rank > 0)
4638 : {
4639 : /* We enclose the above in if (mask) {...} . If the mask is an
4640 : optional argument, generate
4641 : IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4642 307 : tree ifmask;
4643 307 : tmp = gfc_finish_block (&block);
4644 307 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4645 307 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4646 : build_empty_stmt (input_location));
4647 307 : }
4648 : else
4649 2214 : tmp = gfc_finish_block (&block);
4650 2521 : gfc_add_expr_to_block (&body, tmp);
4651 :
4652 2521 : gfc_trans_scalarizing_loops (ploop, &body);
4653 :
4654 : /* For a scalar mask, enclose the loop in an if statement. */
4655 2521 : if (maskexpr && maskexpr->rank == 0)
4656 : {
4657 64 : gfc_init_block (&block);
4658 64 : gfc_add_block_to_block (&block, &ploop->pre);
4659 64 : gfc_add_block_to_block (&block, &ploop->post);
4660 64 : tmp = gfc_finish_block (&block);
4661 :
4662 64 : if (expr->rank > 0)
4663 : {
4664 34 : tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4665 : build_empty_stmt (input_location));
4666 34 : gfc_advance_se_ss_chain (se);
4667 : }
4668 : else
4669 : {
4670 30 : tree ifmask;
4671 :
4672 30 : gcc_assert (expr->rank == 0);
4673 30 : gfc_init_se (&maskse, NULL);
4674 30 : gfc_conv_expr_val (&maskse, maskexpr);
4675 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4676 30 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4677 : build_empty_stmt (input_location));
4678 : }
4679 :
4680 64 : gfc_add_expr_to_block (&block, tmp);
4681 64 : gfc_add_block_to_block (&se->pre, &block);
4682 64 : gcc_assert (se->post.head == NULL);
4683 : }
4684 : else
4685 : {
4686 2457 : gfc_add_block_to_block (&se->pre, &ploop->pre);
4687 2457 : gfc_add_block_to_block (&se->pre, &ploop->post);
4688 : }
4689 :
4690 2521 : if (expr->rank == 0)
4691 1943 : gfc_cleanup_loop (ploop);
4692 :
4693 2521 : if (norm2)
4694 : {
4695 : /* result = scale * sqrt(result). */
4696 68 : tree sqrt;
4697 68 : sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4698 68 : resvar = build_call_expr_loc (input_location,
4699 : sqrt, 1, resvar);
4700 68 : resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4701 : }
4702 :
4703 2521 : se->expr = resvar;
4704 2521 : }
4705 :
4706 :
4707 : /* Inline implementation of the dot_product intrinsic. This function
4708 : is based on gfc_conv_intrinsic_arith (the previous function). */
4709 : static void
4710 113 : gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4711 : {
4712 113 : tree resvar;
4713 113 : tree type;
4714 113 : stmtblock_t body;
4715 113 : stmtblock_t block;
4716 113 : tree tmp;
4717 113 : gfc_loopinfo loop;
4718 113 : gfc_actual_arglist *actual;
4719 113 : gfc_ss *arrayss1, *arrayss2;
4720 113 : gfc_se arrayse1, arrayse2;
4721 113 : gfc_expr *arrayexpr1, *arrayexpr2;
4722 :
4723 113 : type = gfc_typenode_for_spec (&expr->ts);
4724 :
4725 : /* Initialize the result. */
4726 113 : resvar = gfc_create_var (type, "val");
4727 113 : if (expr->ts.type == BT_LOGICAL)
4728 30 : tmp = build_int_cst (type, 0);
4729 : else
4730 83 : tmp = gfc_build_const (type, integer_zero_node);
4731 :
4732 113 : gfc_add_modify (&se->pre, resvar, tmp);
4733 :
4734 : /* Walk argument #1. */
4735 113 : actual = expr->value.function.actual;
4736 113 : arrayexpr1 = actual->expr;
4737 113 : arrayss1 = gfc_walk_expr (arrayexpr1);
4738 113 : gcc_assert (arrayss1 != gfc_ss_terminator);
4739 :
4740 : /* Walk argument #2. */
4741 113 : actual = actual->next;
4742 113 : arrayexpr2 = actual->expr;
4743 113 : arrayss2 = gfc_walk_expr (arrayexpr2);
4744 113 : gcc_assert (arrayss2 != gfc_ss_terminator);
4745 :
4746 : /* Initialize the scalarizer. */
4747 113 : gfc_init_loopinfo (&loop);
4748 113 : gfc_add_ss_to_loop (&loop, arrayss1);
4749 113 : gfc_add_ss_to_loop (&loop, arrayss2);
4750 :
4751 : /* Initialize the loop. */
4752 113 : gfc_conv_ss_startstride (&loop);
4753 113 : gfc_conv_loop_setup (&loop, &expr->where);
4754 :
4755 113 : gfc_mark_ss_chain_used (arrayss1, 1);
4756 113 : gfc_mark_ss_chain_used (arrayss2, 1);
4757 :
4758 : /* Generate the loop body. */
4759 113 : gfc_start_scalarized_body (&loop, &body);
4760 113 : gfc_init_block (&block);
4761 :
4762 : /* Make the tree expression for [conjg(]array1[)]. */
4763 113 : gfc_init_se (&arrayse1, NULL);
4764 113 : gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4765 113 : arrayse1.ss = arrayss1;
4766 113 : gfc_conv_expr_val (&arrayse1, arrayexpr1);
4767 113 : if (expr->ts.type == BT_COMPLEX)
4768 9 : arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4769 : arrayse1.expr);
4770 113 : gfc_add_block_to_block (&block, &arrayse1.pre);
4771 :
4772 : /* Make the tree expression for array2. */
4773 113 : gfc_init_se (&arrayse2, NULL);
4774 113 : gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4775 113 : arrayse2.ss = arrayss2;
4776 113 : gfc_conv_expr_val (&arrayse2, arrayexpr2);
4777 113 : gfc_add_block_to_block (&block, &arrayse2.pre);
4778 :
4779 : /* Do the actual product and sum. */
4780 113 : if (expr->ts.type == BT_LOGICAL)
4781 : {
4782 30 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4783 : arrayse1.expr, arrayse2.expr);
4784 30 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4785 : }
4786 : else
4787 : {
4788 83 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4789 : arrayse2.expr);
4790 83 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4791 : }
4792 113 : gfc_add_modify (&block, resvar, tmp);
4793 :
4794 : /* Finish up the loop block and the loop. */
4795 113 : tmp = gfc_finish_block (&block);
4796 113 : gfc_add_expr_to_block (&body, tmp);
4797 :
4798 113 : gfc_trans_scalarizing_loops (&loop, &body);
4799 113 : gfc_add_block_to_block (&se->pre, &loop.pre);
4800 113 : gfc_add_block_to_block (&se->pre, &loop.post);
4801 113 : gfc_cleanup_loop (&loop);
4802 :
4803 113 : se->expr = resvar;
4804 113 : }
4805 :
4806 :
4807 : /* Tells whether the expression E is a reference to an optional variable whose
4808 : presence is not known at compile time. Those are variable references without
4809 : subreference; if there is a subreference, we can assume the variable is
4810 : present. We have to special case full arrays, which we represent with a fake
4811 : "full" reference, and class descriptors for which a reference to data is not
4812 : really a subreference. */
4813 :
4814 : bool
4815 14613 : maybe_absent_optional_variable (gfc_expr *e)
4816 : {
4817 14613 : if (!(e && e->expr_type == EXPR_VARIABLE))
4818 : return false;
4819 :
4820 1716 : gfc_symbol *sym = e->symtree->n.sym;
4821 1716 : if (!sym->attr.optional)
4822 : return false;
4823 :
4824 224 : gfc_ref *ref = e->ref;
4825 224 : if (ref == nullptr)
4826 : return true;
4827 :
4828 20 : if (ref->type == REF_ARRAY
4829 20 : && ref->u.ar.type == AR_FULL
4830 20 : && ref->next == nullptr)
4831 : return true;
4832 :
4833 0 : if (!(sym->ts.type == BT_CLASS
4834 0 : && ref->type == REF_COMPONENT
4835 0 : && ref->u.c.component == CLASS_DATA (sym)))
4836 : return false;
4837 :
4838 0 : gfc_ref *next_ref = ref->next;
4839 0 : if (next_ref == nullptr)
4840 : return true;
4841 :
4842 0 : if (next_ref->type == REF_ARRAY
4843 0 : && next_ref->u.ar.type == AR_FULL
4844 0 : && next_ref->next == nullptr)
4845 0 : return true;
4846 :
4847 : return false;
4848 : }
4849 :
4850 :
4851 : /* Emit code for minloc or maxloc intrinsic. There are many different cases
4852 : we need to handle. For performance reasons we sometimes create two
4853 : loops instead of one, where the second one is much simpler.
4854 : Examples for minloc intrinsic:
4855 : A: Result is scalar.
4856 : 1) Array mask is used and NaNs need to be supported:
4857 : limit = Infinity;
4858 : pos = 0;
4859 : S = from;
4860 : while (S <= to) {
4861 : if (mask[S]) {
4862 : if (pos == 0) pos = S + (1 - from);
4863 : if (a[S] <= limit) {
4864 : limit = a[S];
4865 : pos = S + (1 - from);
4866 : goto lab1;
4867 : }
4868 : }
4869 : S++;
4870 : }
4871 : goto lab2;
4872 : lab1:;
4873 : while (S <= to) {
4874 : if (mask[S])
4875 : if (a[S] < limit) {
4876 : limit = a[S];
4877 : pos = S + (1 - from);
4878 : }
4879 : S++;
4880 : }
4881 : lab2:;
4882 : 2) NaNs need to be supported, but it is known at compile time or cheaply
4883 : at runtime whether array is nonempty or not:
4884 : limit = Infinity;
4885 : pos = 0;
4886 : S = from;
4887 : while (S <= to) {
4888 : if (a[S] <= limit) {
4889 : limit = a[S];
4890 : pos = S + (1 - from);
4891 : goto lab1;
4892 : }
4893 : S++;
4894 : }
4895 : if (from <= to) pos = 1;
4896 : goto lab2;
4897 : lab1:;
4898 : while (S <= to) {
4899 : if (a[S] < limit) {
4900 : limit = a[S];
4901 : pos = S + (1 - from);
4902 : }
4903 : S++;
4904 : }
4905 : lab2:;
4906 : 3) NaNs aren't supported, array mask is used:
4907 : limit = infinities_supported ? Infinity : huge (limit);
4908 : pos = 0;
4909 : S = from;
4910 : while (S <= to) {
4911 : if (mask[S]) {
4912 : limit = a[S];
4913 : pos = S + (1 - from);
4914 : goto lab1;
4915 : }
4916 : S++;
4917 : }
4918 : goto lab2;
4919 : lab1:;
4920 : while (S <= to) {
4921 : if (mask[S])
4922 : if (a[S] < limit) {
4923 : limit = a[S];
4924 : pos = S + (1 - from);
4925 : }
4926 : S++;
4927 : }
4928 : lab2:;
4929 : 4) Same without array mask:
4930 : limit = infinities_supported ? Infinity : huge (limit);
4931 : pos = (from <= to) ? 1 : 0;
4932 : S = from;
4933 : while (S <= to) {
4934 : if (a[S] < limit) {
4935 : limit = a[S];
4936 : pos = S + (1 - from);
4937 : }
4938 : S++;
4939 : }
4940 : B: Array result, non-CHARACTER type, DIM absent
4941 : Generate similar code as in the scalar case, using a collection of
4942 : variables (one per dimension) instead of a single variable as result.
4943 : Picking only cases 1) and 4) with ARRAY of rank 2, the generated code
4944 : becomes:
4945 : 1) Array mask is used and NaNs need to be supported:
4946 : limit = Infinity;
4947 : pos0 = 0;
4948 : pos1 = 0;
4949 : S1 = from1;
4950 : second_loop_entry = false;
4951 : while (S1 <= to1) {
4952 : S0 = from0;
4953 : while (s0 <= to0 {
4954 : if (mask[S1][S0]) {
4955 : if (pos0 == 0) {
4956 : pos0 = S0 + (1 - from0);
4957 : pos1 = S1 + (1 - from1);
4958 : }
4959 : if (a[S1][S0] <= limit) {
4960 : limit = a[S1][S0];
4961 : pos0 = S0 + (1 - from0);
4962 : pos1 = S1 + (1 - from1);
4963 : second_loop_entry = true;
4964 : goto lab1;
4965 : }
4966 : }
4967 : S0++;
4968 : }
4969 : S1++;
4970 : }
4971 : goto lab2;
4972 : lab1:;
4973 : S1 = second_loop_entry ? S1 : from1;
4974 : while (S1 <= to1) {
4975 : S0 = second_loop_entry ? S0 : from0;
4976 : while (S0 <= to0) {
4977 : if (mask[S1][S0])
4978 : if (a[S1][S0] < limit) {
4979 : limit = a[S1][S0];
4980 : pos0 = S + (1 - from0);
4981 : pos1 = S + (1 - from1);
4982 : }
4983 : second_loop_entry = false;
4984 : S0++;
4985 : }
4986 : S1++;
4987 : }
4988 : lab2:;
4989 : result = { pos0, pos1 };
4990 : ...
4991 : 4) NANs aren't supported, no array mask.
4992 : limit = infinities_supported ? Infinity : huge (limit);
4993 : pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4994 : pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4995 : S1 = from1;
4996 : while (S1 <= to1) {
4997 : S0 = from0;
4998 : while (S0 <= to0) {
4999 : if (a[S1][S0] < limit) {
5000 : limit = a[S1][S0];
5001 : pos0 = S + (1 - from0);
5002 : pos1 = S + (1 - from1);
5003 : }
5004 : S0++;
5005 : }
5006 : S1++;
5007 : }
5008 : result = { pos0, pos1 };
5009 : C: Otherwise, a call is generated.
5010 : For 2) and 4), if mask is scalar, this all goes into a conditional,
5011 : setting pos = 0; in the else branch.
5012 :
5013 : Since we now also support the BACK argument, instead of using
5014 : if (a[S] < limit), we now use
5015 :
5016 : if (back)
5017 : cond = a[S] <= limit;
5018 : else
5019 : cond = a[S] < limit;
5020 : if (cond) {
5021 : ....
5022 :
5023 : The optimizer is smart enough to move the condition out of the loop.
5024 : They are now marked as unlikely too for further speedup. */
5025 :
5026 : static void
5027 18898 : gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5028 : {
5029 18898 : stmtblock_t body;
5030 18898 : stmtblock_t block;
5031 18898 : stmtblock_t ifblock;
5032 18898 : stmtblock_t elseblock;
5033 18898 : tree limit;
5034 18898 : tree type;
5035 18898 : tree tmp;
5036 18898 : tree cond;
5037 18898 : tree elsetmp;
5038 18898 : tree ifbody;
5039 18898 : tree offset[GFC_MAX_DIMENSIONS];
5040 18898 : tree nonempty;
5041 18898 : tree lab1, lab2;
5042 18898 : tree b_if, b_else;
5043 18898 : tree back;
5044 18898 : gfc_loopinfo loop, *ploop;
5045 18898 : gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg;
5046 18898 : gfc_actual_arglist *back_arg;
5047 18898 : gfc_ss *arrayss = nullptr;
5048 18898 : gfc_ss *maskss = nullptr;
5049 18898 : gfc_ss *orig_ss = nullptr;
5050 18898 : gfc_se arrayse;
5051 18898 : gfc_se maskse;
5052 18898 : gfc_se nested_se;
5053 18898 : gfc_se *base_se;
5054 18898 : gfc_expr *arrayexpr;
5055 18898 : gfc_expr *maskexpr;
5056 18898 : gfc_expr *backexpr;
5057 18898 : gfc_se backse;
5058 18898 : tree pos[GFC_MAX_DIMENSIONS];
5059 18898 : tree idx[GFC_MAX_DIMENSIONS];
5060 18898 : tree result_var = NULL_TREE;
5061 18898 : int n;
5062 18898 : bool optional_mask;
5063 :
5064 18898 : array_arg = expr->value.function.actual;
5065 18898 : dim_arg = array_arg->next;
5066 18898 : mask_arg = dim_arg->next;
5067 18898 : kind_arg = mask_arg->next;
5068 18898 : back_arg = kind_arg->next;
5069 :
5070 18898 : bool dim_present = dim_arg->expr != nullptr;
5071 18898 : bool nested_loop = dim_present && expr->rank > 0;
5072 :
5073 : /* Remove kind. */
5074 18898 : if (kind_arg->expr)
5075 : {
5076 2240 : gfc_free_expr (kind_arg->expr);
5077 2240 : kind_arg->expr = NULL;
5078 : }
5079 :
5080 : /* Pass BACK argument by value. */
5081 18898 : back_arg->name = "%VAL";
5082 :
5083 18898 : if (se->ss)
5084 : {
5085 14732 : if (se->ss->info->useflags)
5086 : {
5087 7671 : if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
5088 : {
5089 : /* The code generating and initializing the result array has been
5090 : generated already before the scalarization loop, either with a
5091 : library function call or with inline code; now we can just use
5092 : the result. */
5093 4875 : gfc_conv_tmp_array_ref (se);
5094 13822 : return;
5095 : }
5096 : }
5097 7061 : else if (!gfc_inline_intrinsic_function_p (expr))
5098 : {
5099 3780 : gfc_conv_intrinsic_funcall (se, expr);
5100 3780 : return;
5101 : }
5102 : }
5103 :
5104 10243 : arrayexpr = array_arg->expr;
5105 :
5106 : /* Special case for character maxloc. Remove unneeded "dim" actual
5107 : argument, then call a library function. */
5108 :
5109 10243 : if (arrayexpr->ts.type == BT_CHARACTER)
5110 : {
5111 292 : gcc_assert (expr->rank == 0);
5112 :
5113 292 : if (dim_arg->expr)
5114 : {
5115 292 : gfc_free_expr (dim_arg->expr);
5116 292 : dim_arg->expr = NULL;
5117 : }
5118 292 : gfc_conv_intrinsic_funcall (se, expr);
5119 292 : return;
5120 : }
5121 :
5122 9951 : type = gfc_typenode_for_spec (&expr->ts);
5123 :
5124 9951 : if (expr->rank > 0 && !dim_present)
5125 : {
5126 3281 : gfc_array_spec as;
5127 3281 : memset (&as, 0, sizeof (as));
5128 :
5129 3281 : as.rank = 1;
5130 3281 : as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5131 : &arrayexpr->where,
5132 : HOST_WIDE_INT_1);
5133 6562 : as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind,
5134 : &arrayexpr->where,
5135 3281 : arrayexpr->rank);
5136 :
5137 3281 : tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
5138 :
5139 3281 : result_var = gfc_create_var (array, "loc_result");
5140 : }
5141 :
5142 7155 : const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
5143 :
5144 : /* Initialize the result. */
5145 22177 : for (int i = 0; i < reduction_dimensions; i++)
5146 : {
5147 12226 : pos[i] = gfc_create_var (gfc_array_index_type,
5148 : gfc_get_string ("pos%d", i));
5149 12226 : offset[i] = gfc_create_var (gfc_array_index_type,
5150 : gfc_get_string ("offset%d", i));
5151 12226 : idx[i] = gfc_create_var (gfc_array_index_type,
5152 : gfc_get_string ("idx%d", i));
5153 : }
5154 :
5155 9951 : maskexpr = mask_arg->expr;
5156 6518 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5157 5329 : && maskexpr->symtree->n.sym->attr.dummy
5158 10116 : && maskexpr->symtree->n.sym->attr.optional;
5159 9951 : backexpr = back_arg->expr;
5160 :
5161 17106 : gfc_init_se (&backse, nested_loop ? se : nullptr);
5162 9951 : if (backexpr == nullptr)
5163 0 : back = logical_false_node;
5164 9951 : else if (maybe_absent_optional_variable (backexpr))
5165 : {
5166 : /* This should have been checked already by
5167 : maybe_absent_optional_variable. */
5168 184 : gcc_checking_assert (backexpr->expr_type == EXPR_VARIABLE);
5169 :
5170 184 : gfc_conv_expr (&backse, backexpr);
5171 184 : tree present = gfc_conv_expr_present (backexpr->symtree->n.sym, false);
5172 184 : back = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5173 : logical_type_node, present, backse.expr);
5174 : }
5175 : else
5176 : {
5177 9767 : gfc_conv_expr (&backse, backexpr);
5178 9767 : back = backse.expr;
5179 : }
5180 9951 : gfc_add_block_to_block (&se->pre, &backse.pre);
5181 9951 : back = gfc_evaluate_now_loc (input_location, back, &se->pre);
5182 9951 : gfc_add_block_to_block (&se->pre, &backse.post);
5183 :
5184 9951 : if (nested_loop)
5185 : {
5186 2796 : gfc_init_se (&nested_se, se);
5187 2796 : base_se = &nested_se;
5188 : }
5189 : else
5190 : {
5191 : /* Walk the arguments. */
5192 7155 : arrayss = gfc_walk_expr (arrayexpr);
5193 7155 : gcc_assert (arrayss != gfc_ss_terminator);
5194 :
5195 7155 : if (maskexpr && maskexpr->rank != 0)
5196 : {
5197 2700 : maskss = gfc_walk_expr (maskexpr);
5198 2700 : gcc_assert (maskss != gfc_ss_terminator);
5199 : }
5200 :
5201 : base_se = nullptr;
5202 : }
5203 :
5204 18091 : nonempty = nullptr;
5205 7448 : if (!(maskexpr && maskexpr->rank > 0))
5206 : {
5207 6077 : mpz_t asize;
5208 6077 : bool reduction_size_known;
5209 :
5210 6077 : if (dim_present)
5211 : {
5212 4032 : int reduction_dim;
5213 4032 : if (dim_arg->expr->expr_type == EXPR_CONSTANT)
5214 4030 : reduction_dim = mpz_get_si (dim_arg->expr->value.integer) - 1;
5215 2 : else if (arrayexpr->rank == 1)
5216 : reduction_dim = 0;
5217 : else
5218 0 : gcc_unreachable ();
5219 4032 : reduction_size_known = gfc_array_dimen_size (arrayexpr, reduction_dim,
5220 : &asize);
5221 : }
5222 : else
5223 2045 : reduction_size_known = gfc_array_size (arrayexpr, &asize);
5224 :
5225 6077 : if (reduction_size_known)
5226 : {
5227 4482 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5228 4482 : mpz_clear (asize);
5229 4482 : nonempty = fold_build2_loc (input_location, GT_EXPR,
5230 : logical_type_node, nonempty,
5231 : gfc_index_zero_node);
5232 : }
5233 6077 : maskss = NULL;
5234 : }
5235 :
5236 9951 : limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5237 9951 : switch (arrayexpr->ts.type)
5238 : {
5239 3898 : case BT_REAL:
5240 3898 : tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5241 3898 : break;
5242 :
5243 6029 : case BT_INTEGER:
5244 6029 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5245 6029 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5246 : arrayexpr->ts.kind);
5247 6029 : break;
5248 :
5249 24 : case BT_UNSIGNED:
5250 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
5251 24 : if (op == GT_EXPR)
5252 : {
5253 12 : tmp = gfc_get_unsigned_type (arrayexpr->ts.kind);
5254 12 : tmp = build_int_cst (tmp, 0);
5255 : }
5256 : else
5257 : {
5258 12 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5259 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
5260 : expr->ts.kind);
5261 : }
5262 : break;
5263 :
5264 0 : default:
5265 0 : gcc_unreachable ();
5266 : }
5267 :
5268 : /* We start with the most negative possible value for MAXLOC, and the most
5269 : positive possible value for MINLOC. The most negative possible value is
5270 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5271 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
5272 : with above. */
5273 9951 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
5274 4724 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5275 4724 : if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5276 2914 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5277 2914 : build_int_cst (TREE_TYPE (tmp), 1));
5278 :
5279 9951 : gfc_add_modify (&se->pre, limit, tmp);
5280 :
5281 : /* If we are in a case where we generate two sets of loops, the second one
5282 : should continue where the first stopped instead of restarting from the
5283 : beginning. So nested loops in the second set should have a partial range
5284 : on the first iteration, but they should start from the beginning and span
5285 : their full range on the following iterations. So we use conditionals in
5286 : the loops lower bounds, and use the following variable in those
5287 : conditionals to decide whether to use the original loop bound or to use
5288 : the index at which the loop from the first set stopped. */
5289 9951 : tree second_loop_entry = gfc_create_var (logical_type_node,
5290 : "second_loop_entry");
5291 9951 : gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
5292 :
5293 9951 : if (nested_loop)
5294 : {
5295 2796 : ploop = enter_nested_loop (&nested_se);
5296 2796 : orig_ss = nested_se.ss;
5297 2796 : ploop->temp_dim = 1;
5298 : }
5299 : else
5300 : {
5301 : /* Initialize the scalarizer. */
5302 7155 : gfc_init_loopinfo (&loop);
5303 :
5304 : /* We add the mask first because the number of iterations is taken
5305 : from the last ss, and this breaks if an absent optional argument
5306 : is used for mask. */
5307 :
5308 7155 : if (maskss)
5309 2700 : gfc_add_ss_to_loop (&loop, maskss);
5310 :
5311 7155 : gfc_add_ss_to_loop (&loop, arrayss);
5312 :
5313 : /* Initialize the loop. */
5314 7155 : gfc_conv_ss_startstride (&loop);
5315 :
5316 : /* The code generated can have more than one loop in sequence (see the
5317 : comment at the function header). This doesn't work well with the
5318 : scalarizer, which changes arrays' offset when the scalarization loops
5319 : are generated (see gfc_trans_preloop_setup). Fortunately, we can use
5320 : the scalarizer temporary code to handle multiple loops. Thus, we set
5321 : temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
5322 : we use gfc_trans_scalarized_loop_boundary even later to restore
5323 : offset. */
5324 7155 : loop.temp_dim = loop.dimen;
5325 7155 : gfc_conv_loop_setup (&loop, &expr->where);
5326 :
5327 7155 : ploop = &loop;
5328 : }
5329 :
5330 9951 : gcc_assert (reduction_dimensions == ploop->dimen);
5331 :
5332 9951 : if (nonempty == NULL && !(maskexpr && maskexpr->rank > 0))
5333 : {
5334 1595 : nonempty = logical_true_node;
5335 :
5336 3697 : for (int i = 0; i < ploop->dimen; i++)
5337 : {
5338 2102 : if (!(ploop->from[i] && ploop->to[i]))
5339 : {
5340 : nonempty = NULL;
5341 : break;
5342 : }
5343 :
5344 2102 : tree tmp = fold_build2_loc (input_location, LE_EXPR,
5345 : logical_type_node, ploop->from[i],
5346 : ploop->to[i]);
5347 :
5348 2102 : nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5349 : logical_type_node, nonempty, tmp);
5350 : }
5351 : }
5352 :
5353 11546 : lab1 = NULL;
5354 11546 : lab2 = NULL;
5355 : /* Initialize the position to zero, following Fortran 2003. We are free
5356 : to do this because Fortran 95 allows the result of an entirely false
5357 : mask to be processor dependent. If we know at compile time the array
5358 : is non-empty and no MASK is used, we can initialize to 1 to simplify
5359 : the inner loop. */
5360 9951 : if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5361 : {
5362 3748 : tree init = fold_build3_loc (input_location, COND_EXPR,
5363 : gfc_array_index_type, nonempty,
5364 : gfc_index_one_node,
5365 : gfc_index_zero_node);
5366 12178 : for (int i = 0; i < ploop->dimen; i++)
5367 4682 : gfc_add_modify (&ploop->pre, pos[i], init);
5368 : }
5369 : else
5370 : {
5371 13747 : for (int i = 0; i < ploop->dimen; i++)
5372 7544 : gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node);
5373 6203 : lab1 = gfc_build_label_decl (NULL_TREE);
5374 6203 : TREE_USED (lab1) = 1;
5375 6203 : lab2 = gfc_build_label_decl (NULL_TREE);
5376 6203 : TREE_USED (lab2) = 1;
5377 : }
5378 :
5379 : /* An offset must be added to the loop
5380 : counter to obtain the required position. */
5381 22177 : for (int i = 0; i < ploop->dimen; i++)
5382 : {
5383 12226 : gcc_assert (ploop->from[i]);
5384 :
5385 12226 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5386 : gfc_index_one_node, ploop->from[i]);
5387 12226 : gfc_add_modify (&ploop->pre, offset[i], tmp);
5388 : }
5389 :
5390 9951 : if (!nested_loop)
5391 : {
5392 9965 : gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5393 7155 : if (maskss)
5394 2700 : gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5395 : }
5396 :
5397 : /* Generate the loop body. */
5398 9951 : gfc_start_scalarized_body (ploop, &body);
5399 :
5400 : /* If we have a mask, only check this element if the mask is set. */
5401 9951 : if (maskexpr && maskexpr->rank > 0)
5402 : {
5403 3874 : gfc_init_se (&maskse, base_se);
5404 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5405 3874 : if (!nested_loop)
5406 2700 : maskse.ss = maskss;
5407 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5408 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5409 :
5410 3874 : gfc_start_block (&block);
5411 : }
5412 : else
5413 6077 : gfc_init_block (&block);
5414 :
5415 : /* Compare with the current limit. */
5416 9951 : gfc_init_se (&arrayse, base_se);
5417 9951 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5418 9951 : if (!nested_loop)
5419 7155 : arrayse.ss = arrayss;
5420 9951 : gfc_conv_expr_val (&arrayse, arrayexpr);
5421 9951 : gfc_add_block_to_block (&block, &arrayse.pre);
5422 :
5423 : /* We do the following if this is a more extreme value. */
5424 9951 : gfc_start_block (&ifblock);
5425 :
5426 : /* Assign the value to the limit... */
5427 9951 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5428 :
5429 9951 : if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5430 : {
5431 1569 : stmtblock_t ifblock2;
5432 1569 : tree ifbody2;
5433 :
5434 1569 : gfc_start_block (&ifblock2);
5435 5008 : for (int i = 0; i < ploop->dimen; i++)
5436 : {
5437 1870 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5438 : ploop->loopvar[i], offset[i]);
5439 1870 : gfc_add_modify (&ifblock2, pos[i], tmp);
5440 : }
5441 1569 : ifbody2 = gfc_finish_block (&ifblock2);
5442 :
5443 1569 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5444 : pos[0], gfc_index_zero_node);
5445 1569 : tmp = build3_v (COND_EXPR, cond, ifbody2,
5446 : build_empty_stmt (input_location));
5447 1569 : gfc_add_expr_to_block (&block, tmp);
5448 : }
5449 :
5450 22177 : for (int i = 0; i < ploop->dimen; i++)
5451 : {
5452 12226 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5453 : ploop->loopvar[i], offset[i]);
5454 12226 : gfc_add_modify (&ifblock, pos[i], tmp);
5455 12226 : gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
5456 : }
5457 :
5458 9951 : gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
5459 :
5460 9951 : if (lab1)
5461 6203 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5462 :
5463 9951 : ifbody = gfc_finish_block (&ifblock);
5464 :
5465 9951 : if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5466 : {
5467 7646 : if (lab1)
5468 5998 : cond = fold_build2_loc (input_location,
5469 : op == GT_EXPR ? GE_EXPR : LE_EXPR,
5470 : logical_type_node, arrayse.expr, limit);
5471 : else
5472 : {
5473 3748 : tree ifbody2, elsebody2;
5474 :
5475 : /* We switch to > or >= depending on the value of the BACK argument. */
5476 3748 : cond = gfc_create_var (logical_type_node, "cond");
5477 :
5478 3748 : gfc_start_block (&ifblock);
5479 5641 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5480 : logical_type_node, arrayse.expr, limit);
5481 :
5482 3748 : gfc_add_modify (&ifblock, cond, b_if);
5483 3748 : ifbody2 = gfc_finish_block (&ifblock);
5484 :
5485 3748 : gfc_start_block (&elseblock);
5486 3748 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5487 : arrayse.expr, limit);
5488 :
5489 3748 : gfc_add_modify (&elseblock, cond, b_else);
5490 3748 : elsebody2 = gfc_finish_block (&elseblock);
5491 :
5492 3748 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5493 : back, ifbody2, elsebody2);
5494 :
5495 3748 : gfc_add_expr_to_block (&block, tmp);
5496 : }
5497 :
5498 7646 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5499 7646 : ifbody = build3_v (COND_EXPR, cond, ifbody,
5500 : build_empty_stmt (input_location));
5501 : }
5502 9951 : gfc_add_expr_to_block (&block, ifbody);
5503 :
5504 9951 : if (maskexpr && maskexpr->rank > 0)
5505 : {
5506 : /* We enclose the above in if (mask) {...}. If the mask is an
5507 : optional argument, generate IF (.NOT. PRESENT(MASK)
5508 : .OR. MASK(I)). */
5509 :
5510 3874 : tree ifmask;
5511 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5512 3874 : tmp = gfc_finish_block (&block);
5513 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5514 : build_empty_stmt (input_location));
5515 3874 : }
5516 : else
5517 6077 : tmp = gfc_finish_block (&block);
5518 9951 : gfc_add_expr_to_block (&body, tmp);
5519 :
5520 9951 : if (lab1)
5521 : {
5522 13747 : for (int i = 0; i < ploop->dimen; i++)
5523 7544 : ploop->from[i] = fold_build3_loc (input_location, COND_EXPR,
5524 7544 : TREE_TYPE (ploop->from[i]),
5525 : second_loop_entry, idx[i],
5526 : ploop->from[i]);
5527 :
5528 6203 : gfc_trans_scalarized_loop_boundary (ploop, &body);
5529 :
5530 6203 : if (nested_loop)
5531 : {
5532 : /* The first loop already advanced the parent se'ss chain, so clear
5533 : the parent now to avoid doing it a second time, making the chain
5534 : out of sync. */
5535 1858 : nested_se.parent = nullptr;
5536 1858 : nested_se.ss = orig_ss;
5537 : }
5538 :
5539 6203 : stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1];
5540 :
5541 6203 : if (HONOR_NANS (DECL_MODE (limit)))
5542 : {
5543 3898 : if (nonempty != NULL)
5544 : {
5545 2329 : stmtblock_t init_block;
5546 2329 : gfc_init_block (&init_block);
5547 :
5548 7558 : for (int i = 0; i < ploop->dimen; i++)
5549 2900 : gfc_add_modify (&init_block, pos[i], gfc_index_one_node);
5550 :
5551 2329 : tree ifbody = gfc_finish_block (&init_block);
5552 2329 : tmp = build3_v (COND_EXPR, nonempty, ifbody,
5553 : build_empty_stmt (input_location));
5554 2329 : gfc_add_expr_to_block (outer_block, tmp);
5555 : }
5556 : }
5557 :
5558 6203 : gfc_add_expr_to_block (outer_block, build1_v (GOTO_EXPR, lab2));
5559 6203 : gfc_add_expr_to_block (outer_block, build1_v (LABEL_EXPR, lab1));
5560 :
5561 : /* If we have a mask, only check this element if the mask is set. */
5562 6203 : if (maskexpr && maskexpr->rank > 0)
5563 : {
5564 3874 : gfc_init_se (&maskse, base_se);
5565 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5566 3874 : if (!nested_loop)
5567 2700 : maskse.ss = maskss;
5568 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5569 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5570 :
5571 3874 : gfc_start_block (&block);
5572 : }
5573 : else
5574 2329 : gfc_init_block (&block);
5575 :
5576 : /* Compare with the current limit. */
5577 6203 : gfc_init_se (&arrayse, base_se);
5578 6203 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5579 6203 : if (!nested_loop)
5580 4345 : arrayse.ss = arrayss;
5581 6203 : gfc_conv_expr_val (&arrayse, arrayexpr);
5582 6203 : gfc_add_block_to_block (&block, &arrayse.pre);
5583 :
5584 : /* We do the following if this is a more extreme value. */
5585 6203 : gfc_start_block (&ifblock);
5586 :
5587 : /* Assign the value to the limit... */
5588 6203 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5589 :
5590 19950 : for (int i = 0; i < ploop->dimen; i++)
5591 : {
5592 7544 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5593 : ploop->loopvar[i], offset[i]);
5594 7544 : gfc_add_modify (&ifblock, pos[i], tmp);
5595 : }
5596 :
5597 6203 : ifbody = gfc_finish_block (&ifblock);
5598 :
5599 : /* We switch to > or >= depending on the value of the BACK argument. */
5600 6203 : {
5601 6203 : tree ifbody2, elsebody2;
5602 :
5603 6203 : cond = gfc_create_var (logical_type_node, "cond");
5604 :
5605 6203 : gfc_start_block (&ifblock);
5606 9537 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5607 : logical_type_node, arrayse.expr, limit);
5608 :
5609 6203 : gfc_add_modify (&ifblock, cond, b_if);
5610 6203 : ifbody2 = gfc_finish_block (&ifblock);
5611 :
5612 6203 : gfc_start_block (&elseblock);
5613 6203 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5614 : arrayse.expr, limit);
5615 :
5616 6203 : gfc_add_modify (&elseblock, cond, b_else);
5617 6203 : elsebody2 = gfc_finish_block (&elseblock);
5618 :
5619 6203 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5620 : back, ifbody2, elsebody2);
5621 : }
5622 :
5623 6203 : gfc_add_expr_to_block (&block, tmp);
5624 6203 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5625 6203 : tmp = build3_v (COND_EXPR, cond, ifbody,
5626 : build_empty_stmt (input_location));
5627 :
5628 6203 : gfc_add_expr_to_block (&block, tmp);
5629 :
5630 6203 : if (maskexpr && maskexpr->rank > 0)
5631 : {
5632 : /* We enclose the above in if (mask) {...}. If the mask is
5633 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5634 : .OR. MASK(I)).*/
5635 :
5636 3874 : tree ifmask;
5637 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5638 3874 : tmp = gfc_finish_block (&block);
5639 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5640 : build_empty_stmt (input_location));
5641 3874 : }
5642 : else
5643 2329 : tmp = gfc_finish_block (&block);
5644 :
5645 6203 : gfc_add_expr_to_block (&body, tmp);
5646 6203 : gfc_add_modify (&body, second_loop_entry, logical_false_node);
5647 : }
5648 :
5649 9951 : gfc_trans_scalarizing_loops (ploop, &body);
5650 :
5651 9951 : if (lab2)
5652 6203 : gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2));
5653 :
5654 : /* For a scalar mask, enclose the loop in an if statement. */
5655 9951 : if (maskexpr && maskexpr->rank == 0)
5656 : {
5657 2644 : tree ifmask;
5658 :
5659 2644 : gfc_init_se (&maskse, nested_loop ? se : nullptr);
5660 2644 : gfc_conv_expr_val (&maskse, maskexpr);
5661 2644 : gfc_add_block_to_block (&se->pre, &maskse.pre);
5662 2644 : gfc_init_block (&block);
5663 2644 : gfc_add_block_to_block (&block, &ploop->pre);
5664 2644 : gfc_add_block_to_block (&block, &ploop->post);
5665 2644 : tmp = gfc_finish_block (&block);
5666 :
5667 : /* For the else part of the scalar mask, just initialize
5668 : the pos variable the same way as above. */
5669 :
5670 2644 : gfc_init_block (&elseblock);
5671 8224 : for (int i = 0; i < ploop->dimen; i++)
5672 2936 : gfc_add_modify (&elseblock, pos[i], gfc_index_zero_node);
5673 2644 : elsetmp = gfc_finish_block (&elseblock);
5674 2644 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5675 2644 : tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5676 2644 : gfc_add_expr_to_block (&block, tmp);
5677 2644 : gfc_add_block_to_block (&se->pre, &block);
5678 2644 : }
5679 : else
5680 : {
5681 7307 : gfc_add_block_to_block (&se->pre, &ploop->pre);
5682 7307 : gfc_add_block_to_block (&se->pre, &ploop->post);
5683 : }
5684 :
5685 9951 : if (!nested_loop)
5686 7155 : gfc_cleanup_loop (&loop);
5687 :
5688 9951 : if (!dim_present)
5689 : {
5690 8837 : for (int i = 0; i < arrayexpr->rank; i++)
5691 : {
5692 5556 : tree res_idx = build_int_cst (gfc_array_index_type, i);
5693 5556 : tree res_arr_ref = gfc_build_array_ref (result_var, res_idx,
5694 : NULL_TREE, true);
5695 :
5696 5556 : tree value = convert (type, pos[i]);
5697 5556 : gfc_add_modify (&se->pre, res_arr_ref, value);
5698 : }
5699 :
5700 3281 : se->expr = result_var;
5701 : }
5702 : else
5703 6670 : se->expr = convert (type, pos[0]);
5704 : }
5705 :
5706 : /* Emit code for findloc. */
5707 :
5708 : static void
5709 1332 : gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5710 : {
5711 1332 : gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5712 : *kind_arg, *back_arg;
5713 1332 : gfc_expr *value_expr;
5714 1332 : int ikind;
5715 1332 : tree resvar;
5716 1332 : stmtblock_t block;
5717 1332 : stmtblock_t body;
5718 1332 : stmtblock_t loopblock;
5719 1332 : tree type;
5720 1332 : tree tmp;
5721 1332 : tree found;
5722 1332 : tree forward_branch = NULL_TREE;
5723 1332 : tree back_branch;
5724 1332 : gfc_loopinfo loop;
5725 1332 : gfc_ss *arrayss;
5726 1332 : gfc_ss *maskss;
5727 1332 : gfc_se arrayse;
5728 1332 : gfc_se valuese;
5729 1332 : gfc_se maskse;
5730 1332 : gfc_se backse;
5731 1332 : tree exit_label;
5732 1332 : gfc_expr *maskexpr;
5733 1332 : tree offset;
5734 1332 : int i;
5735 1332 : bool optional_mask;
5736 :
5737 1332 : array_arg = expr->value.function.actual;
5738 1332 : value_arg = array_arg->next;
5739 1332 : dim_arg = value_arg->next;
5740 1332 : mask_arg = dim_arg->next;
5741 1332 : kind_arg = mask_arg->next;
5742 1332 : back_arg = kind_arg->next;
5743 :
5744 : /* Remove kind and set ikind. */
5745 1332 : if (kind_arg->expr)
5746 : {
5747 0 : ikind = mpz_get_si (kind_arg->expr->value.integer);
5748 0 : gfc_free_expr (kind_arg->expr);
5749 0 : kind_arg->expr = NULL;
5750 : }
5751 : else
5752 1332 : ikind = gfc_default_integer_kind;
5753 :
5754 1332 : value_expr = value_arg->expr;
5755 :
5756 : /* Unless it's a string, pass VALUE by value. */
5757 1332 : if (value_expr->ts.type != BT_CHARACTER)
5758 732 : value_arg->name = "%VAL";
5759 :
5760 : /* Pass BACK argument by value. */
5761 1332 : back_arg->name = "%VAL";
5762 :
5763 : /* Call the library if we have a character function or if
5764 : rank > 0. */
5765 1332 : if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5766 : {
5767 1200 : se->ignore_optional = 1;
5768 1200 : if (expr->rank == 0)
5769 : {
5770 : /* Remove dim argument. */
5771 84 : gfc_free_expr (dim_arg->expr);
5772 84 : dim_arg->expr = NULL;
5773 : }
5774 1200 : gfc_conv_intrinsic_funcall (se, expr);
5775 1200 : return;
5776 : }
5777 :
5778 132 : type = gfc_get_int_type (ikind);
5779 :
5780 : /* Initialize the result. */
5781 132 : resvar = gfc_create_var (gfc_array_index_type, "pos");
5782 132 : gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5783 132 : offset = gfc_create_var (gfc_array_index_type, "offset");
5784 :
5785 132 : maskexpr = mask_arg->expr;
5786 72 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5787 60 : && maskexpr->symtree->n.sym->attr.dummy
5788 144 : && maskexpr->symtree->n.sym->attr.optional;
5789 :
5790 : /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5791 :
5792 396 : for (i = 0 ; i < 2; i++)
5793 : {
5794 : /* Walk the arguments. */
5795 264 : arrayss = gfc_walk_expr (array_arg->expr);
5796 264 : gcc_assert (arrayss != gfc_ss_terminator);
5797 :
5798 264 : if (maskexpr && maskexpr->rank != 0)
5799 : {
5800 84 : maskss = gfc_walk_expr (maskexpr);
5801 84 : gcc_assert (maskss != gfc_ss_terminator);
5802 : }
5803 : else
5804 : maskss = NULL;
5805 :
5806 : /* Initialize the scalarizer. */
5807 264 : gfc_init_loopinfo (&loop);
5808 264 : exit_label = gfc_build_label_decl (NULL_TREE);
5809 264 : TREE_USED (exit_label) = 1;
5810 :
5811 : /* We add the mask first because the number of iterations is
5812 : taken from the last ss, and this breaks if an absent
5813 : optional argument is used for mask. */
5814 :
5815 264 : if (maskss)
5816 84 : gfc_add_ss_to_loop (&loop, maskss);
5817 264 : gfc_add_ss_to_loop (&loop, arrayss);
5818 :
5819 : /* Initialize the loop. */
5820 264 : gfc_conv_ss_startstride (&loop);
5821 264 : gfc_conv_loop_setup (&loop, &expr->where);
5822 :
5823 : /* Calculate the offset. */
5824 264 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5825 : gfc_index_one_node, loop.from[0]);
5826 264 : gfc_add_modify (&loop.pre, offset, tmp);
5827 :
5828 264 : gfc_mark_ss_chain_used (arrayss, 1);
5829 264 : if (maskss)
5830 84 : gfc_mark_ss_chain_used (maskss, 1);
5831 :
5832 : /* The first loop is for BACK=.true. */
5833 264 : if (i == 0)
5834 132 : loop.reverse[0] = GFC_REVERSE_SET;
5835 :
5836 : /* Generate the loop body. */
5837 264 : gfc_start_scalarized_body (&loop, &body);
5838 :
5839 : /* If we have an array mask, only add the element if it is
5840 : set. */
5841 264 : if (maskss)
5842 : {
5843 84 : gfc_init_se (&maskse, NULL);
5844 84 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5845 84 : maskse.ss = maskss;
5846 84 : gfc_conv_expr_val (&maskse, maskexpr);
5847 84 : gfc_add_block_to_block (&body, &maskse.pre);
5848 : }
5849 :
5850 : /* If the condition matches then set the return value. */
5851 264 : gfc_start_block (&block);
5852 :
5853 : /* Add the offset. */
5854 264 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5855 264 : TREE_TYPE (resvar),
5856 : loop.loopvar[0], offset);
5857 264 : gfc_add_modify (&block, resvar, tmp);
5858 : /* And break out of the loop. */
5859 264 : tmp = build1_v (GOTO_EXPR, exit_label);
5860 264 : gfc_add_expr_to_block (&block, tmp);
5861 :
5862 264 : found = gfc_finish_block (&block);
5863 :
5864 : /* Check this element. */
5865 264 : gfc_init_se (&arrayse, NULL);
5866 264 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5867 264 : arrayse.ss = arrayss;
5868 264 : gfc_conv_expr_val (&arrayse, array_arg->expr);
5869 264 : gfc_add_block_to_block (&body, &arrayse.pre);
5870 :
5871 264 : gfc_init_se (&valuese, NULL);
5872 264 : gfc_conv_expr_val (&valuese, value_arg->expr);
5873 264 : gfc_add_block_to_block (&body, &valuese.pre);
5874 :
5875 264 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5876 : arrayse.expr, valuese.expr);
5877 :
5878 264 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5879 264 : if (maskss)
5880 : {
5881 : /* We enclose the above in if (mask) {...}. If the mask is
5882 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5883 : .OR. MASK(I)). */
5884 :
5885 84 : tree ifmask;
5886 84 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5887 84 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5888 : build_empty_stmt (input_location));
5889 : }
5890 :
5891 264 : gfc_add_expr_to_block (&body, tmp);
5892 264 : gfc_add_block_to_block (&body, &arrayse.post);
5893 :
5894 264 : gfc_trans_scalarizing_loops (&loop, &body);
5895 :
5896 : /* Add the exit label. */
5897 264 : tmp = build1_v (LABEL_EXPR, exit_label);
5898 264 : gfc_add_expr_to_block (&loop.pre, tmp);
5899 264 : gfc_start_block (&loopblock);
5900 264 : gfc_add_block_to_block (&loopblock, &loop.pre);
5901 264 : gfc_add_block_to_block (&loopblock, &loop.post);
5902 264 : if (i == 0)
5903 132 : forward_branch = gfc_finish_block (&loopblock);
5904 : else
5905 132 : back_branch = gfc_finish_block (&loopblock);
5906 :
5907 264 : gfc_cleanup_loop (&loop);
5908 : }
5909 :
5910 : /* Enclose the two loops in an IF statement. */
5911 :
5912 132 : gfc_init_se (&backse, NULL);
5913 132 : gfc_conv_expr_val (&backse, back_arg->expr);
5914 132 : gfc_add_block_to_block (&se->pre, &backse.pre);
5915 132 : tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5916 :
5917 : /* For a scalar mask, enclose the loop in an if statement. */
5918 132 : if (maskexpr && maskss == NULL)
5919 : {
5920 30 : tree ifmask;
5921 30 : tree if_stmt;
5922 :
5923 30 : gfc_init_se (&maskse, NULL);
5924 30 : gfc_conv_expr_val (&maskse, maskexpr);
5925 30 : gfc_init_block (&block);
5926 30 : gfc_add_expr_to_block (&block, maskse.expr);
5927 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5928 30 : if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5929 : build_empty_stmt (input_location));
5930 30 : gfc_add_expr_to_block (&block, if_stmt);
5931 30 : tmp = gfc_finish_block (&block);
5932 : }
5933 :
5934 132 : gfc_add_expr_to_block (&se->pre, tmp);
5935 132 : se->expr = convert (type, resvar);
5936 :
5937 : }
5938 :
5939 : /* Emit code for fstat, lstat and stat intrinsic subroutines. */
5940 :
5941 : static tree
5942 55 : conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code)
5943 : {
5944 55 : stmtblock_t block;
5945 55 : gfc_se se, se_stat;
5946 55 : tree unit = NULL_TREE;
5947 55 : tree name = NULL_TREE;
5948 55 : tree slen = NULL_TREE;
5949 55 : tree vals;
5950 55 : tree arg3 = NULL_TREE;
5951 55 : tree stat = NULL_TREE ;
5952 55 : tree present = NULL_TREE;
5953 55 : tree tmp;
5954 55 : int kind;
5955 :
5956 55 : gfc_init_block (&block);
5957 55 : gfc_init_se (&se, NULL);
5958 :
5959 55 : switch (code->resolved_isym->id)
5960 : {
5961 21 : case GFC_ISYM_FSTAT:
5962 : /* Deal with the UNIT argument. */
5963 21 : gfc_conv_expr (&se, code->ext.actual->expr);
5964 21 : gfc_add_block_to_block (&block, &se.pre);
5965 21 : unit = gfc_evaluate_now (se.expr, &block);
5966 21 : unit = gfc_build_addr_expr (NULL_TREE, unit);
5967 21 : gfc_add_block_to_block (&block, &se.post);
5968 21 : break;
5969 :
5970 34 : case GFC_ISYM_LSTAT:
5971 34 : case GFC_ISYM_STAT:
5972 : /* Deal with the NAME argument. */
5973 34 : gfc_conv_expr (&se, code->ext.actual->expr);
5974 34 : gfc_conv_string_parameter (&se);
5975 34 : gfc_add_block_to_block (&block, &se.pre);
5976 34 : name = se.expr;
5977 34 : slen = se.string_length;
5978 34 : gfc_add_block_to_block (&block, &se.post);
5979 34 : break;
5980 :
5981 0 : default:
5982 0 : gcc_unreachable ();
5983 : }
5984 :
5985 : /* Deal with the VALUES argument. */
5986 55 : gfc_init_se (&se, NULL);
5987 55 : gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr);
5988 55 : vals = gfc_build_addr_expr (NULL_TREE, se.expr);
5989 55 : gfc_add_block_to_block (&block, &se.pre);
5990 55 : gfc_add_block_to_block (&block, &se.post);
5991 55 : kind = code->ext.actual->next->expr->ts.kind;
5992 :
5993 : /* Deal with an optional STATUS. */
5994 55 : if (code->ext.actual->next->next->expr)
5995 : {
5996 45 : gfc_init_se (&se_stat, NULL);
5997 45 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
5998 45 : stat = gfc_create_var (gfc_get_int_type (kind), "_stat");
5999 45 : arg3 = gfc_build_addr_expr (NULL_TREE, stat);
6000 :
6001 : /* Handle case of status being an optional dummy. */
6002 45 : gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym;
6003 45 : if (sym->attr.dummy && sym->attr.optional)
6004 : {
6005 6 : present = gfc_conv_expr_present (sym);
6006 12 : arg3 = fold_build3_loc (input_location, COND_EXPR,
6007 6 : TREE_TYPE (arg3), present, arg3,
6008 6 : fold_convert (TREE_TYPE (arg3),
6009 : null_pointer_node));
6010 : }
6011 : }
6012 :
6013 : /* Call library function depending on KIND of VALUES argument. */
6014 55 : switch (code->resolved_isym->id)
6015 : {
6016 21 : case GFC_ISYM_FSTAT:
6017 21 : tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub);
6018 : break;
6019 14 : case GFC_ISYM_LSTAT:
6020 14 : tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub);
6021 : break;
6022 20 : case GFC_ISYM_STAT:
6023 20 : tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub);
6024 : break;
6025 0 : default:
6026 0 : gcc_unreachable ();
6027 : }
6028 :
6029 55 : if (code->resolved_isym->id == GFC_ISYM_FSTAT)
6030 21 : tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals,
6031 : stat ? arg3 : null_pointer_node);
6032 : else
6033 34 : tmp = build_call_expr_loc (input_location, tmp, 4, name, vals,
6034 : stat ? arg3 : null_pointer_node, slen);
6035 55 : gfc_add_expr_to_block (&block, tmp);
6036 :
6037 : /* Handle kind conversion of status. */
6038 55 : if (stat && stat != se_stat.expr)
6039 : {
6040 45 : stmtblock_t block2;
6041 :
6042 45 : gfc_init_block (&block2);
6043 45 : gfc_add_modify (&block2, se_stat.expr,
6044 45 : fold_convert (TREE_TYPE (se_stat.expr), stat));
6045 :
6046 45 : if (present)
6047 : {
6048 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2),
6049 : build_empty_stmt (input_location));
6050 6 : gfc_add_expr_to_block (&block, tmp);
6051 : }
6052 : else
6053 39 : gfc_add_block_to_block (&block, &block2);
6054 : }
6055 :
6056 55 : return gfc_finish_block (&block);
6057 : }
6058 :
6059 : /* Emit code for minval or maxval intrinsic. There are many different cases
6060 : we need to handle. For performance reasons we sometimes create two
6061 : loops instead of one, where the second one is much simpler.
6062 : Examples for minval intrinsic:
6063 : 1) Result is an array, a call is generated
6064 : 2) Array mask is used and NaNs need to be supported, rank 1:
6065 : limit = Infinity;
6066 : nonempty = false;
6067 : S = from;
6068 : while (S <= to) {
6069 : if (mask[S]) {
6070 : nonempty = true;
6071 : if (a[S] <= limit) {
6072 : limit = a[S];
6073 : S++;
6074 : goto lab;
6075 : }
6076 : else
6077 : S++;
6078 : }
6079 : }
6080 : limit = nonempty ? NaN : huge (limit);
6081 : lab:
6082 : while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6083 : 3) NaNs need to be supported, but it is known at compile time or cheaply
6084 : at runtime whether array is nonempty or not, rank 1:
6085 : limit = Infinity;
6086 : S = from;
6087 : while (S <= to) {
6088 : if (a[S] <= limit) {
6089 : limit = a[S];
6090 : S++;
6091 : goto lab;
6092 : }
6093 : else
6094 : S++;
6095 : }
6096 : limit = (from <= to) ? NaN : huge (limit);
6097 : lab:
6098 : while (S <= to) { limit = min (a[S], limit); S++; }
6099 : 4) Array mask is used and NaNs need to be supported, rank > 1:
6100 : limit = Infinity;
6101 : nonempty = false;
6102 : fast = false;
6103 : S1 = from1;
6104 : while (S1 <= to1) {
6105 : S2 = from2;
6106 : while (S2 <= to2) {
6107 : if (mask[S1][S2]) {
6108 : if (fast) limit = min (a[S1][S2], limit);
6109 : else {
6110 : nonempty = true;
6111 : if (a[S1][S2] <= limit) {
6112 : limit = a[S1][S2];
6113 : fast = true;
6114 : }
6115 : }
6116 : }
6117 : S2++;
6118 : }
6119 : S1++;
6120 : }
6121 : if (!fast)
6122 : limit = nonempty ? NaN : huge (limit);
6123 : 5) NaNs need to be supported, but it is known at compile time or cheaply
6124 : at runtime whether array is nonempty or not, rank > 1:
6125 : limit = Infinity;
6126 : fast = false;
6127 : S1 = from1;
6128 : while (S1 <= to1) {
6129 : S2 = from2;
6130 : while (S2 <= to2) {
6131 : if (fast) limit = min (a[S1][S2], limit);
6132 : else {
6133 : if (a[S1][S2] <= limit) {
6134 : limit = a[S1][S2];
6135 : fast = true;
6136 : }
6137 : }
6138 : S2++;
6139 : }
6140 : S1++;
6141 : }
6142 : if (!fast)
6143 : limit = (nonempty_array) ? NaN : huge (limit);
6144 : 6) NaNs aren't supported, but infinities are. Array mask is used:
6145 : limit = Infinity;
6146 : nonempty = false;
6147 : S = from;
6148 : while (S <= to) {
6149 : if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6150 : S++;
6151 : }
6152 : limit = nonempty ? limit : huge (limit);
6153 : 7) Same without array mask:
6154 : limit = Infinity;
6155 : S = from;
6156 : while (S <= to) { limit = min (a[S], limit); S++; }
6157 : limit = (from <= to) ? limit : huge (limit);
6158 : 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6159 : limit = huge (limit);
6160 : S = from;
6161 : while (S <= to) { limit = min (a[S], limit); S++); }
6162 : (or
6163 : while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6164 : with array mask instead).
6165 : For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6166 : setting limit = huge (limit); in the else branch. */
6167 :
6168 : static void
6169 2417 : gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6170 : {
6171 2417 : tree limit;
6172 2417 : tree type;
6173 2417 : tree tmp;
6174 2417 : tree ifbody;
6175 2417 : tree nonempty;
6176 2417 : tree nonempty_var;
6177 2417 : tree lab;
6178 2417 : tree fast;
6179 2417 : tree huge_cst = NULL, nan_cst = NULL;
6180 2417 : stmtblock_t body;
6181 2417 : stmtblock_t block, block2;
6182 2417 : gfc_loopinfo loop;
6183 2417 : gfc_actual_arglist *actual;
6184 2417 : gfc_ss *arrayss;
6185 2417 : gfc_ss *maskss;
6186 2417 : gfc_se arrayse;
6187 2417 : gfc_se maskse;
6188 2417 : gfc_expr *arrayexpr;
6189 2417 : gfc_expr *maskexpr;
6190 2417 : int n;
6191 2417 : bool optional_mask;
6192 :
6193 2417 : if (se->ss)
6194 : {
6195 0 : gfc_conv_intrinsic_funcall (se, expr);
6196 186 : return;
6197 : }
6198 :
6199 2417 : actual = expr->value.function.actual;
6200 2417 : arrayexpr = actual->expr;
6201 :
6202 2417 : if (arrayexpr->ts.type == BT_CHARACTER)
6203 : {
6204 186 : gfc_actual_arglist *dim = actual->next;
6205 186 : if (expr->rank == 0 && dim->expr != 0)
6206 : {
6207 6 : gfc_free_expr (dim->expr);
6208 6 : dim->expr = NULL;
6209 : }
6210 186 : gfc_conv_intrinsic_funcall (se, expr);
6211 186 : return;
6212 : }
6213 :
6214 2231 : type = gfc_typenode_for_spec (&expr->ts);
6215 : /* Initialize the result. */
6216 2231 : limit = gfc_create_var (type, "limit");
6217 2231 : n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6218 2231 : switch (expr->ts.type)
6219 : {
6220 1245 : case BT_REAL:
6221 1245 : huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6222 : expr->ts.kind, 0);
6223 1245 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6224 : {
6225 1241 : REAL_VALUE_TYPE real;
6226 1241 : real_inf (&real);
6227 1241 : tmp = build_real (type, real);
6228 : }
6229 : else
6230 : tmp = huge_cst;
6231 1245 : if (HONOR_NANS (DECL_MODE (limit)))
6232 1241 : nan_cst = gfc_build_nan (type, "");
6233 : break;
6234 :
6235 956 : case BT_INTEGER:
6236 956 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6237 956 : break;
6238 :
6239 30 : case BT_UNSIGNED:
6240 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
6241 30 : if (op == GT_EXPR)
6242 18 : tmp = build_int_cst (type, 0);
6243 : else
6244 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
6245 : expr->ts.kind);
6246 : break;
6247 :
6248 0 : default:
6249 0 : gcc_unreachable ();
6250 : }
6251 :
6252 : /* We start with the most negative possible value for MAXVAL, and the most
6253 : positive possible value for MINVAL. The most negative possible value is
6254 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6255 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
6256 : with above. */
6257 2231 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
6258 : {
6259 987 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6260 987 : if (huge_cst)
6261 560 : huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6262 560 : TREE_TYPE (huge_cst), huge_cst);
6263 : }
6264 :
6265 1005 : if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6266 427 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6267 : tmp, build_int_cst (type, 1));
6268 :
6269 2231 : gfc_add_modify (&se->pre, limit, tmp);
6270 :
6271 : /* Walk the arguments. */
6272 2231 : arrayss = gfc_walk_expr (arrayexpr);
6273 2231 : gcc_assert (arrayss != gfc_ss_terminator);
6274 :
6275 2231 : actual = actual->next->next;
6276 2231 : gcc_assert (actual);
6277 2231 : maskexpr = actual->expr;
6278 1572 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6279 1560 : && maskexpr->symtree->n.sym->attr.dummy
6280 2243 : && maskexpr->symtree->n.sym->attr.optional;
6281 2777 : nonempty = NULL;
6282 1572 : if (maskexpr && maskexpr->rank != 0)
6283 : {
6284 1026 : maskss = gfc_walk_expr (maskexpr);
6285 1026 : gcc_assert (maskss != gfc_ss_terminator);
6286 : }
6287 : else
6288 : {
6289 1205 : mpz_t asize;
6290 1205 : if (gfc_array_size (arrayexpr, &asize))
6291 : {
6292 678 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6293 678 : mpz_clear (asize);
6294 678 : nonempty = fold_build2_loc (input_location, GT_EXPR,
6295 : logical_type_node, nonempty,
6296 : gfc_index_zero_node);
6297 : }
6298 1205 : maskss = NULL;
6299 : }
6300 :
6301 : /* Initialize the scalarizer. */
6302 2231 : gfc_init_loopinfo (&loop);
6303 :
6304 : /* We add the mask first because the number of iterations is taken
6305 : from the last ss, and this breaks if an absent optional argument
6306 : is used for mask. */
6307 :
6308 2231 : if (maskss)
6309 1026 : gfc_add_ss_to_loop (&loop, maskss);
6310 2231 : gfc_add_ss_to_loop (&loop, arrayss);
6311 :
6312 : /* Initialize the loop. */
6313 2231 : gfc_conv_ss_startstride (&loop);
6314 :
6315 : /* The code generated can have more than one loop in sequence (see the
6316 : comment at the function header). This doesn't work well with the
6317 : scalarizer, which changes arrays' offset when the scalarization loops
6318 : are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6319 : are currently inlined in the scalar case only. As there is no dependency
6320 : to care about in that case, there is no temporary, so that we can use the
6321 : scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6322 : here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6323 : gfc_trans_scalarized_loop_boundary even later to restore offset.
6324 : TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6325 : should eventually go away. We could either create two loops properly,
6326 : or find another way to save/restore the array offsets between the two
6327 : loops (without conflicting with temporary management), or use a single
6328 : loop minmaxval implementation. See PR 31067. */
6329 2231 : loop.temp_dim = loop.dimen;
6330 2231 : gfc_conv_loop_setup (&loop, &expr->where);
6331 :
6332 2231 : if (nonempty == NULL && maskss == NULL
6333 527 : && loop.dimen == 1 && loop.from[0] && loop.to[0])
6334 491 : nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6335 : loop.from[0], loop.to[0]);
6336 2231 : nonempty_var = NULL;
6337 2231 : if (nonempty == NULL
6338 2231 : && (HONOR_INFINITIES (DECL_MODE (limit))
6339 480 : || HONOR_NANS (DECL_MODE (limit))))
6340 : {
6341 582 : nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6342 582 : gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6343 582 : nonempty = nonempty_var;
6344 : }
6345 2231 : lab = NULL;
6346 2231 : fast = NULL;
6347 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6348 : {
6349 1241 : if (loop.dimen == 1)
6350 : {
6351 821 : lab = gfc_build_label_decl (NULL_TREE);
6352 821 : TREE_USED (lab) = 1;
6353 : }
6354 : else
6355 : {
6356 420 : fast = gfc_create_var (logical_type_node, "fast");
6357 420 : gfc_add_modify (&se->pre, fast, logical_false_node);
6358 : }
6359 : }
6360 :
6361 2231 : gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6362 2231 : if (maskss)
6363 1704 : gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6364 : /* Generate the loop body. */
6365 2231 : gfc_start_scalarized_body (&loop, &body);
6366 :
6367 : /* If we have a mask, only add this element if the mask is set. */
6368 2231 : if (maskss)
6369 : {
6370 1026 : gfc_init_se (&maskse, NULL);
6371 1026 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6372 1026 : maskse.ss = maskss;
6373 1026 : gfc_conv_expr_val (&maskse, maskexpr);
6374 1026 : gfc_add_block_to_block (&body, &maskse.pre);
6375 :
6376 1026 : gfc_start_block (&block);
6377 : }
6378 : else
6379 1205 : gfc_init_block (&block);
6380 :
6381 : /* Compare with the current limit. */
6382 2231 : gfc_init_se (&arrayse, NULL);
6383 2231 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6384 2231 : arrayse.ss = arrayss;
6385 2231 : gfc_conv_expr_val (&arrayse, arrayexpr);
6386 2231 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6387 2231 : gfc_add_block_to_block (&block, &arrayse.pre);
6388 :
6389 2231 : gfc_init_block (&block2);
6390 :
6391 2231 : if (nonempty_var)
6392 582 : gfc_add_modify (&block2, nonempty_var, logical_true_node);
6393 :
6394 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6395 : {
6396 1922 : tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6397 : logical_type_node, arrayse.expr, limit);
6398 1241 : if (lab)
6399 : {
6400 821 : stmtblock_t ifblock;
6401 821 : tree inc_loop;
6402 821 : inc_loop = fold_build2_loc (input_location, PLUS_EXPR,
6403 821 : TREE_TYPE (loop.loopvar[0]),
6404 : loop.loopvar[0], gfc_index_one_node);
6405 821 : gfc_init_block (&ifblock);
6406 821 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6407 821 : gfc_add_modify (&ifblock, loop.loopvar[0], inc_loop);
6408 821 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab));
6409 821 : ifbody = gfc_finish_block (&ifblock);
6410 : }
6411 : else
6412 : {
6413 420 : stmtblock_t ifblock;
6414 :
6415 420 : gfc_init_block (&ifblock);
6416 420 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6417 420 : gfc_add_modify (&ifblock, fast, logical_true_node);
6418 420 : ifbody = gfc_finish_block (&ifblock);
6419 : }
6420 1241 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6421 : build_empty_stmt (input_location));
6422 1241 : gfc_add_expr_to_block (&block2, tmp);
6423 : }
6424 : else
6425 : {
6426 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6427 : signed zeros. */
6428 1535 : tmp = fold_build2_loc (input_location,
6429 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6430 : type, arrayse.expr, limit);
6431 990 : gfc_add_modify (&block2, limit, tmp);
6432 : }
6433 :
6434 2231 : if (fast)
6435 : {
6436 420 : tree elsebody = gfc_finish_block (&block2);
6437 :
6438 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6439 : signed zeros. */
6440 420 : if (HONOR_NANS (DECL_MODE (limit)))
6441 : {
6442 420 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6443 : arrayse.expr, limit);
6444 420 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6445 420 : ifbody = build3_v (COND_EXPR, tmp, ifbody,
6446 : build_empty_stmt (input_location));
6447 : }
6448 : else
6449 : {
6450 0 : tmp = fold_build2_loc (input_location,
6451 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6452 : type, arrayse.expr, limit);
6453 0 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6454 : }
6455 420 : tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6456 420 : gfc_add_expr_to_block (&block, tmp);
6457 : }
6458 : else
6459 1811 : gfc_add_block_to_block (&block, &block2);
6460 :
6461 2231 : gfc_add_block_to_block (&block, &arrayse.post);
6462 :
6463 2231 : tmp = gfc_finish_block (&block);
6464 2231 : if (maskss)
6465 : {
6466 : /* We enclose the above in if (mask) {...}. If the mask is an
6467 : optional argument, generate IF (.NOT. PRESENT(MASK)
6468 : .OR. MASK(I)). */
6469 1026 : tree ifmask;
6470 1026 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6471 1026 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6472 : build_empty_stmt (input_location));
6473 : }
6474 2231 : gfc_add_expr_to_block (&body, tmp);
6475 :
6476 2231 : if (lab)
6477 : {
6478 821 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6479 :
6480 821 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6481 : nan_cst, huge_cst);
6482 821 : gfc_add_modify (&loop.code[0], limit, tmp);
6483 821 : gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6484 :
6485 : /* If we have a mask, only add this element if the mask is set. */
6486 821 : if (maskss)
6487 : {
6488 348 : gfc_init_se (&maskse, NULL);
6489 348 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6490 348 : maskse.ss = maskss;
6491 348 : gfc_conv_expr_val (&maskse, maskexpr);
6492 348 : gfc_add_block_to_block (&body, &maskse.pre);
6493 :
6494 348 : gfc_start_block (&block);
6495 : }
6496 : else
6497 473 : gfc_init_block (&block);
6498 :
6499 : /* Compare with the current limit. */
6500 821 : gfc_init_se (&arrayse, NULL);
6501 821 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6502 821 : arrayse.ss = arrayss;
6503 821 : gfc_conv_expr_val (&arrayse, arrayexpr);
6504 821 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6505 821 : gfc_add_block_to_block (&block, &arrayse.pre);
6506 :
6507 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6508 : signed zeros. */
6509 821 : if (HONOR_NANS (DECL_MODE (limit)))
6510 : {
6511 821 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6512 : arrayse.expr, limit);
6513 821 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6514 821 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6515 : build_empty_stmt (input_location));
6516 821 : gfc_add_expr_to_block (&block, tmp);
6517 : }
6518 : else
6519 : {
6520 0 : tmp = fold_build2_loc (input_location,
6521 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6522 : type, arrayse.expr, limit);
6523 0 : gfc_add_modify (&block, limit, tmp);
6524 : }
6525 :
6526 821 : gfc_add_block_to_block (&block, &arrayse.post);
6527 :
6528 821 : tmp = gfc_finish_block (&block);
6529 821 : if (maskss)
6530 : /* We enclose the above in if (mask) {...}. */
6531 : {
6532 348 : tree ifmask;
6533 348 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6534 348 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6535 : build_empty_stmt (input_location));
6536 : }
6537 :
6538 821 : gfc_add_expr_to_block (&body, tmp);
6539 : /* Avoid initializing loopvar[0] again, it should be left where
6540 : it finished by the first loop. */
6541 821 : loop.from[0] = loop.loopvar[0];
6542 : }
6543 2231 : gfc_trans_scalarizing_loops (&loop, &body);
6544 :
6545 2231 : if (fast)
6546 : {
6547 420 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6548 : nan_cst, huge_cst);
6549 420 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6550 420 : tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6551 : ifbody);
6552 420 : gfc_add_expr_to_block (&loop.pre, tmp);
6553 : }
6554 1811 : else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6555 : {
6556 0 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6557 : huge_cst);
6558 0 : gfc_add_modify (&loop.pre, limit, tmp);
6559 : }
6560 :
6561 : /* For a scalar mask, enclose the loop in an if statement. */
6562 2231 : if (maskexpr && maskss == NULL)
6563 : {
6564 546 : tree else_stmt;
6565 546 : tree ifmask;
6566 :
6567 546 : gfc_init_se (&maskse, NULL);
6568 546 : gfc_conv_expr_val (&maskse, maskexpr);
6569 546 : gfc_init_block (&block);
6570 546 : gfc_add_block_to_block (&block, &loop.pre);
6571 546 : gfc_add_block_to_block (&block, &loop.post);
6572 546 : tmp = gfc_finish_block (&block);
6573 :
6574 546 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6575 354 : else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6576 : else
6577 192 : else_stmt = build_empty_stmt (input_location);
6578 :
6579 546 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6580 546 : tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6581 546 : gfc_add_expr_to_block (&block, tmp);
6582 546 : gfc_add_block_to_block (&se->pre, &block);
6583 : }
6584 : else
6585 : {
6586 1685 : gfc_add_block_to_block (&se->pre, &loop.pre);
6587 1685 : gfc_add_block_to_block (&se->pre, &loop.post);
6588 : }
6589 :
6590 2231 : gfc_cleanup_loop (&loop);
6591 :
6592 2231 : se->expr = limit;
6593 : }
6594 :
6595 : /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6596 : static void
6597 145 : gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6598 : {
6599 145 : tree args[2];
6600 145 : tree type;
6601 145 : tree tmp;
6602 :
6603 145 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6604 145 : type = TREE_TYPE (args[0]);
6605 :
6606 : /* Optionally generate code for runtime argument check. */
6607 145 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6608 : {
6609 6 : tree below = fold_build2_loc (input_location, LT_EXPR,
6610 : logical_type_node, args[1],
6611 6 : build_int_cst (TREE_TYPE (args[1]), 0));
6612 6 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6613 6 : tree above = fold_build2_loc (input_location, GE_EXPR,
6614 : logical_type_node, args[1], nbits);
6615 6 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6616 : logical_type_node, below, above);
6617 6 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6618 : "POS argument (%ld) out of range 0:%ld "
6619 : "in intrinsic BTEST",
6620 : fold_convert (long_integer_type_node, args[1]),
6621 : fold_convert (long_integer_type_node, nbits));
6622 : }
6623 :
6624 145 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6625 : build_int_cst (type, 1), args[1]);
6626 145 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6627 145 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6628 : build_int_cst (type, 0));
6629 145 : type = gfc_typenode_for_spec (&expr->ts);
6630 145 : se->expr = convert (type, tmp);
6631 145 : }
6632 :
6633 :
6634 : /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6635 : static void
6636 216 : gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6637 : {
6638 216 : tree args[2];
6639 :
6640 216 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6641 :
6642 : /* Convert both arguments to the unsigned type of the same size. */
6643 216 : args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6644 216 : args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6645 :
6646 : /* If they have unequal type size, convert to the larger one. */
6647 216 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
6648 216 : > TYPE_PRECISION (TREE_TYPE (args[1])))
6649 0 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6650 216 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6651 216 : > TYPE_PRECISION (TREE_TYPE (args[0])))
6652 0 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6653 :
6654 : /* Now, we compare them. */
6655 216 : se->expr = fold_build2_loc (input_location, op, logical_type_node,
6656 : args[0], args[1]);
6657 216 : }
6658 :
6659 :
6660 : /* Generate code to perform the specified operation. */
6661 : static void
6662 1915 : gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6663 : {
6664 1915 : tree args[2];
6665 :
6666 1915 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6667 1915 : se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6668 : args[0], args[1]);
6669 1915 : }
6670 :
6671 : /* Bitwise not. */
6672 : static void
6673 230 : gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6674 : {
6675 230 : tree arg;
6676 :
6677 230 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6678 230 : se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6679 230 : TREE_TYPE (arg), arg);
6680 230 : }
6681 :
6682 :
6683 : /* Generate code for OUT_OF_RANGE. */
6684 : static void
6685 468 : gfc_conv_intrinsic_out_of_range (gfc_se * se, gfc_expr * expr)
6686 : {
6687 468 : tree *args;
6688 468 : tree type;
6689 468 : tree tmp = NULL_TREE, tmp1, tmp2;
6690 468 : unsigned int num_args;
6691 468 : int k;
6692 468 : gfc_se rnd_se;
6693 468 : gfc_actual_arglist *arg = expr->value.function.actual;
6694 468 : gfc_expr *x = arg->expr;
6695 468 : gfc_expr *mold = arg->next->expr;
6696 :
6697 468 : num_args = gfc_intrinsic_argument_list_length (expr);
6698 468 : args = XALLOCAVEC (tree, num_args);
6699 :
6700 468 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6701 :
6702 468 : gfc_init_se (&rnd_se, NULL);
6703 :
6704 468 : if (num_args == 3)
6705 : {
6706 : /* The ROUND argument is optional and shall appear only if X is
6707 : of type real and MOLD is of type integer (see edit F23/004). */
6708 270 : gfc_expr *round = arg->next->next->expr;
6709 270 : gfc_conv_expr (&rnd_se, round);
6710 :
6711 270 : if (round->expr_type == EXPR_VARIABLE
6712 198 : && round->symtree->n.sym->attr.dummy
6713 30 : && round->symtree->n.sym->attr.optional)
6714 : {
6715 30 : tree present = gfc_conv_expr_present (round->symtree->n.sym);
6716 30 : rnd_se.expr = build3_loc (input_location, COND_EXPR,
6717 : logical_type_node, present,
6718 : rnd_se.expr, logical_false_node);
6719 30 : gfc_add_block_to_block (&se->pre, &rnd_se.pre);
6720 : }
6721 : }
6722 : else
6723 : {
6724 : /* If ROUND is absent, it is equivalent to having the value false. */
6725 198 : rnd_se.expr = logical_false_node;
6726 : }
6727 :
6728 468 : type = TREE_TYPE (args[0]);
6729 468 : k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
6730 :
6731 468 : switch (x->ts.type)
6732 : {
6733 378 : case BT_REAL:
6734 : /* X may be IEEE infinity or NaN, but the representation of MOLD may not
6735 : support infinity or NaN. */
6736 378 : tree finite;
6737 378 : finite = build_call_expr_loc (input_location,
6738 : builtin_decl_explicit (BUILT_IN_ISFINITE),
6739 : 1, args[0]);
6740 378 : finite = convert (logical_type_node, finite);
6741 :
6742 378 : if (mold->ts.type == BT_REAL)
6743 : {
6744 24 : tmp1 = build1 (ABS_EXPR, type, args[0]);
6745 24 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6746 : mold->ts.kind, 0);
6747 24 : tmp = build2 (GT_EXPR, logical_type_node, tmp1,
6748 : convert (type, tmp2));
6749 :
6750 : /* Check if MOLD representation supports infinity or NaN. */
6751 24 : bool infnan = (HONOR_INFINITIES (TREE_TYPE (args[1]))
6752 24 : || HONOR_NANS (TREE_TYPE (args[1])));
6753 24 : tmp = build3 (COND_EXPR, logical_type_node, finite, tmp,
6754 : infnan ? logical_false_node : logical_true_node);
6755 : }
6756 : else
6757 : {
6758 354 : tree rounded;
6759 354 : tree decl;
6760 :
6761 354 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, x->ts.kind);
6762 354 : gcc_assert (decl != NULL_TREE);
6763 :
6764 : /* Round or truncate argument X, depending on the optional argument
6765 : ROUND (default: .false.). */
6766 354 : tmp1 = build_round_expr (args[0], type);
6767 354 : tmp2 = build_call_expr_loc (input_location, decl, 1, args[0]);
6768 354 : rounded = build3 (COND_EXPR, type, rnd_se.expr, tmp1, tmp2);
6769 :
6770 354 : if (mold->ts.type == BT_INTEGER)
6771 : {
6772 180 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6773 : x->ts.kind);
6774 180 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6775 : x->ts.kind);
6776 : }
6777 174 : else if (mold->ts.type == BT_UNSIGNED)
6778 : {
6779 174 : tmp1 = build_real_from_int_cst (type, integer_zero_node);
6780 174 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6781 : x->ts.kind);
6782 : }
6783 : else
6784 0 : gcc_unreachable ();
6785 :
6786 354 : tmp1 = build2 (LT_EXPR, logical_type_node, rounded,
6787 : convert (type, tmp1));
6788 354 : tmp2 = build2 (GT_EXPR, logical_type_node, rounded,
6789 : convert (type, tmp2));
6790 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6791 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node,
6792 : build1 (TRUTH_NOT_EXPR, logical_type_node, finite),
6793 : tmp);
6794 : }
6795 : break;
6796 :
6797 48 : case BT_INTEGER:
6798 48 : if (mold->ts.type == BT_INTEGER)
6799 : {
6800 12 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6801 : x->ts.kind);
6802 12 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6803 : x->ts.kind);
6804 12 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6805 : convert (type, tmp1));
6806 12 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6807 : convert (type, tmp2));
6808 12 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6809 : }
6810 36 : else if (mold->ts.type == BT_UNSIGNED)
6811 : {
6812 36 : int i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6813 36 : tmp = build_int_cst (type, 0);
6814 36 : tmp = build2 (LT_EXPR, logical_type_node, args[0], tmp);
6815 36 : if (mpz_cmp (gfc_integer_kinds[i].huge,
6816 36 : gfc_unsigned_kinds[k].huge) > 0)
6817 : {
6818 0 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6819 : x->ts.kind);
6820 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6821 : convert (type, tmp2));
6822 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp, tmp2);
6823 : }
6824 : }
6825 0 : else if (mold->ts.type == BT_REAL)
6826 : {
6827 0 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6828 : mold->ts.kind, 0);
6829 0 : tmp1 = build1 (NEGATE_EXPR, TREE_TYPE (tmp2), tmp2);
6830 0 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6831 : convert (type, tmp1));
6832 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6833 : convert (type, tmp2));
6834 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6835 : }
6836 : else
6837 0 : gcc_unreachable ();
6838 : break;
6839 :
6840 42 : case BT_UNSIGNED:
6841 42 : if (mold->ts.type == BT_UNSIGNED)
6842 : {
6843 12 : tmp = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6844 : x->ts.kind);
6845 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6846 : convert (type, tmp));
6847 : }
6848 30 : else if (mold->ts.type == BT_INTEGER)
6849 : {
6850 18 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6851 : x->ts.kind);
6852 18 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6853 : convert (type, tmp));
6854 : }
6855 12 : else if (mold->ts.type == BT_REAL)
6856 : {
6857 12 : tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6858 : mold->ts.kind, 0);
6859 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6860 : convert (type, tmp));
6861 : }
6862 : else
6863 0 : gcc_unreachable ();
6864 : break;
6865 :
6866 0 : default:
6867 0 : gcc_unreachable ();
6868 : }
6869 :
6870 468 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6871 468 : }
6872 :
6873 :
6874 : /* Set or clear a single bit. */
6875 : static void
6876 306 : gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6877 : {
6878 306 : tree args[2];
6879 306 : tree type;
6880 306 : tree tmp;
6881 306 : enum tree_code op;
6882 :
6883 306 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6884 306 : type = TREE_TYPE (args[0]);
6885 :
6886 : /* Optionally generate code for runtime argument check. */
6887 306 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6888 : {
6889 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6890 : logical_type_node, args[1],
6891 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6892 12 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6893 12 : tree above = fold_build2_loc (input_location, GE_EXPR,
6894 : logical_type_node, args[1], nbits);
6895 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6896 : logical_type_node, below, above);
6897 12 : size_t len_name = strlen (expr->value.function.isym->name);
6898 12 : char *name = XALLOCAVEC (char, len_name + 1);
6899 72 : for (size_t i = 0; i < len_name; i++)
6900 60 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
6901 12 : name[len_name] = '\0';
6902 12 : tree iname = gfc_build_addr_expr (pchar_type_node,
6903 : gfc_build_cstring_const (name));
6904 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6905 : "POS argument (%ld) out of range 0:%ld "
6906 : "in intrinsic %s",
6907 : fold_convert (long_integer_type_node, args[1]),
6908 : fold_convert (long_integer_type_node, nbits),
6909 : iname);
6910 : }
6911 :
6912 306 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6913 : build_int_cst (type, 1), args[1]);
6914 306 : if (set)
6915 : op = BIT_IOR_EXPR;
6916 : else
6917 : {
6918 168 : op = BIT_AND_EXPR;
6919 168 : tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6920 : }
6921 306 : se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6922 306 : }
6923 :
6924 : /* Extract a sequence of bits.
6925 : IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6926 : static void
6927 27 : gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6928 : {
6929 27 : tree args[3];
6930 27 : tree type;
6931 27 : tree tmp;
6932 27 : tree mask;
6933 27 : tree num_bits, cond;
6934 :
6935 27 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
6936 27 : type = TREE_TYPE (args[0]);
6937 :
6938 : /* Optionally generate code for runtime argument check. */
6939 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6940 : {
6941 12 : tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6942 12 : tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6943 12 : tree nbits = build_int_cst (long_integer_type_node,
6944 12 : TYPE_PRECISION (type));
6945 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6946 : logical_type_node, args[1],
6947 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6948 12 : tree above = fold_build2_loc (input_location, GT_EXPR,
6949 : logical_type_node, tmp1, nbits);
6950 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6951 : logical_type_node, below, above);
6952 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6953 : "POS argument (%ld) out of range 0:%ld "
6954 : "in intrinsic IBITS", tmp1, nbits);
6955 12 : below = fold_build2_loc (input_location, LT_EXPR,
6956 : logical_type_node, args[2],
6957 12 : build_int_cst (TREE_TYPE (args[2]), 0));
6958 12 : above = fold_build2_loc (input_location, GT_EXPR,
6959 : logical_type_node, tmp2, nbits);
6960 12 : scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6961 : logical_type_node, below, above);
6962 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6963 : "LEN argument (%ld) out of range 0:%ld "
6964 : "in intrinsic IBITS", tmp2, nbits);
6965 12 : above = fold_build2_loc (input_location, PLUS_EXPR,
6966 : long_integer_type_node, tmp1, tmp2);
6967 12 : scond = fold_build2_loc (input_location, GT_EXPR,
6968 : logical_type_node, above, nbits);
6969 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6970 : "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6971 : "in intrinsic IBITS", tmp1, tmp2, nbits);
6972 : }
6973 :
6974 : /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6975 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6976 : special case. See also gfc_conv_intrinsic_ishft (). */
6977 27 : num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
6978 :
6979 27 : mask = build_int_cst (type, -1);
6980 27 : mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6981 27 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
6982 : num_bits);
6983 27 : mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
6984 : build_int_cst (type, 0), mask);
6985 27 : mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6986 :
6987 27 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6988 :
6989 27 : se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6990 27 : }
6991 :
6992 : static void
6993 492 : gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6994 : bool arithmetic)
6995 : {
6996 492 : tree args[2], type, num_bits, cond;
6997 492 : tree bigshift;
6998 492 : bool do_convert = false;
6999 :
7000 492 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7001 :
7002 492 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7003 492 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7004 492 : type = TREE_TYPE (args[0]);
7005 :
7006 492 : if (!arithmetic)
7007 : {
7008 390 : args[0] = fold_convert (unsigned_type_for (type), args[0]);
7009 390 : do_convert = true;
7010 : }
7011 : else
7012 102 : gcc_assert (right_shift);
7013 :
7014 492 : if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED)
7015 : {
7016 30 : do_convert = true;
7017 30 : args[0] = fold_convert (signed_type_for (type), args[0]);
7018 : }
7019 :
7020 816 : se->expr = fold_build2_loc (input_location,
7021 : right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
7022 492 : TREE_TYPE (args[0]), args[0], args[1]);
7023 :
7024 492 : if (do_convert)
7025 420 : se->expr = fold_convert (type, se->expr);
7026 :
7027 492 : if (!arithmetic)
7028 390 : bigshift = build_int_cst (type, 0);
7029 : else
7030 : {
7031 102 : tree nonneg = fold_build2_loc (input_location, GE_EXPR,
7032 : logical_type_node, args[0],
7033 102 : build_int_cst (TREE_TYPE (args[0]), 0));
7034 102 : bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
7035 : build_int_cst (type, 0),
7036 : build_int_cst (type, -1));
7037 : }
7038 :
7039 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7040 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7041 : special case. */
7042 492 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7043 :
7044 : /* Optionally generate code for runtime argument check. */
7045 492 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7046 : {
7047 30 : tree below = fold_build2_loc (input_location, LT_EXPR,
7048 : logical_type_node, args[1],
7049 30 : build_int_cst (TREE_TYPE (args[1]), 0));
7050 30 : tree above = fold_build2_loc (input_location, GT_EXPR,
7051 : logical_type_node, args[1], num_bits);
7052 30 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7053 : logical_type_node, below, above);
7054 30 : size_t len_name = strlen (expr->value.function.isym->name);
7055 30 : char *name = XALLOCAVEC (char, len_name + 1);
7056 210 : for (size_t i = 0; i < len_name; i++)
7057 180 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
7058 30 : name[len_name] = '\0';
7059 30 : tree iname = gfc_build_addr_expr (pchar_type_node,
7060 : gfc_build_cstring_const (name));
7061 30 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7062 : "SHIFT argument (%ld) out of range 0:%ld "
7063 : "in intrinsic %s",
7064 : fold_convert (long_integer_type_node, args[1]),
7065 : fold_convert (long_integer_type_node, num_bits),
7066 : iname);
7067 : }
7068 :
7069 492 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7070 : args[1], num_bits);
7071 :
7072 492 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7073 : bigshift, se->expr);
7074 492 : }
7075 :
7076 : /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
7077 : ? 0
7078 : : ((shift >= 0) ? i << shift : i >> -shift)
7079 : where all shifts are logical shifts. */
7080 : static void
7081 318 : gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
7082 : {
7083 318 : tree args[2];
7084 318 : tree type;
7085 318 : tree utype;
7086 318 : tree tmp;
7087 318 : tree width;
7088 318 : tree num_bits;
7089 318 : tree cond;
7090 318 : tree lshift;
7091 318 : tree rshift;
7092 :
7093 318 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7094 :
7095 318 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7096 318 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7097 :
7098 318 : type = TREE_TYPE (args[0]);
7099 318 : utype = unsigned_type_for (type);
7100 :
7101 318 : width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
7102 : args[1]);
7103 :
7104 : /* Left shift if positive. */
7105 318 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
7106 :
7107 : /* Right shift if negative.
7108 : We convert to an unsigned type because we want a logical shift.
7109 : The standard doesn't define the case of shifting negative
7110 : numbers, and we try to be compatible with other compilers, most
7111 : notably g77, here. */
7112 318 : rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
7113 : utype, convert (utype, args[0]), width));
7114 :
7115 318 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
7116 318 : build_int_cst (TREE_TYPE (args[1]), 0));
7117 318 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
7118 :
7119 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7120 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7121 : special case. */
7122 318 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7123 :
7124 : /* Optionally generate code for runtime argument check. */
7125 318 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7126 : {
7127 24 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7128 : logical_type_node, width, num_bits);
7129 24 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7130 : "SHIFT argument (%ld) out of range -%ld:%ld "
7131 : "in intrinsic ISHFT",
7132 : fold_convert (long_integer_type_node, args[1]),
7133 : fold_convert (long_integer_type_node, num_bits),
7134 : fold_convert (long_integer_type_node, num_bits));
7135 : }
7136 :
7137 318 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
7138 : num_bits);
7139 318 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7140 : build_int_cst (type, 0), tmp);
7141 318 : }
7142 :
7143 :
7144 : /* Circular shift. AKA rotate or barrel shift. */
7145 :
7146 : static void
7147 658 : gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
7148 : {
7149 658 : tree *args;
7150 658 : tree type;
7151 658 : tree tmp;
7152 658 : tree lrot;
7153 658 : tree rrot;
7154 658 : tree zero;
7155 658 : tree nbits;
7156 658 : unsigned int num_args;
7157 :
7158 658 : num_args = gfc_intrinsic_argument_list_length (expr);
7159 658 : args = XALLOCAVEC (tree, num_args);
7160 :
7161 658 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7162 :
7163 658 : type = TREE_TYPE (args[0]);
7164 658 : nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
7165 :
7166 658 : if (num_args == 3)
7167 : {
7168 550 : gfc_expr *size = expr->value.function.actual->next->next->expr;
7169 :
7170 : /* Use a library function for the 3 parameter version. */
7171 550 : tree int4type = gfc_get_int_type (4);
7172 :
7173 : /* Treat optional SIZE argument when it is passed as an optional
7174 : dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
7175 550 : if (size->expr_type == EXPR_VARIABLE
7176 438 : && size->symtree->n.sym->attr.dummy
7177 36 : && size->symtree->n.sym->attr.optional)
7178 : {
7179 36 : tree type_of_size = TREE_TYPE (args[2]);
7180 72 : args[2] = build3_loc (input_location, COND_EXPR, type_of_size,
7181 36 : gfc_conv_expr_present (size->symtree->n.sym),
7182 : args[2], fold_convert (type_of_size, nbits));
7183 : }
7184 :
7185 : /* We convert the first argument to at least 4 bytes, and
7186 : convert back afterwards. This removes the need for library
7187 : functions for all argument sizes, and function will be
7188 : aligned to at least 32 bits, so there's no loss. */
7189 550 : if (expr->ts.kind < 4)
7190 242 : args[0] = convert (int4type, args[0]);
7191 :
7192 : /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
7193 : need loads of library functions. They cannot have values >
7194 : BIT_SIZE (I) so the conversion is safe. */
7195 550 : args[1] = convert (int4type, args[1]);
7196 550 : args[2] = convert (int4type, args[2]);
7197 :
7198 : /* Optionally generate code for runtime argument check. */
7199 550 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7200 : {
7201 18 : tree size = fold_convert (long_integer_type_node, args[2]);
7202 18 : tree below = fold_build2_loc (input_location, LE_EXPR,
7203 : logical_type_node, size,
7204 18 : build_int_cst (TREE_TYPE (args[1]), 0));
7205 18 : tree above = fold_build2_loc (input_location, GT_EXPR,
7206 : logical_type_node, size, nbits);
7207 18 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7208 : logical_type_node, below, above);
7209 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7210 : "SIZE argument (%ld) out of range 1:%ld "
7211 : "in intrinsic ISHFTC", size, nbits);
7212 18 : tree width = fold_convert (long_integer_type_node, args[1]);
7213 18 : width = fold_build1_loc (input_location, ABS_EXPR,
7214 : long_integer_type_node, width);
7215 18 : scond = fold_build2_loc (input_location, GT_EXPR,
7216 : logical_type_node, width, size);
7217 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7218 : "SHIFT argument (%ld) out of range -%ld:%ld "
7219 : "in intrinsic ISHFTC",
7220 : fold_convert (long_integer_type_node, args[1]),
7221 : size, size);
7222 : }
7223 :
7224 550 : switch (expr->ts.kind)
7225 : {
7226 426 : case 1:
7227 426 : case 2:
7228 426 : case 4:
7229 426 : tmp = gfor_fndecl_math_ishftc4;
7230 426 : break;
7231 124 : case 8:
7232 124 : tmp = gfor_fndecl_math_ishftc8;
7233 124 : break;
7234 0 : case 16:
7235 0 : tmp = gfor_fndecl_math_ishftc16;
7236 0 : break;
7237 0 : default:
7238 0 : gcc_unreachable ();
7239 : }
7240 550 : se->expr = build_call_expr_loc (input_location,
7241 : tmp, 3, args[0], args[1], args[2]);
7242 : /* Convert the result back to the original type, if we extended
7243 : the first argument's width above. */
7244 550 : if (expr->ts.kind < 4)
7245 242 : se->expr = convert (type, se->expr);
7246 :
7247 : return;
7248 : }
7249 :
7250 : /* Evaluate arguments only once. */
7251 108 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7252 108 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7253 :
7254 : /* Optionally generate code for runtime argument check. */
7255 108 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7256 : {
7257 12 : tree width = fold_convert (long_integer_type_node, args[1]);
7258 12 : width = fold_build1_loc (input_location, ABS_EXPR,
7259 : long_integer_type_node, width);
7260 12 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7261 : logical_type_node, width, nbits);
7262 12 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7263 : "SHIFT argument (%ld) out of range -%ld:%ld "
7264 : "in intrinsic ISHFTC",
7265 : fold_convert (long_integer_type_node, args[1]),
7266 : nbits, nbits);
7267 : }
7268 :
7269 : /* Rotate left if positive. */
7270 108 : lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
7271 :
7272 : /* Rotate right if negative. */
7273 108 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
7274 : args[1]);
7275 108 : rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
7276 :
7277 108 : zero = build_int_cst (TREE_TYPE (args[1]), 0);
7278 108 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
7279 : zero);
7280 108 : rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
7281 :
7282 : /* Do nothing if shift == 0. */
7283 108 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
7284 : zero);
7285 108 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
7286 : rrot);
7287 : }
7288 :
7289 :
7290 : /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7291 : : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7292 :
7293 : The conditional expression is necessary because the result of LEADZ(0)
7294 : is defined, but the result of __builtin_clz(0) is undefined for most
7295 : targets.
7296 :
7297 : For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7298 : difference in bit size between the argument of LEADZ and the C int. */
7299 :
7300 : static void
7301 270 : gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7302 : {
7303 270 : tree arg;
7304 270 : tree arg_type;
7305 270 : tree cond;
7306 270 : tree result_type;
7307 270 : tree leadz;
7308 270 : tree bit_size;
7309 270 : tree tmp;
7310 270 : tree func;
7311 270 : int s, argsize;
7312 :
7313 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7314 270 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7315 :
7316 : /* Which variant of __builtin_clz* should we call? */
7317 270 : if (argsize <= INT_TYPE_SIZE)
7318 : {
7319 183 : arg_type = unsigned_type_node;
7320 183 : func = builtin_decl_explicit (BUILT_IN_CLZ);
7321 : }
7322 87 : else if (argsize <= LONG_TYPE_SIZE)
7323 : {
7324 57 : arg_type = long_unsigned_type_node;
7325 57 : func = builtin_decl_explicit (BUILT_IN_CLZL);
7326 : }
7327 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7328 : {
7329 0 : arg_type = long_long_unsigned_type_node;
7330 0 : func = builtin_decl_explicit (BUILT_IN_CLZLL);
7331 : }
7332 : else
7333 : {
7334 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7335 30 : arg_type = gfc_build_uint_type (argsize);
7336 30 : func = NULL_TREE;
7337 : }
7338 :
7339 : /* Convert the actual argument twice: first, to the unsigned type of the
7340 : same size; then, to the proper argument type for the built-in
7341 : function. But the return type is of the default INTEGER kind. */
7342 270 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7343 270 : arg = fold_convert (arg_type, arg);
7344 270 : arg = gfc_evaluate_now (arg, &se->pre);
7345 270 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7346 :
7347 : /* Compute LEADZ for the case i .ne. 0. */
7348 270 : if (func)
7349 : {
7350 240 : s = TYPE_PRECISION (arg_type) - argsize;
7351 240 : tmp = fold_convert (result_type,
7352 : build_call_expr_loc (input_location, func,
7353 : 1, arg));
7354 240 : leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7355 240 : tmp, build_int_cst (result_type, s));
7356 : }
7357 : else
7358 : {
7359 : /* We end up here if the argument type is larger than 'long long'.
7360 : We generate this code:
7361 :
7362 : if (x & (ULL_MAX << ULL_SIZE) != 0)
7363 : return clzll ((unsigned long long) (x >> ULLSIZE));
7364 : else
7365 : return ULL_SIZE + clzll ((unsigned long long) x);
7366 : where ULL_MAX is the largest value that a ULL_MAX can hold
7367 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7368 : is the bit-size of the long long type (64 in this example). */
7369 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7370 :
7371 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7372 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7373 : long_long_unsigned_type_node,
7374 : build_int_cst (long_long_unsigned_type_node,
7375 : 0));
7376 :
7377 30 : cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7378 : fold_convert (arg_type, ullmax), ullsize);
7379 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7380 : arg, cond);
7381 30 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7382 : cond, build_int_cst (arg_type, 0));
7383 :
7384 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7385 : arg, ullsize);
7386 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7387 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7388 30 : tmp1 = fold_convert (result_type,
7389 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7390 :
7391 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7392 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7393 30 : tmp2 = fold_convert (result_type,
7394 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7395 30 : tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7396 : tmp2, ullsize);
7397 :
7398 30 : leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7399 : cond, tmp1, tmp2);
7400 : }
7401 :
7402 : /* Build BIT_SIZE. */
7403 270 : bit_size = build_int_cst (result_type, argsize);
7404 :
7405 270 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7406 : arg, build_int_cst (arg_type, 0));
7407 270 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7408 : bit_size, leadz);
7409 270 : }
7410 :
7411 :
7412 : /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7413 :
7414 : The conditional expression is necessary because the result of TRAILZ(0)
7415 : is defined, but the result of __builtin_ctz(0) is undefined for most
7416 : targets. */
7417 :
7418 : static void
7419 282 : gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7420 : {
7421 282 : tree arg;
7422 282 : tree arg_type;
7423 282 : tree cond;
7424 282 : tree result_type;
7425 282 : tree trailz;
7426 282 : tree bit_size;
7427 282 : tree func;
7428 282 : int argsize;
7429 :
7430 282 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7431 282 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7432 :
7433 : /* Which variant of __builtin_ctz* should we call? */
7434 282 : if (argsize <= INT_TYPE_SIZE)
7435 : {
7436 195 : arg_type = unsigned_type_node;
7437 195 : func = builtin_decl_explicit (BUILT_IN_CTZ);
7438 : }
7439 87 : else if (argsize <= LONG_TYPE_SIZE)
7440 : {
7441 57 : arg_type = long_unsigned_type_node;
7442 57 : func = builtin_decl_explicit (BUILT_IN_CTZL);
7443 : }
7444 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7445 : {
7446 0 : arg_type = long_long_unsigned_type_node;
7447 0 : func = builtin_decl_explicit (BUILT_IN_CTZLL);
7448 : }
7449 : else
7450 : {
7451 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7452 30 : arg_type = gfc_build_uint_type (argsize);
7453 30 : func = NULL_TREE;
7454 : }
7455 :
7456 : /* Convert the actual argument twice: first, to the unsigned type of the
7457 : same size; then, to the proper argument type for the built-in
7458 : function. But the return type is of the default INTEGER kind. */
7459 282 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7460 282 : arg = fold_convert (arg_type, arg);
7461 282 : arg = gfc_evaluate_now (arg, &se->pre);
7462 282 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7463 :
7464 : /* Compute TRAILZ for the case i .ne. 0. */
7465 282 : if (func)
7466 252 : trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7467 : func, 1, arg));
7468 : else
7469 : {
7470 : /* We end up here if the argument type is larger than 'long long'.
7471 : We generate this code:
7472 :
7473 : if ((x & ULL_MAX) == 0)
7474 : return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7475 : else
7476 : return ctzll ((unsigned long long) x);
7477 :
7478 : where ULL_MAX is the largest value that a ULL_MAX can hold
7479 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7480 : is the bit-size of the long long type (64 in this example). */
7481 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7482 :
7483 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7484 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7485 : long_long_unsigned_type_node,
7486 : build_int_cst (long_long_unsigned_type_node, 0));
7487 :
7488 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7489 : fold_convert (arg_type, ullmax));
7490 30 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7491 : build_int_cst (arg_type, 0));
7492 :
7493 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7494 : arg, ullsize);
7495 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7496 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7497 30 : tmp1 = fold_convert (result_type,
7498 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7499 30 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7500 : tmp1, ullsize);
7501 :
7502 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7503 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7504 30 : tmp2 = fold_convert (result_type,
7505 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7506 :
7507 30 : trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7508 : cond, tmp1, tmp2);
7509 : }
7510 :
7511 : /* Build BIT_SIZE. */
7512 282 : bit_size = build_int_cst (result_type, argsize);
7513 :
7514 282 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7515 : arg, build_int_cst (arg_type, 0));
7516 282 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7517 : bit_size, trailz);
7518 282 : }
7519 :
7520 : /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7521 : for types larger than "long long", we call the long long built-in for
7522 : the lower and higher bits and combine the result. */
7523 :
7524 : static void
7525 134 : gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7526 : {
7527 134 : tree arg;
7528 134 : tree arg_type;
7529 134 : tree result_type;
7530 134 : tree func;
7531 134 : int argsize;
7532 :
7533 134 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7534 134 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7535 134 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7536 :
7537 : /* Which variant of the builtin should we call? */
7538 134 : if (argsize <= INT_TYPE_SIZE)
7539 : {
7540 108 : arg_type = unsigned_type_node;
7541 198 : func = builtin_decl_explicit (parity
7542 : ? BUILT_IN_PARITY
7543 : : BUILT_IN_POPCOUNT);
7544 : }
7545 26 : else if (argsize <= LONG_TYPE_SIZE)
7546 : {
7547 12 : arg_type = long_unsigned_type_node;
7548 18 : func = builtin_decl_explicit (parity
7549 : ? BUILT_IN_PARITYL
7550 : : BUILT_IN_POPCOUNTL);
7551 : }
7552 14 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7553 : {
7554 0 : arg_type = long_long_unsigned_type_node;
7555 0 : func = builtin_decl_explicit (parity
7556 : ? BUILT_IN_PARITYLL
7557 : : BUILT_IN_POPCOUNTLL);
7558 : }
7559 : else
7560 : {
7561 : /* Our argument type is larger than 'long long', which mean none
7562 : of the POPCOUNT builtins covers it. We thus call the 'long long'
7563 : variant multiple times, and add the results. */
7564 14 : tree utype, arg2, call1, call2;
7565 :
7566 : /* For now, we only cover the case where argsize is twice as large
7567 : as 'long long'. */
7568 14 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7569 :
7570 21 : func = builtin_decl_explicit (parity
7571 : ? BUILT_IN_PARITYLL
7572 : : BUILT_IN_POPCOUNTLL);
7573 :
7574 : /* Convert it to an integer, and store into a variable. */
7575 14 : utype = gfc_build_uint_type (argsize);
7576 14 : arg = fold_convert (utype, arg);
7577 14 : arg = gfc_evaluate_now (arg, &se->pre);
7578 :
7579 : /* Call the builtin twice. */
7580 14 : call1 = build_call_expr_loc (input_location, func, 1,
7581 : fold_convert (long_long_unsigned_type_node,
7582 : arg));
7583 :
7584 14 : arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7585 : build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7586 14 : call2 = build_call_expr_loc (input_location, func, 1,
7587 : fold_convert (long_long_unsigned_type_node,
7588 : arg2));
7589 :
7590 : /* Combine the results. */
7591 14 : if (parity)
7592 7 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7593 : integer_type_node, call1, call2);
7594 : else
7595 7 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7596 : integer_type_node, call1, call2);
7597 :
7598 14 : se->expr = convert (result_type, se->expr);
7599 14 : return;
7600 : }
7601 :
7602 : /* Convert the actual argument twice: first, to the unsigned type of the
7603 : same size; then, to the proper argument type for the built-in
7604 : function. */
7605 120 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7606 120 : arg = fold_convert (arg_type, arg);
7607 :
7608 120 : se->expr = fold_convert (result_type,
7609 : build_call_expr_loc (input_location, func, 1, arg));
7610 : }
7611 :
7612 :
7613 : /* Process an intrinsic with unspecified argument-types that has an optional
7614 : argument (which could be of type character), e.g. EOSHIFT. For those, we
7615 : need to append the string length of the optional argument if it is not
7616 : present and the type is really character.
7617 : primary specifies the position (starting at 1) of the non-optional argument
7618 : specifying the type and optional gives the position of the optional
7619 : argument in the arglist. */
7620 :
7621 : static void
7622 5867 : conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7623 : unsigned primary, unsigned optional)
7624 : {
7625 5867 : gfc_actual_arglist* prim_arg;
7626 5867 : gfc_actual_arglist* opt_arg;
7627 5867 : unsigned cur_pos;
7628 5867 : gfc_actual_arglist* arg;
7629 5867 : gfc_symbol* sym;
7630 5867 : vec<tree, va_gc> *append_args;
7631 :
7632 : /* Find the two arguments given as position. */
7633 5867 : cur_pos = 0;
7634 5867 : prim_arg = NULL;
7635 5867 : opt_arg = NULL;
7636 17601 : for (arg = expr->value.function.actual; arg; arg = arg->next)
7637 : {
7638 17601 : ++cur_pos;
7639 :
7640 17601 : if (cur_pos == primary)
7641 5867 : prim_arg = arg;
7642 17601 : if (cur_pos == optional)
7643 5867 : opt_arg = arg;
7644 :
7645 17601 : if (cur_pos >= primary && cur_pos >= optional)
7646 : break;
7647 : }
7648 5867 : gcc_assert (prim_arg);
7649 5867 : gcc_assert (prim_arg->expr);
7650 5867 : gcc_assert (opt_arg);
7651 :
7652 : /* If we do have type CHARACTER and the optional argument is really absent,
7653 : append a dummy 0 as string length. */
7654 5867 : append_args = NULL;
7655 5867 : if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7656 : {
7657 608 : tree dummy;
7658 :
7659 608 : dummy = build_int_cst (gfc_charlen_type_node, 0);
7660 608 : vec_alloc (append_args, 1);
7661 608 : append_args->quick_push (dummy);
7662 : }
7663 :
7664 : /* Build the call itself. */
7665 5867 : gcc_assert (!se->ignore_optional);
7666 5867 : sym = gfc_get_symbol_for_expr (expr, false);
7667 5867 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7668 : append_args);
7669 5867 : gfc_free_symbol (sym);
7670 5867 : }
7671 :
7672 : /* The length of a character string. */
7673 : static void
7674 5898 : gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7675 : {
7676 5898 : tree len;
7677 5898 : tree type;
7678 5898 : tree decl;
7679 5898 : gfc_symbol *sym;
7680 5898 : gfc_se argse;
7681 5898 : gfc_expr *arg;
7682 :
7683 5898 : gcc_assert (!se->ss);
7684 :
7685 5898 : arg = expr->value.function.actual->expr;
7686 :
7687 5898 : type = gfc_typenode_for_spec (&expr->ts);
7688 5898 : switch (arg->expr_type)
7689 : {
7690 0 : case EXPR_CONSTANT:
7691 0 : len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7692 0 : break;
7693 :
7694 2 : case EXPR_ARRAY:
7695 : /* If there is an explicit type-spec, use it. */
7696 2 : if (arg->ts.u.cl->length && arg->ts.u.cl->length_from_typespec)
7697 : {
7698 0 : gfc_conv_string_length (arg->ts.u.cl, arg, &se->pre);
7699 0 : len = arg->ts.u.cl->backend_decl;
7700 0 : break;
7701 : }
7702 :
7703 : /* Obtain the string length from the function used by
7704 : trans-array.cc(gfc_trans_array_constructor). */
7705 2 : len = NULL_TREE;
7706 2 : get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7707 2 : break;
7708 :
7709 5311 : case EXPR_VARIABLE:
7710 5311 : if (arg->ref == NULL
7711 2398 : || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7712 : {
7713 : /* This doesn't catch all cases.
7714 : See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7715 : and the surrounding thread. */
7716 4778 : sym = arg->symtree->n.sym;
7717 4778 : decl = gfc_get_symbol_decl (sym);
7718 4778 : if (decl == current_function_decl && sym->attr.function
7719 55 : && (sym->result == sym))
7720 55 : decl = gfc_get_fake_result_decl (sym, 0);
7721 :
7722 4778 : len = sym->ts.u.cl->backend_decl;
7723 4778 : gcc_assert (len);
7724 : break;
7725 : }
7726 :
7727 : /* Fall through. */
7728 :
7729 1118 : default:
7730 1118 : gfc_init_se (&argse, se);
7731 1118 : if (arg->rank == 0)
7732 996 : gfc_conv_expr (&argse, arg);
7733 : else
7734 122 : gfc_conv_expr_descriptor (&argse, arg);
7735 1118 : gfc_add_block_to_block (&se->pre, &argse.pre);
7736 1118 : gfc_add_block_to_block (&se->post, &argse.post);
7737 1118 : len = argse.string_length;
7738 1118 : break;
7739 : }
7740 5898 : se->expr = convert (type, len);
7741 5898 : }
7742 :
7743 : /* The length of a character string not including trailing blanks. */
7744 : static void
7745 2340 : gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7746 : {
7747 2340 : int kind = expr->value.function.actual->expr->ts.kind;
7748 2340 : tree args[2], type, fndecl;
7749 :
7750 2340 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7751 2340 : type = gfc_typenode_for_spec (&expr->ts);
7752 :
7753 2340 : if (kind == 1)
7754 1938 : fndecl = gfor_fndecl_string_len_trim;
7755 402 : else if (kind == 4)
7756 402 : fndecl = gfor_fndecl_string_len_trim_char4;
7757 : else
7758 0 : gcc_unreachable ();
7759 :
7760 2340 : se->expr = build_call_expr_loc (input_location,
7761 : fndecl, 2, args[0], args[1]);
7762 2340 : se->expr = convert (type, se->expr);
7763 2340 : }
7764 :
7765 :
7766 : /* Returns the starting position of a substring within a string. */
7767 :
7768 : static void
7769 751 : gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7770 : tree function)
7771 : {
7772 751 : tree logical4_type_node = gfc_get_logical_type (4);
7773 751 : tree type;
7774 751 : tree fndecl;
7775 751 : tree *args;
7776 751 : unsigned int num_args;
7777 :
7778 751 : args = XALLOCAVEC (tree, 5);
7779 :
7780 : /* Get number of arguments; characters count double due to the
7781 : string length argument. Kind= is not passed to the library
7782 : and thus ignored. */
7783 751 : if (expr->value.function.actual->next->next->expr == NULL)
7784 : num_args = 4;
7785 : else
7786 304 : num_args = 5;
7787 :
7788 751 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7789 751 : type = gfc_typenode_for_spec (&expr->ts);
7790 :
7791 751 : if (num_args == 4)
7792 447 : args[4] = build_int_cst (logical4_type_node, 0);
7793 : else
7794 304 : args[4] = convert (logical4_type_node, args[4]);
7795 :
7796 751 : fndecl = build_addr (function);
7797 751 : se->expr = build_call_array_loc (input_location,
7798 751 : TREE_TYPE (TREE_TYPE (function)), fndecl,
7799 : 5, args);
7800 751 : se->expr = convert (type, se->expr);
7801 :
7802 751 : }
7803 :
7804 : /* The ascii value for a single character. */
7805 : static void
7806 2033 : gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7807 : {
7808 2033 : tree args[3], type, pchartype;
7809 2033 : int nargs;
7810 :
7811 2033 : nargs = gfc_intrinsic_argument_list_length (expr);
7812 2033 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7813 2033 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7814 2033 : pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7815 2033 : args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7816 2033 : type = gfc_typenode_for_spec (&expr->ts);
7817 :
7818 2033 : se->expr = build_fold_indirect_ref_loc (input_location,
7819 : args[1]);
7820 2033 : se->expr = convert (type, se->expr);
7821 2033 : }
7822 :
7823 :
7824 : /* Intrinsic ISNAN calls __builtin_isnan. */
7825 :
7826 : static void
7827 432 : gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7828 : {
7829 432 : tree arg;
7830 :
7831 432 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7832 432 : se->expr = build_call_expr_loc (input_location,
7833 : builtin_decl_explicit (BUILT_IN_ISNAN),
7834 : 1, arg);
7835 864 : STRIP_TYPE_NOPS (se->expr);
7836 432 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7837 432 : }
7838 :
7839 :
7840 : /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7841 : their argument against a constant integer value. */
7842 :
7843 : static void
7844 24 : gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7845 : {
7846 24 : tree arg;
7847 :
7848 24 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7849 24 : se->expr = fold_build2_loc (input_location, EQ_EXPR,
7850 : gfc_typenode_for_spec (&expr->ts),
7851 24 : arg, build_int_cst (TREE_TYPE (arg), value));
7852 24 : }
7853 :
7854 :
7855 :
7856 : /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7857 :
7858 : static void
7859 949 : gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7860 : {
7861 949 : tree tsource;
7862 949 : tree fsource;
7863 949 : tree mask;
7864 949 : tree type;
7865 949 : tree len, len2;
7866 949 : tree *args;
7867 949 : unsigned int num_args;
7868 :
7869 949 : num_args = gfc_intrinsic_argument_list_length (expr);
7870 949 : args = XALLOCAVEC (tree, num_args);
7871 :
7872 949 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7873 949 : if (expr->ts.type != BT_CHARACTER)
7874 : {
7875 422 : tsource = args[0];
7876 422 : fsource = args[1];
7877 422 : mask = args[2];
7878 : }
7879 : else
7880 : {
7881 : /* We do the same as in the non-character case, but the argument
7882 : list is different because of the string length arguments. We
7883 : also have to set the string length for the result. */
7884 527 : len = args[0];
7885 527 : tsource = args[1];
7886 527 : len2 = args[2];
7887 527 : fsource = args[3];
7888 527 : mask = args[4];
7889 :
7890 527 : gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7891 : &se->pre);
7892 527 : se->string_length = len;
7893 : }
7894 949 : tsource = gfc_evaluate_now (tsource, &se->pre);
7895 949 : fsource = gfc_evaluate_now (fsource, &se->pre);
7896 949 : mask = gfc_evaluate_now (mask, &se->pre);
7897 949 : type = TREE_TYPE (tsource);
7898 949 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7899 : fold_convert (type, fsource));
7900 949 : }
7901 :
7902 :
7903 : /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7904 :
7905 : static void
7906 42 : gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7907 : {
7908 42 : tree args[3], mask, type;
7909 :
7910 42 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
7911 42 : mask = gfc_evaluate_now (args[2], &se->pre);
7912 :
7913 42 : type = TREE_TYPE (args[0]);
7914 42 : gcc_assert (TREE_TYPE (args[1]) == type);
7915 42 : gcc_assert (TREE_TYPE (mask) == type);
7916 :
7917 42 : args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7918 42 : args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7919 : fold_build1_loc (input_location, BIT_NOT_EXPR,
7920 : type, mask));
7921 42 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7922 : args[0], args[1]);
7923 42 : }
7924 :
7925 :
7926 : /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7927 : MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7928 :
7929 : static void
7930 64 : gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7931 : {
7932 64 : tree arg, allones, type, utype, res, cond, bitsize;
7933 64 : int i;
7934 :
7935 64 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7936 64 : arg = gfc_evaluate_now (arg, &se->pre);
7937 :
7938 64 : type = gfc_get_int_type (expr->ts.kind);
7939 64 : utype = unsigned_type_for (type);
7940 :
7941 64 : i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7942 64 : bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7943 :
7944 64 : allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7945 : build_int_cst (utype, 0));
7946 :
7947 64 : if (left)
7948 : {
7949 : /* Left-justified mask. */
7950 32 : res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7951 : bitsize, arg);
7952 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7953 : fold_convert (utype, res));
7954 :
7955 : /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7956 : smaller than type width. */
7957 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7958 32 : build_int_cst (TREE_TYPE (arg), 0));
7959 32 : res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7960 : build_int_cst (utype, 0), res);
7961 : }
7962 : else
7963 : {
7964 : /* Right-justified mask. */
7965 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7966 : fold_convert (utype, arg));
7967 32 : res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7968 :
7969 : /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7970 : strictly smaller than type width. */
7971 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7972 : arg, bitsize);
7973 32 : res = fold_build3_loc (input_location, COND_EXPR, utype,
7974 : cond, allones, res);
7975 : }
7976 :
7977 64 : se->expr = fold_convert (type, res);
7978 64 : }
7979 :
7980 :
7981 : /* FRACTION (s) is translated into:
7982 : isfinite (s) ? frexp (s, &dummy_int) : NaN */
7983 : static void
7984 60 : gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7985 : {
7986 60 : tree arg, type, tmp, res, frexp, cond;
7987 :
7988 60 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7989 :
7990 60 : type = gfc_typenode_for_spec (&expr->ts);
7991 60 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7992 60 : arg = gfc_evaluate_now (arg, &se->pre);
7993 :
7994 60 : cond = build_call_expr_loc (input_location,
7995 : builtin_decl_explicit (BUILT_IN_ISFINITE),
7996 : 1, arg);
7997 :
7998 60 : tmp = gfc_create_var (integer_type_node, NULL);
7999 60 : res = build_call_expr_loc (input_location, frexp, 2,
8000 : fold_convert (type, arg),
8001 : gfc_build_addr_expr (NULL_TREE, tmp));
8002 60 : res = fold_convert (type, res);
8003 :
8004 60 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
8005 : cond, res, gfc_build_nan (type, ""));
8006 60 : }
8007 :
8008 :
8009 : /* NEAREST (s, dir) is translated into
8010 : tmp = copysign (HUGE_VAL, dir);
8011 : return nextafter (s, tmp);
8012 : */
8013 : static void
8014 1595 : gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
8015 : {
8016 1595 : tree args[2], type, tmp, nextafter, copysign, huge_val;
8017 :
8018 1595 : nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
8019 1595 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
8020 :
8021 1595 : type = gfc_typenode_for_spec (&expr->ts);
8022 1595 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8023 :
8024 1595 : huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
8025 1595 : tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
8026 : fold_convert (type, args[1]));
8027 1595 : se->expr = build_call_expr_loc (input_location, nextafter, 2,
8028 : fold_convert (type, args[0]), tmp);
8029 1595 : se->expr = fold_convert (type, se->expr);
8030 1595 : }
8031 :
8032 :
8033 : /* SPACING (s) is translated into
8034 : int e;
8035 : if (!isfinite (s))
8036 : res = NaN;
8037 : else if (s == 0)
8038 : res = tiny;
8039 : else
8040 : {
8041 : frexp (s, &e);
8042 : e = e - prec;
8043 : e = MAX_EXPR (e, emin);
8044 : res = scalbn (1., e);
8045 : }
8046 : return res;
8047 :
8048 : where prec is the precision of s, gfc_real_kinds[k].digits,
8049 : emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
8050 : and tiny is tiny(s), gfc_real_kinds[k].tiny. */
8051 :
8052 : static void
8053 70 : gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
8054 : {
8055 70 : tree arg, type, prec, emin, tiny, res, e;
8056 70 : tree cond, nan, tmp, frexp, scalbn;
8057 70 : int k;
8058 70 : stmtblock_t block;
8059 :
8060 70 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8061 70 : prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
8062 70 : emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
8063 70 : tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
8064 :
8065 70 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8066 70 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8067 :
8068 70 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8069 70 : arg = gfc_evaluate_now (arg, &se->pre);
8070 :
8071 70 : type = gfc_typenode_for_spec (&expr->ts);
8072 70 : e = gfc_create_var (integer_type_node, NULL);
8073 70 : res = gfc_create_var (type, NULL);
8074 :
8075 :
8076 : /* Build the block for s /= 0. */
8077 70 : gfc_start_block (&block);
8078 70 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8079 : gfc_build_addr_expr (NULL_TREE, e));
8080 70 : gfc_add_expr_to_block (&block, tmp);
8081 :
8082 70 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
8083 : prec);
8084 70 : gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
8085 : integer_type_node, tmp, emin));
8086 :
8087 70 : tmp = build_call_expr_loc (input_location, scalbn, 2,
8088 70 : build_real_from_int_cst (type, integer_one_node), e);
8089 70 : gfc_add_modify (&block, res, tmp);
8090 :
8091 : /* Finish by building the IF statement for value zero. */
8092 70 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8093 70 : build_real_from_int_cst (type, integer_zero_node));
8094 70 : tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
8095 : gfc_finish_block (&block));
8096 :
8097 : /* And deal with infinities and NaNs. */
8098 70 : cond = build_call_expr_loc (input_location,
8099 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8100 : 1, arg);
8101 70 : nan = gfc_build_nan (type, "");
8102 70 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
8103 :
8104 70 : gfc_add_expr_to_block (&se->pre, tmp);
8105 70 : se->expr = res;
8106 70 : }
8107 :
8108 :
8109 : /* RRSPACING (s) is translated into
8110 : int e;
8111 : real x;
8112 : x = fabs (s);
8113 : if (isfinite (x))
8114 : {
8115 : if (x != 0)
8116 : {
8117 : frexp (s, &e);
8118 : x = scalbn (x, precision - e);
8119 : }
8120 : }
8121 : else
8122 : x = NaN;
8123 : return x;
8124 :
8125 : where precision is gfc_real_kinds[k].digits. */
8126 :
8127 : static void
8128 48 : gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
8129 : {
8130 48 : tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
8131 48 : int prec, k;
8132 48 : stmtblock_t block;
8133 :
8134 48 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8135 48 : prec = gfc_real_kinds[k].digits;
8136 :
8137 48 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8138 48 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8139 48 : fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
8140 :
8141 48 : type = gfc_typenode_for_spec (&expr->ts);
8142 48 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8143 48 : arg = gfc_evaluate_now (arg, &se->pre);
8144 :
8145 48 : e = gfc_create_var (integer_type_node, NULL);
8146 48 : x = gfc_create_var (type, NULL);
8147 48 : gfc_add_modify (&se->pre, x,
8148 : build_call_expr_loc (input_location, fabs, 1, arg));
8149 :
8150 :
8151 48 : gfc_start_block (&block);
8152 48 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8153 : gfc_build_addr_expr (NULL_TREE, e));
8154 48 : gfc_add_expr_to_block (&block, tmp);
8155 :
8156 48 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
8157 48 : build_int_cst (integer_type_node, prec), e);
8158 48 : tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
8159 48 : gfc_add_modify (&block, x, tmp);
8160 48 : stmt = gfc_finish_block (&block);
8161 :
8162 : /* if (x != 0) */
8163 48 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
8164 48 : build_real_from_int_cst (type, integer_zero_node));
8165 48 : tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
8166 :
8167 : /* And deal with infinities and NaNs. */
8168 48 : cond = build_call_expr_loc (input_location,
8169 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8170 : 1, x);
8171 48 : nan = gfc_build_nan (type, "");
8172 48 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
8173 :
8174 48 : gfc_add_expr_to_block (&se->pre, tmp);
8175 48 : se->expr = fold_convert (type, x);
8176 48 : }
8177 :
8178 :
8179 : /* SCALE (s, i) is translated into scalbn (s, i). */
8180 : static void
8181 72 : gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
8182 : {
8183 72 : tree args[2], type, scalbn;
8184 :
8185 72 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8186 :
8187 72 : type = gfc_typenode_for_spec (&expr->ts);
8188 72 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8189 72 : se->expr = build_call_expr_loc (input_location, scalbn, 2,
8190 : fold_convert (type, args[0]),
8191 : fold_convert (integer_type_node, args[1]));
8192 72 : se->expr = fold_convert (type, se->expr);
8193 72 : }
8194 :
8195 :
8196 : /* SET_EXPONENT (s, i) is translated into
8197 : isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
8198 : static void
8199 262 : gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
8200 : {
8201 262 : tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
8202 :
8203 262 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8204 262 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8205 :
8206 262 : type = gfc_typenode_for_spec (&expr->ts);
8207 262 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8208 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
8209 :
8210 262 : tmp = gfc_create_var (integer_type_node, NULL);
8211 262 : tmp = build_call_expr_loc (input_location, frexp, 2,
8212 : fold_convert (type, args[0]),
8213 : gfc_build_addr_expr (NULL_TREE, tmp));
8214 262 : res = build_call_expr_loc (input_location, scalbn, 2, tmp,
8215 : fold_convert (integer_type_node, args[1]));
8216 262 : res = fold_convert (type, res);
8217 :
8218 : /* Call to isfinite */
8219 262 : cond = build_call_expr_loc (input_location,
8220 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8221 : 1, args[0]);
8222 262 : nan = gfc_build_nan (type, "");
8223 :
8224 262 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
8225 : res, nan);
8226 262 : }
8227 :
8228 :
8229 : static void
8230 15517 : gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
8231 : {
8232 15517 : gfc_actual_arglist *actual;
8233 15517 : tree arg1;
8234 15517 : tree type;
8235 15517 : tree size;
8236 15517 : gfc_se argse;
8237 15517 : gfc_expr *e;
8238 15517 : gfc_symbol *sym = NULL;
8239 :
8240 15517 : gfc_init_se (&argse, NULL);
8241 15517 : actual = expr->value.function.actual;
8242 :
8243 15517 : if (actual->expr->ts.type == BT_CLASS)
8244 627 : gfc_add_class_array_ref (actual->expr);
8245 :
8246 15517 : e = actual->expr;
8247 :
8248 : /* These are emerging from the interface mapping, when a class valued
8249 : function appears as the rhs in a realloc on assign statement, where
8250 : the size of the result is that of one of the actual arguments. */
8251 15517 : if (e->expr_type == EXPR_VARIABLE
8252 15041 : && e->symtree->n.sym->ns == NULL /* This is distinctive! */
8253 573 : && e->symtree->n.sym->ts.type == BT_CLASS
8254 62 : && e->ref && e->ref->type == REF_COMPONENT
8255 44 : && strcmp (e->ref->u.c.component->name, "_data") == 0)
8256 15517 : sym = e->symtree->n.sym;
8257 :
8258 15517 : if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
8259 : && e
8260 854 : && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
8261 : {
8262 854 : symbol_attribute attr;
8263 854 : char *msg;
8264 854 : tree temp;
8265 854 : tree cond;
8266 :
8267 854 : if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
8268 : {
8269 33 : attr = CLASS_DATA (e->symtree->n.sym)->attr;
8270 33 : attr.pointer = attr.class_pointer;
8271 : }
8272 : else
8273 821 : attr = gfc_expr_attr (e);
8274 :
8275 854 : if (attr.allocatable)
8276 100 : msg = xasprintf ("Allocatable argument '%s' is not allocated",
8277 100 : e->symtree->n.sym->name);
8278 754 : else if (attr.pointer)
8279 46 : msg = xasprintf ("Pointer argument '%s' is not associated",
8280 46 : e->symtree->n.sym->name);
8281 : else
8282 708 : goto end_arg_check;
8283 :
8284 146 : if (sym)
8285 : {
8286 0 : temp = gfc_class_data_get (sym->backend_decl);
8287 0 : temp = gfc_conv_descriptor_data_get (temp);
8288 : }
8289 : else
8290 : {
8291 146 : argse.descriptor_only = 1;
8292 146 : gfc_conv_expr_descriptor (&argse, actual->expr);
8293 146 : temp = gfc_conv_descriptor_data_get (argse.expr);
8294 : }
8295 :
8296 146 : cond = fold_build2_loc (input_location, EQ_EXPR,
8297 : logical_type_node, temp,
8298 146 : fold_convert (TREE_TYPE (temp),
8299 : null_pointer_node));
8300 146 : gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
8301 :
8302 146 : free (msg);
8303 : }
8304 14663 : end_arg_check:
8305 :
8306 15517 : argse.data_not_needed = 1;
8307 15517 : if (gfc_is_class_array_function (e))
8308 : {
8309 : /* For functions that return a class array conv_expr_descriptor is not
8310 : able to get the descriptor right. Therefore this special case. */
8311 7 : gfc_conv_expr_reference (&argse, e);
8312 7 : argse.expr = gfc_class_data_get (argse.expr);
8313 : }
8314 15510 : else if (sym && sym->backend_decl)
8315 : {
8316 32 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8317 32 : argse.expr = gfc_class_data_get (sym->backend_decl);
8318 : }
8319 : else
8320 15478 : gfc_conv_expr_descriptor (&argse, actual->expr);
8321 15517 : gfc_add_block_to_block (&se->pre, &argse.pre);
8322 15517 : gfc_add_block_to_block (&se->post, &argse.post);
8323 15517 : arg1 = argse.expr;
8324 :
8325 15517 : actual = actual->next;
8326 15517 : if (actual->expr)
8327 : {
8328 9301 : stmtblock_t block;
8329 9301 : gfc_init_block (&block);
8330 9301 : gfc_init_se (&argse, NULL);
8331 9301 : gfc_conv_expr_type (&argse, actual->expr,
8332 : gfc_array_index_type);
8333 9301 : gfc_add_block_to_block (&block, &argse.pre);
8334 9301 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8335 : argse.expr, gfc_index_one_node);
8336 9301 : size = gfc_tree_array_size (&block, arg1, e, tmp);
8337 :
8338 : /* Unusually, for an intrinsic, size does not exclude
8339 : an optional arg2, so we must test for it. */
8340 9301 : if (actual->expr->expr_type == EXPR_VARIABLE
8341 2565 : && actual->expr->symtree->n.sym->attr.dummy
8342 31 : && actual->expr->symtree->n.sym->attr.optional)
8343 : {
8344 31 : tree cond;
8345 31 : stmtblock_t block2;
8346 31 : gfc_init_block (&block2);
8347 31 : gfc_init_se (&argse, NULL);
8348 31 : argse.want_pointer = 1;
8349 31 : argse.data_not_needed = 1;
8350 31 : gfc_conv_expr (&argse, actual->expr);
8351 31 : gfc_add_block_to_block (&se->pre, &argse.pre);
8352 : /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8353 : case; size_var can be used in both blocks. */
8354 31 : tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8355 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8356 31 : TREE_TYPE (size_var), size_var, size);
8357 31 : gfc_add_expr_to_block (&block, tmp);
8358 31 : size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8359 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8360 31 : TREE_TYPE (size_var), size_var, size);
8361 31 : gfc_add_expr_to_block (&block2, tmp);
8362 31 : cond = gfc_conv_expr_present (actual->expr->symtree->n.sym);
8363 31 : tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8364 : gfc_finish_block (&block2));
8365 31 : gfc_add_expr_to_block (&se->pre, tmp);
8366 31 : size = size_var;
8367 31 : }
8368 : else
8369 9270 : gfc_add_block_to_block (&se->pre, &block);
8370 : }
8371 : else
8372 6216 : size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8373 15517 : type = gfc_typenode_for_spec (&expr->ts);
8374 15517 : se->expr = convert (type, size);
8375 15517 : }
8376 :
8377 :
8378 : /* Helper function to compute the size of a character variable,
8379 : excluding the terminating null characters. The result has
8380 : gfc_array_index_type type. */
8381 :
8382 : tree
8383 1894 : size_of_string_in_bytes (int kind, tree string_length)
8384 : {
8385 1894 : tree bytesize;
8386 1894 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8387 :
8388 3788 : bytesize = build_int_cst (gfc_array_index_type,
8389 1894 : gfc_character_kinds[i].bit_size / 8);
8390 :
8391 1894 : return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8392 : bytesize,
8393 1894 : fold_convert (gfc_array_index_type, string_length));
8394 : }
8395 :
8396 :
8397 : static void
8398 1309 : gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8399 : {
8400 1309 : gfc_expr *arg;
8401 1309 : gfc_se argse;
8402 1309 : tree source_bytes;
8403 1309 : tree tmp;
8404 1309 : tree lower;
8405 1309 : tree upper;
8406 1309 : tree byte_size;
8407 1309 : int n;
8408 :
8409 1309 : gfc_init_se (&argse, NULL);
8410 1309 : arg = expr->value.function.actual->expr;
8411 :
8412 1309 : if (arg->rank || arg->ts.type == BT_ASSUMED)
8413 1012 : gfc_conv_expr_descriptor (&argse, arg);
8414 : else
8415 297 : gfc_conv_expr_reference (&argse, arg);
8416 :
8417 1309 : if (arg->ts.type == BT_ASSUMED)
8418 : {
8419 : /* This only works if an array descriptor has been passed; thus, extract
8420 : the size from the descriptor. */
8421 172 : gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8422 : == TYPE_PRECISION (size_type_node));
8423 172 : tmp = arg->symtree->n.sym->backend_decl;
8424 172 : tmp = DECL_LANG_SPECIFIC (tmp)
8425 60 : && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8426 226 : ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8427 172 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8428 172 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8429 :
8430 172 : tmp = gfc_conv_descriptor_elem_len_get (tmp);
8431 :
8432 172 : byte_size = fold_convert (gfc_array_index_type, tmp);
8433 : }
8434 1137 : else if (arg->ts.type == BT_CLASS)
8435 : {
8436 : /* Conv_expr_descriptor returns a component_ref to _data component of the
8437 : class object. The class object may be a non-pointer object, e.g.
8438 : located on the stack, or a memory location pointed to, e.g. a
8439 : parameter, i.e., an indirect_ref. */
8440 959 : if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8441 589 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8442 198 : byte_size
8443 198 : = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8444 391 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8445 0 : byte_size = gfc_class_vtab_size_get (argse.expr);
8446 391 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8447 391 : && TREE_CODE (argse.expr) == COMPONENT_REF)
8448 328 : byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8449 63 : else if (arg->rank > 0
8450 21 : || (arg->rank == 0
8451 21 : && arg->ref && arg->ref->type == REF_COMPONENT))
8452 : {
8453 : /* The scalarizer added an additional temp. To get the class' vptr
8454 : one has to look at the original backend_decl. */
8455 63 : if (argse.class_container)
8456 21 : byte_size = gfc_class_vtab_size_get (argse.class_container);
8457 42 : else if (DECL_LANG_SPECIFIC (arg->symtree->n.sym->backend_decl))
8458 84 : byte_size = gfc_class_vtab_size_get (
8459 42 : GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8460 : else
8461 0 : gcc_unreachable ();
8462 : }
8463 : else
8464 0 : gcc_unreachable ();
8465 : }
8466 : else
8467 : {
8468 548 : if (arg->ts.type == BT_CHARACTER)
8469 84 : byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8470 : else
8471 : {
8472 464 : if (arg->rank == 0)
8473 0 : byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8474 : argse.expr));
8475 : else
8476 464 : byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8477 464 : byte_size = fold_convert (gfc_array_index_type,
8478 : size_in_bytes (byte_size));
8479 : }
8480 : }
8481 :
8482 1309 : if (arg->rank == 0)
8483 297 : se->expr = byte_size;
8484 : else
8485 : {
8486 1012 : source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8487 1012 : gfc_add_modify (&argse.pre, source_bytes, byte_size);
8488 :
8489 1012 : if (arg->rank == -1)
8490 : {
8491 365 : tree cond, loop_var, exit_label;
8492 365 : stmtblock_t body;
8493 :
8494 365 : tmp = gfc_conv_descriptor_rank_get (argse.expr);
8495 365 : loop_var = gfc_create_var (gfc_array_dim_rank_type, "i");
8496 365 : gfc_add_modify (&argse.pre, loop_var, gfc_rank_cst[0]);
8497 365 : exit_label = gfc_build_label_decl (NULL_TREE);
8498 :
8499 : /* Create loop:
8500 : for (;;)
8501 : {
8502 : if (i >= rank)
8503 : goto exit;
8504 : source_bytes = source_bytes * array.dim[i].extent;
8505 : i = i + 1;
8506 : }
8507 : exit: */
8508 365 : gfc_start_block (&body);
8509 365 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8510 : loop_var, tmp);
8511 365 : tmp = build1_v (GOTO_EXPR, exit_label);
8512 365 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8513 : cond, tmp, build_empty_stmt (input_location));
8514 365 : gfc_add_expr_to_block (&body, tmp);
8515 :
8516 365 : lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8517 365 : upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8518 365 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8519 365 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8520 : gfc_array_index_type, tmp, source_bytes);
8521 365 : gfc_add_modify (&body, source_bytes, tmp);
8522 :
8523 365 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8524 : gfc_array_dim_rank_type, loop_var,
8525 : gfc_rank_cst[1]);
8526 365 : gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8527 :
8528 365 : tmp = gfc_finish_block (&body);
8529 :
8530 365 : tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8531 : tmp);
8532 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8533 :
8534 365 : tmp = build1_v (LABEL_EXPR, exit_label);
8535 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8536 : }
8537 : else
8538 : {
8539 : /* Obtain the size of the array in bytes. */
8540 1834 : for (n = 0; n < arg->rank; n++)
8541 : {
8542 1187 : tree idx;
8543 1187 : idx = gfc_rank_cst[n];
8544 1187 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8545 1187 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8546 1187 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8547 1187 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8548 : gfc_array_index_type, tmp, source_bytes);
8549 1187 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8550 : }
8551 : }
8552 1012 : se->expr = source_bytes;
8553 : }
8554 :
8555 1309 : gfc_add_block_to_block (&se->pre, &argse.pre);
8556 1309 : }
8557 :
8558 :
8559 : static void
8560 865 : gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8561 : {
8562 865 : gfc_expr *arg;
8563 865 : gfc_se argse;
8564 865 : tree type, result_type, tmp, class_decl = NULL;
8565 865 : gfc_symbol *sym;
8566 865 : bool unlimited = false;
8567 :
8568 865 : arg = expr->value.function.actual->expr;
8569 :
8570 865 : gfc_init_se (&argse, NULL);
8571 865 : result_type = gfc_get_int_type (expr->ts.kind);
8572 :
8573 865 : if (arg->rank == 0)
8574 : {
8575 236 : if (arg->ts.type == BT_CLASS)
8576 : {
8577 86 : unlimited = UNLIMITED_POLY (arg);
8578 86 : gfc_add_vptr_component (arg);
8579 86 : gfc_add_size_component (arg);
8580 86 : gfc_conv_expr (&argse, arg);
8581 86 : tmp = fold_convert (result_type, argse.expr);
8582 86 : class_decl = gfc_get_class_from_expr (argse.expr);
8583 86 : goto done;
8584 : }
8585 :
8586 150 : gfc_conv_expr_reference (&argse, arg);
8587 150 : type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8588 : argse.expr));
8589 : }
8590 : else
8591 : {
8592 629 : argse.want_pointer = 0;
8593 629 : gfc_conv_expr_descriptor (&argse, arg);
8594 629 : sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
8595 629 : if (arg->ts.type == BT_CLASS)
8596 : {
8597 60 : unlimited = UNLIMITED_POLY (arg);
8598 60 : if (TREE_CODE (argse.expr) == COMPONENT_REF)
8599 54 : tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8600 6 : else if (arg->rank > 0 && sym
8601 12 : && DECL_LANG_SPECIFIC (sym->backend_decl))
8602 12 : tmp = gfc_class_vtab_size_get (
8603 6 : GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
8604 : else
8605 0 : gcc_unreachable ();
8606 60 : tmp = fold_convert (result_type, tmp);
8607 60 : class_decl = gfc_get_class_from_expr (argse.expr);
8608 60 : goto done;
8609 : }
8610 569 : type = gfc_get_element_type (TREE_TYPE (argse.expr));
8611 : }
8612 :
8613 : /* Obtain the argument's word length. */
8614 719 : if (arg->ts.type == BT_CHARACTER)
8615 241 : tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8616 : else
8617 478 : tmp = size_in_bytes (type);
8618 719 : tmp = fold_convert (result_type, tmp);
8619 :
8620 865 : done:
8621 865 : if (unlimited && class_decl)
8622 68 : tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
8623 :
8624 865 : se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8625 : build_int_cst (result_type, BITS_PER_UNIT));
8626 865 : gfc_add_block_to_block (&se->pre, &argse.pre);
8627 865 : }
8628 :
8629 :
8630 : /* Intrinsic string comparison functions. */
8631 :
8632 : static void
8633 99 : gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8634 : {
8635 99 : tree args[4];
8636 :
8637 99 : gfc_conv_intrinsic_function_args (se, expr, args, 4);
8638 :
8639 99 : se->expr
8640 198 : = gfc_build_compare_string (args[0], args[1], args[2], args[3],
8641 99 : expr->value.function.actual->expr->ts.kind,
8642 : op);
8643 99 : se->expr = fold_build2_loc (input_location, op,
8644 : gfc_typenode_for_spec (&expr->ts), se->expr,
8645 99 : build_int_cst (TREE_TYPE (se->expr), 0));
8646 99 : }
8647 :
8648 : /* Generate a call to the adjustl/adjustr library function. */
8649 : static void
8650 468 : gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8651 : {
8652 468 : tree args[3];
8653 468 : tree len;
8654 468 : tree type;
8655 468 : tree var;
8656 468 : tree tmp;
8657 :
8658 468 : gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
8659 468 : len = args[1];
8660 :
8661 468 : type = TREE_TYPE (args[2]);
8662 468 : var = gfc_conv_string_tmp (se, type, len);
8663 468 : args[0] = var;
8664 :
8665 468 : tmp = build_call_expr_loc (input_location,
8666 : fndecl, 3, args[0], args[1], args[2]);
8667 468 : gfc_add_expr_to_block (&se->pre, tmp);
8668 468 : se->expr = var;
8669 468 : se->string_length = len;
8670 468 : }
8671 :
8672 :
8673 : /* Generate code for the TRANSFER intrinsic:
8674 : For scalar results:
8675 : DEST = TRANSFER (SOURCE, MOLD)
8676 : where:
8677 : typeof<DEST> = typeof<MOLD>
8678 : and:
8679 : MOLD is scalar.
8680 :
8681 : For array results:
8682 : DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8683 : where:
8684 : typeof<DEST> = typeof<MOLD>
8685 : and:
8686 : N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8687 : sizeof (DEST(0) * SIZE). */
8688 : static void
8689 3975 : gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8690 : {
8691 3975 : tree tmp;
8692 3975 : tree tmpdecl;
8693 3975 : tree ptr;
8694 3975 : tree extent;
8695 3975 : tree source;
8696 3975 : tree source_type;
8697 3975 : tree source_bytes;
8698 3975 : tree mold_type;
8699 3975 : tree dest_word_len;
8700 3975 : tree size_words;
8701 3975 : tree size_bytes;
8702 3975 : tree upper;
8703 3975 : tree lower;
8704 3975 : tree stmt;
8705 3975 : tree class_ref = NULL_TREE;
8706 3975 : gfc_actual_arglist *arg;
8707 3975 : gfc_se argse;
8708 3975 : gfc_array_info *info;
8709 3975 : stmtblock_t block;
8710 3975 : int n;
8711 3975 : bool scalar_mold;
8712 3975 : gfc_expr *source_expr, *mold_expr, *class_expr;
8713 :
8714 3975 : info = NULL;
8715 3975 : if (se->loop)
8716 472 : info = &se->ss->info->data.array;
8717 :
8718 : /* Convert SOURCE. The output from this stage is:-
8719 : source_bytes = length of the source in bytes
8720 : source = pointer to the source data. */
8721 3975 : arg = expr->value.function.actual;
8722 3975 : source_expr = arg->expr;
8723 :
8724 : /* Ensure double transfer through LOGICAL preserves all
8725 : the needed bits. */
8726 3975 : if (arg->expr->expr_type == EXPR_FUNCTION
8727 2978 : && arg->expr->value.function.esym == NULL
8728 2954 : && arg->expr->value.function.isym != NULL
8729 2954 : && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8730 12 : && arg->expr->ts.type == BT_LOGICAL
8731 12 : && expr->ts.type != arg->expr->ts.type)
8732 12 : arg->expr->value.function.name = "__transfer_in_transfer";
8733 :
8734 3975 : gfc_init_se (&argse, NULL);
8735 :
8736 3975 : source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8737 :
8738 : /* Obtain the pointer to source and the length of source in bytes. */
8739 3975 : if (arg->expr->rank == 0)
8740 : {
8741 3619 : gfc_conv_expr_reference (&argse, arg->expr);
8742 3619 : if (arg->expr->ts.type == BT_CLASS)
8743 : {
8744 37 : tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8745 37 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8746 : {
8747 19 : source = gfc_class_data_get (tmp);
8748 19 : class_ref = tmp;
8749 : }
8750 : else
8751 : {
8752 : /* Array elements are evaluated as a reference to the data.
8753 : To obtain the vptr for the element size, the argument
8754 : expression must be stripped to the class reference and
8755 : re-evaluated. The pre and post blocks are not needed. */
8756 18 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8757 18 : source = argse.expr;
8758 18 : class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8759 18 : gfc_init_se (&argse, NULL);
8760 18 : gfc_conv_expr (&argse, class_expr);
8761 18 : class_ref = argse.expr;
8762 : }
8763 : }
8764 : else
8765 3582 : source = argse.expr;
8766 :
8767 : /* Obtain the source word length. */
8768 3619 : switch (arg->expr->ts.type)
8769 : {
8770 294 : case BT_CHARACTER:
8771 294 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8772 : argse.string_length);
8773 294 : break;
8774 37 : case BT_CLASS:
8775 37 : if (class_ref != NULL_TREE)
8776 : {
8777 37 : tmp = gfc_class_vtab_size_get (class_ref);
8778 37 : if (UNLIMITED_POLY (source_expr))
8779 30 : tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
8780 : }
8781 : else
8782 : {
8783 0 : tmp = gfc_class_vtab_size_get (argse.expr);
8784 0 : if (UNLIMITED_POLY (source_expr))
8785 0 : tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
8786 : }
8787 : break;
8788 3288 : default:
8789 3288 : source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8790 : source));
8791 3288 : tmp = fold_convert (gfc_array_index_type,
8792 : size_in_bytes (source_type));
8793 3288 : break;
8794 : }
8795 : }
8796 : else
8797 : {
8798 356 : bool simply_contiguous = gfc_is_simply_contiguous (arg->expr,
8799 : false, true);
8800 356 : argse.want_pointer = 0;
8801 : /* A non-contiguous SOURCE needs packing. */
8802 356 : if (!simply_contiguous)
8803 74 : argse.force_tmp = 1;
8804 356 : gfc_conv_expr_descriptor (&argse, arg->expr);
8805 356 : source = gfc_conv_descriptor_data_get (argse.expr);
8806 356 : source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8807 :
8808 : /* Repack the source if not simply contiguous. */
8809 356 : if (!simply_contiguous)
8810 : {
8811 74 : tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8812 :
8813 74 : if (warn_array_temporaries)
8814 0 : gfc_warning (OPT_Warray_temporaries,
8815 : "Creating array temporary at %L", &expr->where);
8816 :
8817 74 : source = build_call_expr_loc (input_location,
8818 : gfor_fndecl_in_pack, 1, tmp);
8819 74 : source = gfc_evaluate_now (source, &argse.pre);
8820 :
8821 : /* Free the temporary. */
8822 74 : gfc_start_block (&block);
8823 74 : tmp = gfc_call_free (source);
8824 74 : gfc_add_expr_to_block (&block, tmp);
8825 74 : stmt = gfc_finish_block (&block);
8826 :
8827 : /* Clean up if it was repacked. */
8828 74 : gfc_init_block (&block);
8829 74 : tmp = gfc_conv_array_data (argse.expr);
8830 74 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8831 : source, tmp);
8832 74 : tmp = build3_v (COND_EXPR, tmp, stmt,
8833 : build_empty_stmt (input_location));
8834 74 : gfc_add_expr_to_block (&block, tmp);
8835 74 : gfc_add_block_to_block (&block, &se->post);
8836 74 : gfc_init_block (&se->post);
8837 74 : gfc_add_block_to_block (&se->post, &block);
8838 : }
8839 :
8840 : /* Obtain the source word length. */
8841 356 : if (arg->expr->ts.type == BT_CHARACTER)
8842 144 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8843 : argse.string_length);
8844 212 : else if (arg->expr->ts.type == BT_CLASS)
8845 : {
8846 54 : if (UNLIMITED_POLY (source_expr)
8847 54 : && DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl))
8848 12 : class_ref = GFC_DECL_SAVED_DESCRIPTOR
8849 : (source_expr->symtree->n.sym->backend_decl);
8850 : else
8851 42 : class_ref = TREE_OPERAND (argse.expr, 0);
8852 54 : tmp = gfc_class_vtab_size_get (class_ref);
8853 54 : if (UNLIMITED_POLY (arg->expr))
8854 54 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8855 : }
8856 : else
8857 158 : tmp = fold_convert (gfc_array_index_type,
8858 : size_in_bytes (source_type));
8859 :
8860 : /* Obtain the size of the array in bytes. */
8861 356 : extent = gfc_create_var (gfc_array_index_type, NULL);
8862 1098 : for (n = 0; n < arg->expr->rank; n++)
8863 : {
8864 386 : tree idx;
8865 386 : idx = gfc_rank_cst[n];
8866 386 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8867 386 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8868 386 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8869 386 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8870 : gfc_array_index_type, upper, lower);
8871 386 : gfc_add_modify (&argse.pre, extent, tmp);
8872 386 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8873 : gfc_array_index_type, extent,
8874 : gfc_index_one_node);
8875 386 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8876 : gfc_array_index_type, tmp, source_bytes);
8877 : }
8878 : }
8879 :
8880 3975 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8881 3975 : gfc_add_block_to_block (&se->pre, &argse.pre);
8882 3975 : gfc_add_block_to_block (&se->post, &argse.post);
8883 :
8884 : /* Now convert MOLD. The outputs are:
8885 : mold_type = the TREE type of MOLD
8886 : dest_word_len = destination word length in bytes. */
8887 3975 : arg = arg->next;
8888 3975 : mold_expr = arg->expr;
8889 :
8890 3975 : gfc_init_se (&argse, NULL);
8891 :
8892 3975 : scalar_mold = arg->expr->rank == 0;
8893 :
8894 3975 : if (arg->expr->rank == 0)
8895 : {
8896 3652 : gfc_conv_expr_reference (&argse, mold_expr);
8897 3652 : mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8898 : argse.expr));
8899 : }
8900 : else
8901 : {
8902 323 : argse.want_pointer = 0;
8903 323 : gfc_conv_expr_descriptor (&argse, mold_expr);
8904 323 : mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8905 : }
8906 :
8907 3975 : gfc_add_block_to_block (&se->pre, &argse.pre);
8908 3975 : gfc_add_block_to_block (&se->post, &argse.post);
8909 :
8910 3975 : if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8911 : {
8912 : /* If this TRANSFER is nested in another TRANSFER, use a type
8913 : that preserves all bits. */
8914 12 : if (mold_expr->ts.type == BT_LOGICAL)
8915 12 : mold_type = gfc_get_int_type (mold_expr->ts.kind);
8916 : }
8917 :
8918 : /* Obtain the destination word length. */
8919 3975 : switch (mold_expr->ts.type)
8920 : {
8921 467 : case BT_CHARACTER:
8922 467 : tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length);
8923 467 : mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
8924 : argse.string_length);
8925 467 : break;
8926 6 : case BT_CLASS:
8927 6 : if (scalar_mold)
8928 6 : class_ref = argse.expr;
8929 : else
8930 0 : class_ref = TREE_OPERAND (argse.expr, 0);
8931 6 : tmp = gfc_class_vtab_size_get (class_ref);
8932 6 : if (UNLIMITED_POLY (arg->expr))
8933 0 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8934 : break;
8935 3502 : default:
8936 3502 : tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8937 3502 : break;
8938 : }
8939 :
8940 : /* Do not fix dest_word_len if it is a variable, since the temporary can wind
8941 : up being used before the assignment. */
8942 3975 : if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
8943 : dest_word_len = tmp;
8944 : else
8945 : {
8946 3921 : dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8947 3921 : gfc_add_modify (&se->pre, dest_word_len, tmp);
8948 : }
8949 :
8950 : /* Finally convert SIZE, if it is present. */
8951 3975 : arg = arg->next;
8952 3975 : size_words = gfc_create_var (gfc_array_index_type, NULL);
8953 :
8954 3975 : if (arg->expr)
8955 : {
8956 222 : gfc_init_se (&argse, NULL);
8957 222 : gfc_conv_expr_reference (&argse, arg->expr);
8958 222 : tmp = convert (gfc_array_index_type,
8959 : build_fold_indirect_ref_loc (input_location,
8960 : argse.expr));
8961 222 : gfc_add_block_to_block (&se->pre, &argse.pre);
8962 222 : gfc_add_block_to_block (&se->post, &argse.post);
8963 : }
8964 : else
8965 : tmp = NULL_TREE;
8966 :
8967 : /* Separate array and scalar results. */
8968 3975 : if (scalar_mold && tmp == NULL_TREE)
8969 3503 : goto scalar_transfer;
8970 :
8971 472 : size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8972 472 : if (tmp != NULL_TREE)
8973 222 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8974 : tmp, dest_word_len);
8975 : else
8976 : tmp = source_bytes;
8977 :
8978 472 : gfc_add_modify (&se->pre, size_bytes, tmp);
8979 472 : gfc_add_modify (&se->pre, size_words,
8980 : fold_build2_loc (input_location, CEIL_DIV_EXPR,
8981 : gfc_array_index_type,
8982 : size_bytes, dest_word_len));
8983 :
8984 : /* Evaluate the bounds of the result. If the loop range exists, we have
8985 : to check if it is too large. If so, we modify loop->to be consistent
8986 : with min(size, size(source)). Otherwise, size is made consistent with
8987 : the loop range, so that the right number of bytes is transferred.*/
8988 472 : n = se->loop->order[0];
8989 472 : if (se->loop->to[n] != NULL_TREE)
8990 : {
8991 205 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8992 : se->loop->to[n], se->loop->from[n]);
8993 205 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8994 : tmp, gfc_index_one_node);
8995 205 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8996 : tmp, size_words);
8997 205 : gfc_add_modify (&se->pre, size_words, tmp);
8998 205 : gfc_add_modify (&se->pre, size_bytes,
8999 : fold_build2_loc (input_location, MULT_EXPR,
9000 : gfc_array_index_type,
9001 : size_words, dest_word_len));
9002 410 : upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9003 205 : size_words, se->loop->from[n]);
9004 205 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9005 : upper, gfc_index_one_node);
9006 : }
9007 : else
9008 : {
9009 267 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9010 : size_words, gfc_index_one_node);
9011 267 : se->loop->from[n] = gfc_index_zero_node;
9012 : }
9013 :
9014 472 : se->loop->to[n] = upper;
9015 :
9016 : /* Build a destination descriptor, using the pointer, source, as the
9017 : data field. */
9018 472 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
9019 : NULL_TREE, false, true, false, &expr->where);
9020 :
9021 : /* Cast the pointer to the result. */
9022 472 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9023 472 : tmp = fold_convert (pvoid_type_node, tmp);
9024 :
9025 : /* Use memcpy to do the transfer. */
9026 472 : tmp
9027 472 : = build_call_expr_loc (input_location,
9028 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
9029 : fold_convert (pvoid_type_node, source),
9030 : fold_convert (size_type_node,
9031 : fold_build2_loc (input_location,
9032 : MIN_EXPR,
9033 : gfc_array_index_type,
9034 : size_bytes,
9035 : source_bytes)));
9036 472 : gfc_add_expr_to_block (&se->pre, tmp);
9037 :
9038 472 : se->expr = info->descriptor;
9039 472 : if (expr->ts.type == BT_CHARACTER)
9040 : {
9041 275 : tmp = fold_convert (gfc_charlen_type_node,
9042 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9043 275 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9044 : gfc_charlen_type_node,
9045 : dest_word_len, tmp);
9046 : }
9047 :
9048 472 : return;
9049 :
9050 : /* Deal with scalar results. */
9051 3503 : scalar_transfer:
9052 3503 : extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9053 : dest_word_len, source_bytes);
9054 3503 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9055 : extent, gfc_index_zero_node);
9056 :
9057 3503 : if (expr->ts.type == BT_CHARACTER)
9058 : {
9059 192 : tree direct, indirect, free;
9060 :
9061 192 : ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
9062 192 : tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
9063 : "transfer");
9064 :
9065 : /* If source is longer than the destination, use a pointer to
9066 : the source directly. */
9067 192 : gfc_init_block (&block);
9068 192 : gfc_add_modify (&block, tmpdecl, ptr);
9069 192 : direct = gfc_finish_block (&block);
9070 :
9071 : /* Otherwise, allocate a string with the length of the destination
9072 : and copy the source into it. */
9073 192 : gfc_init_block (&block);
9074 192 : tmp = gfc_get_pchar_type (expr->ts.kind);
9075 192 : tmp = gfc_call_malloc (&block, tmp, dest_word_len);
9076 192 : gfc_add_modify (&block, tmpdecl,
9077 192 : fold_convert (TREE_TYPE (ptr), tmp));
9078 192 : tmp = build_call_expr_loc (input_location,
9079 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9080 : fold_convert (pvoid_type_node, tmpdecl),
9081 : fold_convert (pvoid_type_node, ptr),
9082 : fold_convert (size_type_node, extent));
9083 192 : gfc_add_expr_to_block (&block, tmp);
9084 192 : indirect = gfc_finish_block (&block);
9085 :
9086 : /* Wrap it up with the condition. */
9087 192 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
9088 : dest_word_len, source_bytes);
9089 192 : tmp = build3_v (COND_EXPR, tmp, direct, indirect);
9090 192 : gfc_add_expr_to_block (&se->pre, tmp);
9091 :
9092 : /* Free the temporary string, if necessary. */
9093 192 : free = gfc_call_free (tmpdecl);
9094 192 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9095 : dest_word_len, source_bytes);
9096 192 : tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
9097 192 : gfc_add_expr_to_block (&se->post, tmp);
9098 :
9099 192 : se->expr = tmpdecl;
9100 192 : tmp = fold_convert (gfc_charlen_type_node,
9101 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9102 192 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9103 : gfc_charlen_type_node,
9104 : dest_word_len, tmp);
9105 : }
9106 : else
9107 : {
9108 3311 : tmpdecl = gfc_create_var (mold_type, "transfer");
9109 :
9110 3311 : ptr = convert (build_pointer_type (mold_type), source);
9111 :
9112 : /* For CLASS results, allocate the needed memory first. */
9113 3311 : if (mold_expr->ts.type == BT_CLASS)
9114 : {
9115 6 : tree cdata;
9116 6 : cdata = gfc_class_data_get (tmpdecl);
9117 6 : tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
9118 6 : gfc_add_modify (&se->pre, cdata, tmp);
9119 : }
9120 :
9121 : /* Use memcpy to do the transfer. */
9122 3311 : if (mold_expr->ts.type == BT_CLASS)
9123 6 : tmp = gfc_class_data_get (tmpdecl);
9124 : else
9125 3305 : tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
9126 :
9127 3311 : tmp = build_call_expr_loc (input_location,
9128 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9129 : fold_convert (pvoid_type_node, tmp),
9130 : fold_convert (pvoid_type_node, ptr),
9131 : fold_convert (size_type_node, extent));
9132 3311 : gfc_add_expr_to_block (&se->pre, tmp);
9133 :
9134 : /* For CLASS results, set the _vptr. */
9135 3311 : if (mold_expr->ts.type == BT_CLASS)
9136 6 : gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
9137 :
9138 3311 : se->expr = tmpdecl;
9139 : }
9140 : }
9141 :
9142 :
9143 : /* Generate code for the ALLOCATED intrinsic.
9144 : Generate inline code that directly check the address of the argument. */
9145 :
9146 : static void
9147 7530 : gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
9148 : {
9149 7530 : gfc_se arg1se;
9150 7530 : tree tmp;
9151 7530 : gfc_expr *e = expr->value.function.actual->expr;
9152 :
9153 7530 : gfc_init_se (&arg1se, NULL);
9154 7530 : if (e->ts.type == BT_CLASS)
9155 : {
9156 : /* Make sure that class array expressions have both a _data
9157 : component reference and an array reference.... */
9158 923 : if (CLASS_DATA (e)->attr.dimension)
9159 424 : gfc_add_class_array_ref (e);
9160 : /* .... whilst scalars only need the _data component. */
9161 : else
9162 499 : gfc_add_data_component (e);
9163 : }
9164 :
9165 7530 : gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
9166 :
9167 7530 : if (e->rank == 0)
9168 : {
9169 : /* Allocatable scalar. */
9170 2974 : arg1se.want_pointer = 1;
9171 2974 : gfc_conv_expr (&arg1se, e);
9172 2974 : tmp = arg1se.expr;
9173 : }
9174 : else
9175 : {
9176 : /* Allocatable array. */
9177 4556 : arg1se.descriptor_only = 1;
9178 4556 : gfc_conv_expr_descriptor (&arg1se, e);
9179 4556 : tmp = gfc_conv_descriptor_data_get (arg1se.expr);
9180 : }
9181 :
9182 7530 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
9183 7530 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9184 :
9185 : /* Components of pointer array references sometimes come back with a pre block. */
9186 7530 : if (arg1se.pre.head)
9187 327 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9188 :
9189 7530 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9190 7530 : }
9191 :
9192 :
9193 : /* Generate code for the ASSOCIATED intrinsic.
9194 : If both POINTER and TARGET are arrays, generate a call to library function
9195 : _gfor_associated, and pass descriptors of POINTER and TARGET to it.
9196 : In other cases, generate inline code that directly compare the address of
9197 : POINTER with the address of TARGET. */
9198 :
9199 : static void
9200 9671 : gfc_conv_associated (gfc_se *se, gfc_expr *expr)
9201 : {
9202 9671 : gfc_actual_arglist *arg1;
9203 9671 : gfc_actual_arglist *arg2;
9204 9671 : gfc_se arg1se;
9205 9671 : gfc_se arg2se;
9206 9671 : tree tmp2;
9207 9671 : tree tmp;
9208 9671 : tree nonzero_arraylen = NULL_TREE;
9209 9671 : gfc_ss *ss;
9210 9671 : bool scalar;
9211 :
9212 9671 : gfc_init_se (&arg1se, NULL);
9213 9671 : gfc_init_se (&arg2se, NULL);
9214 9671 : arg1 = expr->value.function.actual;
9215 9671 : arg2 = arg1->next;
9216 :
9217 : /* Check whether the expression is a scalar or not; we cannot use
9218 : arg1->expr->rank as it can be nonzero for proc pointers. */
9219 9671 : ss = gfc_walk_expr (arg1->expr);
9220 9671 : scalar = ss == gfc_ss_terminator;
9221 9671 : if (!scalar)
9222 3919 : gfc_free_ss_chain (ss);
9223 :
9224 9671 : if (!arg2->expr)
9225 : {
9226 : /* No optional target. */
9227 7292 : if (scalar)
9228 : {
9229 : /* A pointer to a scalar. */
9230 4825 : arg1se.want_pointer = 1;
9231 4825 : gfc_conv_expr (&arg1se, arg1->expr);
9232 4825 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9233 185 : && arg1->expr->symtree->n.sym->attr.dummy)
9234 78 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9235 : arg1se.expr);
9236 4825 : if (arg1->expr->ts.type == BT_CLASS)
9237 : {
9238 390 : tmp2 = gfc_class_data_get (arg1se.expr);
9239 390 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9240 0 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
9241 : }
9242 : else
9243 4435 : tmp2 = arg1se.expr;
9244 : }
9245 : else
9246 : {
9247 : /* A pointer to an array. */
9248 2467 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9249 2467 : tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
9250 : }
9251 7292 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9252 7292 : gfc_add_block_to_block (&se->post, &arg1se.post);
9253 7292 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9254 7292 : fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9255 7292 : se->expr = tmp;
9256 : }
9257 : else
9258 : {
9259 : /* An optional target. */
9260 2379 : if (arg2->expr->ts.type == BT_CLASS
9261 30 : && arg2->expr->expr_type != EXPR_FUNCTION)
9262 24 : gfc_add_data_component (arg2->expr);
9263 :
9264 2379 : if (scalar)
9265 : {
9266 : /* A pointer to a scalar. */
9267 927 : arg1se.want_pointer = 1;
9268 927 : gfc_conv_expr (&arg1se, arg1->expr);
9269 927 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9270 128 : && arg1->expr->symtree->n.sym->attr.dummy)
9271 42 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9272 : arg1se.expr);
9273 927 : if (arg1->expr->ts.type == BT_CLASS)
9274 254 : arg1se.expr = gfc_class_data_get (arg1se.expr);
9275 :
9276 927 : arg2se.want_pointer = 1;
9277 927 : gfc_conv_expr (&arg2se, arg2->expr);
9278 927 : if (arg2->expr->symtree->n.sym->attr.proc_pointer
9279 36 : && arg2->expr->symtree->n.sym->attr.dummy)
9280 0 : arg2se.expr = build_fold_indirect_ref_loc (input_location,
9281 : arg2se.expr);
9282 927 : if (arg2->expr->ts.type == BT_CLASS)
9283 : {
9284 6 : arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
9285 6 : arg2se.expr = gfc_class_data_get (arg2se.expr);
9286 : }
9287 927 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9288 927 : gfc_add_block_to_block (&se->post, &arg1se.post);
9289 927 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9290 927 : gfc_add_block_to_block (&se->post, &arg2se.post);
9291 927 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9292 : arg1se.expr, arg2se.expr);
9293 927 : tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9294 : arg1se.expr, null_pointer_node);
9295 927 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9296 : logical_type_node, tmp, tmp2);
9297 : }
9298 : else
9299 : {
9300 : /* An array pointer of zero length is not associated if target is
9301 : present. */
9302 1452 : arg1se.descriptor_only = 1;
9303 1452 : gfc_conv_expr_lhs (&arg1se, arg1->expr);
9304 1452 : if (arg1->expr->rank == -1)
9305 : {
9306 84 : tmp = gfc_conv_descriptor_rank_get (arg1se.expr);
9307 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9308 84 : TREE_TYPE (tmp), tmp,
9309 84 : build_int_cst (TREE_TYPE (tmp), 1));
9310 : }
9311 : else
9312 1368 : tmp = gfc_rank_cst[arg1->expr->rank - 1];
9313 1452 : tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9314 1452 : if (arg2->expr->rank != 0)
9315 1422 : nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9316 : logical_type_node, tmp,
9317 1422 : build_int_cst (TREE_TYPE (tmp), 0));
9318 :
9319 : /* A pointer to an array, call library function _gfor_associated. */
9320 1452 : arg1se.want_pointer = 1;
9321 1452 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9322 1452 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9323 1452 : gfc_add_block_to_block (&se->post, &arg1se.post);
9324 :
9325 1452 : arg2se.want_pointer = 1;
9326 1452 : arg2se.force_no_tmp = 1;
9327 1452 : if (arg2->expr->rank != 0)
9328 1422 : gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9329 : else
9330 : {
9331 30 : gfc_conv_expr (&arg2se, arg2->expr);
9332 30 : arg2se.expr
9333 30 : = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9334 30 : gfc_expr_attr (arg2->expr));
9335 30 : arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9336 : }
9337 1452 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9338 1452 : gfc_add_block_to_block (&se->post, &arg2se.post);
9339 1452 : se->expr = build_call_expr_loc (input_location,
9340 : gfor_fndecl_associated, 2,
9341 : arg1se.expr, arg2se.expr);
9342 1452 : se->expr = convert (logical_type_node, se->expr);
9343 1452 : if (arg2->expr->rank != 0)
9344 1422 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9345 : logical_type_node, se->expr,
9346 : nonzero_arraylen);
9347 : }
9348 :
9349 : /* If target is present zero character length pointers cannot
9350 : be associated. */
9351 2379 : if (arg1->expr->ts.type == BT_CHARACTER)
9352 : {
9353 631 : tmp = arg1se.string_length;
9354 631 : tmp = fold_build2_loc (input_location, NE_EXPR,
9355 : logical_type_node, tmp,
9356 631 : build_zero_cst (TREE_TYPE (tmp)));
9357 631 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9358 : logical_type_node, se->expr, tmp);
9359 : }
9360 : }
9361 :
9362 9671 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9363 9671 : }
9364 :
9365 :
9366 : /* Generate code for the SAME_TYPE_AS intrinsic.
9367 : Generate inline code that directly checks the vindices. */
9368 :
9369 : static void
9370 409 : gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9371 : {
9372 409 : gfc_expr *a, *b;
9373 409 : gfc_se se1, se2;
9374 409 : tree tmp;
9375 409 : tree conda = NULL_TREE, condb = NULL_TREE;
9376 :
9377 409 : gfc_init_se (&se1, NULL);
9378 409 : gfc_init_se (&se2, NULL);
9379 :
9380 409 : a = expr->value.function.actual->expr;
9381 409 : b = expr->value.function.actual->next->expr;
9382 :
9383 409 : bool unlimited_poly_a = UNLIMITED_POLY (a);
9384 409 : bool unlimited_poly_b = UNLIMITED_POLY (b);
9385 409 : if (unlimited_poly_a)
9386 : {
9387 111 : se1.want_pointer = 1;
9388 111 : gfc_add_vptr_component (a);
9389 : }
9390 298 : else if (a->ts.type == BT_CLASS)
9391 : {
9392 256 : gfc_add_vptr_component (a);
9393 256 : gfc_add_hash_component (a);
9394 : }
9395 42 : else if (a->ts.type == BT_DERIVED)
9396 42 : a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9397 42 : a->ts.u.derived->hash_value);
9398 :
9399 409 : if (unlimited_poly_b)
9400 : {
9401 72 : se2.want_pointer = 1;
9402 72 : gfc_add_vptr_component (b);
9403 : }
9404 337 : else if (b->ts.type == BT_CLASS)
9405 : {
9406 169 : gfc_add_vptr_component (b);
9407 169 : gfc_add_hash_component (b);
9408 : }
9409 168 : else if (b->ts.type == BT_DERIVED)
9410 168 : b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9411 168 : b->ts.u.derived->hash_value);
9412 :
9413 409 : gfc_conv_expr (&se1, a);
9414 409 : gfc_conv_expr (&se2, b);
9415 :
9416 409 : if (unlimited_poly_a)
9417 : {
9418 111 : conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9419 : se1.expr,
9420 111 : build_int_cst (TREE_TYPE (se1.expr), 0));
9421 111 : se1.expr = gfc_vptr_hash_get (se1.expr);
9422 : }
9423 :
9424 409 : if (unlimited_poly_b)
9425 : {
9426 72 : condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9427 : se2.expr,
9428 72 : build_int_cst (TREE_TYPE (se2.expr), 0));
9429 72 : se2.expr = gfc_vptr_hash_get (se2.expr);
9430 : }
9431 :
9432 409 : tmp = fold_build2_loc (input_location, EQ_EXPR,
9433 : logical_type_node, se1.expr,
9434 409 : fold_convert (TREE_TYPE (se1.expr), se2.expr));
9435 :
9436 409 : if (conda)
9437 111 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9438 : logical_type_node, conda, tmp);
9439 :
9440 409 : if (condb)
9441 72 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9442 : logical_type_node, condb, tmp);
9443 :
9444 409 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9445 409 : }
9446 :
9447 :
9448 : /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9449 :
9450 : static void
9451 42 : gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9452 : {
9453 42 : tree args[2];
9454 :
9455 42 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
9456 42 : se->expr = build_call_expr_loc (input_location,
9457 : gfor_fndecl_sc_kind, 2, args[0], args[1]);
9458 42 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9459 42 : }
9460 :
9461 :
9462 : /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9463 :
9464 : static void
9465 45 : gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9466 : {
9467 45 : tree arg, type;
9468 :
9469 45 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9470 :
9471 : /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9472 45 : type = gfc_get_int_type (4);
9473 45 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9474 :
9475 : /* Convert it to the required type. */
9476 45 : type = gfc_typenode_for_spec (&expr->ts);
9477 45 : se->expr = build_call_expr_loc (input_location,
9478 : gfor_fndecl_si_kind, 1, arg);
9479 45 : se->expr = fold_convert (type, se->expr);
9480 45 : }
9481 :
9482 :
9483 : /* Generate code for SELECTED_LOGICAL_KIND (BITS) intrinsic function. */
9484 :
9485 : static void
9486 6 : gfc_conv_intrinsic_sl_kind (gfc_se *se, gfc_expr *expr)
9487 : {
9488 6 : tree arg, type;
9489 :
9490 6 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9491 :
9492 : /* The argument to SELECTED_LOGICAL_KIND is INTEGER(4). */
9493 6 : type = gfc_get_int_type (4);
9494 6 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9495 :
9496 : /* Convert it to the required type. */
9497 6 : type = gfc_typenode_for_spec (&expr->ts);
9498 6 : se->expr = build_call_expr_loc (input_location,
9499 : gfor_fndecl_sl_kind, 1, arg);
9500 6 : se->expr = fold_convert (type, se->expr);
9501 6 : }
9502 :
9503 :
9504 : /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9505 :
9506 : static void
9507 82 : gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9508 : {
9509 82 : gfc_actual_arglist *actual;
9510 82 : tree type;
9511 82 : gfc_se argse;
9512 82 : vec<tree, va_gc> *args = NULL;
9513 :
9514 328 : for (actual = expr->value.function.actual; actual; actual = actual->next)
9515 : {
9516 246 : gfc_init_se (&argse, se);
9517 :
9518 : /* Pass a NULL pointer for an absent arg. */
9519 246 : if (actual->expr == NULL)
9520 96 : argse.expr = null_pointer_node;
9521 : else
9522 : {
9523 150 : gfc_typespec ts;
9524 150 : gfc_clear_ts (&ts);
9525 :
9526 150 : if (actual->expr->ts.kind != gfc_c_int_kind)
9527 : {
9528 : /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9529 0 : ts.type = BT_INTEGER;
9530 0 : ts.kind = gfc_c_int_kind;
9531 0 : gfc_convert_type (actual->expr, &ts, 2);
9532 : }
9533 150 : gfc_conv_expr_reference (&argse, actual->expr);
9534 : }
9535 :
9536 246 : gfc_add_block_to_block (&se->pre, &argse.pre);
9537 246 : gfc_add_block_to_block (&se->post, &argse.post);
9538 246 : vec_safe_push (args, argse.expr);
9539 : }
9540 :
9541 : /* Convert it to the required type. */
9542 82 : type = gfc_typenode_for_spec (&expr->ts);
9543 82 : se->expr = build_call_expr_loc_vec (input_location,
9544 : gfor_fndecl_sr_kind, args);
9545 82 : se->expr = fold_convert (type, se->expr);
9546 82 : }
9547 :
9548 :
9549 : /* Generate code for TRIM (A) intrinsic function. */
9550 :
9551 : static void
9552 580 : gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9553 : {
9554 580 : tree var;
9555 580 : tree len;
9556 580 : tree addr;
9557 580 : tree tmp;
9558 580 : tree cond;
9559 580 : tree fndecl;
9560 580 : tree function;
9561 580 : tree *args;
9562 580 : unsigned int num_args;
9563 :
9564 580 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9565 580 : args = XALLOCAVEC (tree, num_args);
9566 :
9567 580 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9568 580 : addr = gfc_build_addr_expr (ppvoid_type_node, var);
9569 580 : len = gfc_create_var (gfc_charlen_type_node, "len");
9570 :
9571 580 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
9572 580 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
9573 580 : args[1] = addr;
9574 :
9575 580 : if (expr->ts.kind == 1)
9576 548 : function = gfor_fndecl_string_trim;
9577 32 : else if (expr->ts.kind == 4)
9578 32 : function = gfor_fndecl_string_trim_char4;
9579 : else
9580 0 : gcc_unreachable ();
9581 :
9582 580 : fndecl = build_addr (function);
9583 580 : tmp = build_call_array_loc (input_location,
9584 580 : TREE_TYPE (TREE_TYPE (function)), fndecl,
9585 : num_args, args);
9586 580 : gfc_add_expr_to_block (&se->pre, tmp);
9587 :
9588 : /* Free the temporary afterwards, if necessary. */
9589 580 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9590 580 : len, build_int_cst (TREE_TYPE (len), 0));
9591 580 : tmp = gfc_call_free (var);
9592 580 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9593 580 : gfc_add_expr_to_block (&se->post, tmp);
9594 :
9595 580 : se->expr = var;
9596 580 : se->string_length = len;
9597 580 : }
9598 :
9599 :
9600 : /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9601 :
9602 : static void
9603 529 : gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9604 : {
9605 529 : tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9606 529 : tree type, cond, tmp, count, exit_label, n, max, largest;
9607 529 : tree size;
9608 529 : stmtblock_t block, body;
9609 529 : int i;
9610 :
9611 : /* We store in charsize the size of a character. */
9612 529 : i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9613 529 : size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9614 :
9615 : /* Get the arguments. */
9616 529 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
9617 529 : slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9618 529 : src = args[1];
9619 529 : ncopies = gfc_evaluate_now (args[2], &se->pre);
9620 529 : ncopies_type = TREE_TYPE (ncopies);
9621 :
9622 : /* Check that NCOPIES is not negative. */
9623 529 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9624 : build_int_cst (ncopies_type, 0));
9625 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9626 : "Argument NCOPIES of REPEAT intrinsic is negative "
9627 : "(its value is %ld)",
9628 : fold_convert (long_integer_type_node, ncopies));
9629 :
9630 : /* If the source length is zero, any non negative value of NCOPIES
9631 : is valid, and nothing happens. */
9632 529 : n = gfc_create_var (ncopies_type, "ncopies");
9633 529 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9634 : size_zero_node);
9635 529 : tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9636 : build_int_cst (ncopies_type, 0), ncopies);
9637 529 : gfc_add_modify (&se->pre, n, tmp);
9638 529 : ncopies = n;
9639 :
9640 : /* Check that ncopies is not too large: ncopies should be less than
9641 : (or equal to) MAX / slen, where MAX is the maximal integer of
9642 : the gfc_charlen_type_node type. If slen == 0, we need a special
9643 : case to avoid the division by zero. */
9644 529 : max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9645 529 : fold_convert (sizetype,
9646 : TYPE_MAX_VALUE (gfc_charlen_type_node)),
9647 : slen);
9648 1054 : largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9649 529 : ? sizetype : ncopies_type;
9650 529 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9651 : fold_convert (largest, ncopies),
9652 : fold_convert (largest, max));
9653 529 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9654 : size_zero_node);
9655 529 : cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9656 : logical_false_node, cond);
9657 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9658 : "Argument NCOPIES of REPEAT intrinsic is too large");
9659 :
9660 : /* Compute the destination length. */
9661 529 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9662 : fold_convert (gfc_charlen_type_node, slen),
9663 : fold_convert (gfc_charlen_type_node, ncopies));
9664 529 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9665 529 : dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9666 :
9667 : /* Generate the code to do the repeat operation:
9668 : for (i = 0; i < ncopies; i++)
9669 : memmove (dest + (i * slen * size), src, slen*size); */
9670 529 : gfc_start_block (&block);
9671 529 : count = gfc_create_var (sizetype, "count");
9672 529 : gfc_add_modify (&block, count, size_zero_node);
9673 529 : exit_label = gfc_build_label_decl (NULL_TREE);
9674 :
9675 : /* Start the loop body. */
9676 529 : gfc_start_block (&body);
9677 :
9678 : /* Exit the loop if count >= ncopies. */
9679 529 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9680 : fold_convert (sizetype, ncopies));
9681 529 : tmp = build1_v (GOTO_EXPR, exit_label);
9682 529 : TREE_USED (exit_label) = 1;
9683 529 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9684 : build_empty_stmt (input_location));
9685 529 : gfc_add_expr_to_block (&body, tmp);
9686 :
9687 : /* Call memmove (dest + (i*slen*size), src, slen*size). */
9688 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9689 : count);
9690 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9691 : size);
9692 529 : tmp = fold_build_pointer_plus_loc (input_location,
9693 : fold_convert (pvoid_type_node, dest), tmp);
9694 529 : tmp = build_call_expr_loc (input_location,
9695 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9696 : 3, tmp, src,
9697 : fold_build2_loc (input_location, MULT_EXPR,
9698 : size_type_node, slen, size));
9699 529 : gfc_add_expr_to_block (&body, tmp);
9700 :
9701 : /* Increment count. */
9702 529 : tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9703 : count, size_one_node);
9704 529 : gfc_add_modify (&body, count, tmp);
9705 :
9706 : /* Build the loop. */
9707 529 : tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9708 529 : gfc_add_expr_to_block (&block, tmp);
9709 :
9710 : /* Add the exit label. */
9711 529 : tmp = build1_v (LABEL_EXPR, exit_label);
9712 529 : gfc_add_expr_to_block (&block, tmp);
9713 :
9714 : /* Finish the block. */
9715 529 : tmp = gfc_finish_block (&block);
9716 529 : gfc_add_expr_to_block (&se->pre, tmp);
9717 :
9718 : /* Set the result value. */
9719 529 : se->expr = dest;
9720 529 : se->string_length = dlen;
9721 529 : }
9722 :
9723 :
9724 : /* Generate code for the IARGC intrinsic. */
9725 :
9726 : static void
9727 12 : gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9728 : {
9729 12 : tree tmp;
9730 12 : tree fndecl;
9731 12 : tree type;
9732 :
9733 : /* Call the library function. This always returns an INTEGER(4). */
9734 12 : fndecl = gfor_fndecl_iargc;
9735 12 : tmp = build_call_expr_loc (input_location,
9736 : fndecl, 0);
9737 :
9738 : /* Convert it to the required type. */
9739 12 : type = gfc_typenode_for_spec (&expr->ts);
9740 12 : tmp = fold_convert (type, tmp);
9741 :
9742 12 : se->expr = tmp;
9743 12 : }
9744 :
9745 :
9746 : /* Generate code for the KILL intrinsic. */
9747 :
9748 : static void
9749 8 : conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9750 : {
9751 8 : tree *args;
9752 8 : tree int4_type_node = gfc_get_int_type (4);
9753 8 : tree pid;
9754 8 : tree sig;
9755 8 : tree tmp;
9756 8 : unsigned int num_args;
9757 :
9758 8 : num_args = gfc_intrinsic_argument_list_length (expr);
9759 8 : args = XALLOCAVEC (tree, num_args);
9760 8 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
9761 :
9762 : /* Convert PID to a INTEGER(4) entity. */
9763 8 : pid = convert (int4_type_node, args[0]);
9764 :
9765 : /* Convert SIG to a INTEGER(4) entity. */
9766 8 : sig = convert (int4_type_node, args[1]);
9767 :
9768 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9769 :
9770 8 : se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9771 8 : }
9772 :
9773 :
9774 : static tree
9775 15 : conv_intrinsic_kill_sub (gfc_code *code)
9776 : {
9777 15 : stmtblock_t block;
9778 15 : gfc_se se, se_stat;
9779 15 : tree int4_type_node = gfc_get_int_type (4);
9780 15 : tree pid;
9781 15 : tree sig;
9782 15 : tree statp;
9783 15 : tree tmp;
9784 :
9785 : /* Make the function call. */
9786 15 : gfc_init_block (&block);
9787 15 : gfc_init_se (&se, NULL);
9788 :
9789 : /* Convert PID to a INTEGER(4) entity. */
9790 15 : gfc_conv_expr (&se, code->ext.actual->expr);
9791 15 : gfc_add_block_to_block (&block, &se.pre);
9792 15 : pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9793 15 : gfc_add_block_to_block (&block, &se.post);
9794 :
9795 : /* Convert SIG to a INTEGER(4) entity. */
9796 15 : gfc_conv_expr (&se, code->ext.actual->next->expr);
9797 15 : gfc_add_block_to_block (&block, &se.pre);
9798 15 : sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9799 15 : gfc_add_block_to_block (&block, &se.post);
9800 :
9801 : /* Deal with an optional STATUS. */
9802 15 : if (code->ext.actual->next->next->expr)
9803 : {
9804 10 : gfc_init_se (&se_stat, NULL);
9805 10 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
9806 10 : statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9807 : }
9808 : else
9809 : statp = NULL_TREE;
9810 :
9811 25 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9812 10 : statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9813 :
9814 15 : gfc_add_expr_to_block (&block, tmp);
9815 :
9816 15 : if (statp && statp != se_stat.expr)
9817 10 : gfc_add_modify (&block, se_stat.expr,
9818 10 : fold_convert (TREE_TYPE (se_stat.expr), statp));
9819 :
9820 15 : return gfc_finish_block (&block);
9821 : }
9822 :
9823 :
9824 :
9825 : /* The loc intrinsic returns the address of its argument as
9826 : gfc_index_integer_kind integer. */
9827 :
9828 : static void
9829 8993 : gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9830 : {
9831 8993 : tree temp_var;
9832 8993 : gfc_expr *arg_expr;
9833 :
9834 8993 : gcc_assert (!se->ss);
9835 :
9836 8993 : arg_expr = expr->value.function.actual->expr;
9837 8993 : if (arg_expr->rank == 0)
9838 : {
9839 6575 : if (arg_expr->ts.type == BT_CLASS)
9840 18 : gfc_add_data_component (arg_expr);
9841 6575 : gfc_conv_expr_reference (se, arg_expr);
9842 : }
9843 2418 : else if (gfc_is_simply_contiguous (arg_expr, false, false))
9844 2380 : gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9845 : else
9846 : {
9847 38 : gfc_conv_expr_descriptor (se, arg_expr);
9848 38 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9849 : }
9850 8993 : se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9851 8993 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9852 :
9853 : /* Create a temporary variable for loc return value. Without this,
9854 : we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9855 8993 : temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9856 8993 : gfc_add_modify (&se->pre, temp_var, se->expr);
9857 8993 : se->expr = temp_var;
9858 8993 : }
9859 :
9860 : /* The following routine generates code for the intrinsic functions from
9861 : the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
9862 : F_C_STRING. */
9863 :
9864 : static void
9865 9939 : conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9866 : {
9867 9939 : gfc_actual_arglist *arg = expr->value.function.actual;
9868 :
9869 9939 : if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9870 : {
9871 7549 : if (arg->expr->rank == 0)
9872 2010 : gfc_conv_expr_reference (se, arg->expr);
9873 5539 : else if (gfc_is_simply_contiguous (arg->expr, false, false))
9874 4455 : gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9875 : else
9876 : {
9877 1084 : gfc_conv_expr_descriptor (se, arg->expr);
9878 1084 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9879 : }
9880 :
9881 : /* TODO -- the following two lines shouldn't be necessary, but if
9882 : they're removed, a bug is exposed later in the code path.
9883 : This workaround was thus introduced, but will have to be
9884 : removed; please see PR 35150 for details about the issue. */
9885 7549 : se->expr = convert (pvoid_type_node, se->expr);
9886 7549 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9887 : }
9888 2390 : else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9889 : {
9890 260 : gfc_conv_expr_reference (se, arg->expr);
9891 260 : if (arg->expr->symtree->n.sym->attr.proc_pointer
9892 29 : && arg->expr->symtree->n.sym->attr.dummy)
9893 7 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9894 : /* The code below is necessary to create a reference from the calling
9895 : subprogram to the argument of C_FUNLOC() in the call graph.
9896 : Please see PR 117303 for more details. */
9897 260 : se->expr = convert (pvoid_type_node, se->expr);
9898 260 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9899 : }
9900 2130 : else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9901 : {
9902 2054 : gfc_se arg1se;
9903 2054 : gfc_se arg2se;
9904 :
9905 : /* Build the addr_expr for the first argument. The argument is
9906 : already an *address* so we don't need to set want_pointer in
9907 : the gfc_se. */
9908 2054 : gfc_init_se (&arg1se, NULL);
9909 2054 : gfc_conv_expr (&arg1se, arg->expr);
9910 2054 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9911 2054 : gfc_add_block_to_block (&se->post, &arg1se.post);
9912 :
9913 : /* See if we were given two arguments. */
9914 2054 : if (arg->next->expr == NULL)
9915 : /* Only given one arg so generate a null and do a
9916 : not-equal comparison against the first arg. */
9917 1675 : se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9918 : arg1se.expr,
9919 1675 : fold_convert (TREE_TYPE (arg1se.expr),
9920 : null_pointer_node));
9921 : else
9922 : {
9923 379 : tree eq_expr;
9924 379 : tree not_null_expr;
9925 :
9926 : /* Given two arguments so build the arg2se from second arg. */
9927 379 : gfc_init_se (&arg2se, NULL);
9928 379 : gfc_conv_expr (&arg2se, arg->next->expr);
9929 379 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9930 379 : gfc_add_block_to_block (&se->post, &arg2se.post);
9931 :
9932 : /* Generate test to compare that the two args are equal. */
9933 379 : eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9934 : arg1se.expr, arg2se.expr);
9935 : /* Generate test to ensure that the first arg is not null. */
9936 379 : not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9937 : logical_type_node,
9938 : arg1se.expr, null_pointer_node);
9939 :
9940 : /* Finally, the generated test must check that both arg1 is not
9941 : NULL and that it is equal to the second arg. */
9942 379 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9943 : logical_type_node,
9944 : not_null_expr, eq_expr);
9945 : }
9946 : }
9947 76 : else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
9948 : {
9949 : /* There are three cases:
9950 : f_c_string(string) -> trim(string) // c_null_char
9951 : f_c_string(string, .false.) -> trim(string) // c_null_char
9952 : f_c_string(string, .true.) -> string // c_null_char */
9953 :
9954 76 : gfc_expr *string = arg->expr;
9955 76 : gfc_expr *asis = arg->next->expr;
9956 76 : bool need_asis = false, need_trim = false;
9957 76 : gfc_se asis_se;
9958 :
9959 76 : if (!asis)
9960 : {
9961 : need_trim = true;
9962 : need_asis = false;
9963 : }
9964 54 : else if (asis->expr_type == EXPR_CONSTANT)
9965 : {
9966 32 : need_asis = asis->value.logical;
9967 32 : need_trim = !need_asis;
9968 : }
9969 : else
9970 : {
9971 : /* A conditional expression is needed. */
9972 22 : need_asis = true;
9973 22 : need_trim = true;
9974 22 : gfc_init_se (&asis_se, se);
9975 22 : gfc_conv_expr (&asis_se, asis);
9976 22 : if (asis->expr_type == EXPR_VARIABLE
9977 22 : && asis->symtree->n.sym->attr.dummy
9978 10 : && asis->symtree->n.sym->attr.optional)
9979 : {
9980 6 : tree present = gfc_conv_expr_present (asis->symtree->n.sym);
9981 6 : asis_se.expr
9982 6 : = build3_loc (input_location, COND_EXPR,
9983 : logical_type_node, present,
9984 : asis_se.expr, logical_false_node);
9985 : }
9986 22 : gfc_make_safe_expr (&asis_se);
9987 : }
9988 :
9989 : /* Handle the case of a constant string argument first. */
9990 76 : if (string->expr_type == EXPR_CONSTANT)
9991 : {
9992 : /* Output for the asis "then" case goes tlen/tstr, and the
9993 : trimmed case in elen/estr. */
9994 34 : tree elen, estr, tlen, tstr;
9995 34 : elen = estr = tlen = tstr = NULL_TREE;
9996 :
9997 34 : gfc_char_t *orig_string = string->value.character.string;
9998 34 : gfc_charlen_t orig_len = string->value.character.length;
9999 34 : gfc_charlen_t n;
10000 34 : gfc_char_t *buf
10001 34 : = (gfc_char_t *) alloca ((orig_len + 1) * sizeof (gfc_char_t));
10002 34 : memcpy (buf, orig_string, orig_len * sizeof (gfc_char_t));
10003 34 : buf[orig_len] = '\0';
10004 34 : int kind = gfc_default_character_kind;
10005 34 : gcc_assert (string->ts.kind == kind);
10006 :
10007 : /* Build the new string constant(s). */
10008 34 : if (need_asis)
10009 : {
10010 14 : tstr = gfc_build_wide_string_const (kind, orig_len + 1, buf);
10011 14 : tlen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tstr)));
10012 14 : if (!need_trim)
10013 : {
10014 10 : se->expr = tstr;
10015 10 : se->string_length = tlen;
10016 10 : return;
10017 : }
10018 : }
10019 24 : if (need_trim)
10020 : {
10021 72 : for (n = orig_len; n; n--)
10022 72 : if (buf[n - 1] != ' ')
10023 : break;
10024 24 : buf[n] = '\0';
10025 24 : if (need_asis && n == orig_len)
10026 : {
10027 : /* Special case; trimming is a no-op. Add side-effects
10028 : from the condition and then just return the string
10029 : without a conditional. */
10030 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10031 2 : se->expr = tstr;
10032 2 : se->string_length = tlen;
10033 2 : return;
10034 : }
10035 : else
10036 : {
10037 22 : estr = gfc_build_wide_string_const (kind, n + 1, buf);
10038 22 : elen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (estr)));
10039 : }
10040 22 : if (!need_asis)
10041 : {
10042 20 : se->expr = estr;
10043 20 : se->string_length = elen;
10044 20 : return;
10045 : }
10046 : }
10047 0 : gcc_assert (need_asis && need_trim);
10048 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10049 2 : se->expr
10050 2 : = fold_build3_loc (input_location, COND_EXPR,
10051 : pchar_type_node, asis_se.expr,
10052 : tstr, estr);
10053 2 : se->string_length
10054 2 : = fold_build3_loc (input_location, COND_EXPR,
10055 : gfc_charlen_type_node, asis_se.expr,
10056 : tlen, elen);
10057 2 : return;
10058 : }
10059 : else
10060 : /* We have to generate code to do the string transformation(s) at
10061 : runtime. */
10062 : {
10063 42 : tree tmp;
10064 :
10065 : /* Convert input string. */
10066 42 : gfc_se sse;
10067 42 : gfc_init_se (&sse, se);
10068 42 : gfc_conv_expr (&sse, string);
10069 42 : gfc_conv_string_parameter (&sse);
10070 42 : gfc_make_safe_expr (&sse);
10071 42 : gfc_add_block_to_block (&se->pre, &sse.pre);
10072 :
10073 : /* Use a temporary for the (possibly trimmed) string length. */
10074 42 : tree lenvar = gfc_create_var (gfc_charlen_type_node, NULL);
10075 42 : gfc_add_modify (&se->pre, lenvar, sse.string_length);
10076 :
10077 : /* Build the expression for a call to LEN_TRIM if we may need
10078 : to trim the string. If it's conditional, handle that too. */
10079 42 : if (need_trim)
10080 : {
10081 36 : tree trimlen
10082 36 : = build_call_expr_loc (input_location,
10083 : gfor_fndecl_string_len_trim, 2,
10084 : lenvar, sse.expr);
10085 36 : if (need_asis)
10086 : {
10087 18 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10088 18 : tmp = fold_build3_loc (input_location, COND_EXPR,
10089 : gfc_charlen_type_node, asis_se.expr,
10090 : lenvar, trimlen);
10091 18 : gfc_add_modify (&se->pre, lenvar, tmp);
10092 : }
10093 : else
10094 18 : gfc_add_modify (&se->pre, lenvar, trimlen);
10095 : }
10096 :
10097 : /* Allocate a new string newvar that is lenvar+1 bytes long.
10098 : memcpy the first lenvar bytes from the input string, and
10099 : add a null character. Note that lenvar, the length of
10100 : the (trimmed) original string, has type gfc_charlen_type_node,
10101 : but newlen is size_type_node. */
10102 42 : tree string_type_node = build_pointer_type (char_type_node);
10103 42 : tree newvar = gfc_create_var (string_type_node, NULL);
10104 42 : tree newlen = fold_build2_loc (input_location, PLUS_EXPR,
10105 : size_type_node,
10106 : fold_convert (size_type_node,
10107 : lenvar),
10108 : size_one_node);
10109 42 : gfc_add_modify (&se->pre, newvar,
10110 : gfc_call_malloc (&se->pre, string_type_node,
10111 : newlen));
10112 42 : tmp = build_call_expr_loc (input_location,
10113 : builtin_decl_explicit (BUILT_IN_MEMCPY),
10114 : 3,
10115 : fold_convert (pvoid_type_node, newvar),
10116 : fold_convert (pvoid_type_node, sse.expr),
10117 : fold_convert (size_type_node, lenvar));
10118 42 : gfc_add_expr_to_block (&se->pre, tmp);
10119 42 : tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
10120 : string_type_node, newvar,
10121 : fold_convert (size_type_node, lenvar));
10122 42 : tmp = fold_build1_loc (input_location, INDIRECT_REF,
10123 : char_type_node, tmp);
10124 42 : gfc_add_modify (&se->pre, tmp,
10125 : fold_convert (char_type_node, integer_zero_node));
10126 :
10127 : /* Remember to free the string later. */
10128 42 : tmp = gfc_call_free (newvar);
10129 42 : gfc_add_expr_to_block (&se->post, tmp);
10130 :
10131 : /* Return the result. */
10132 42 : se->expr = newvar;
10133 42 : se->string_length = fold_convert (gfc_charlen_type_node, newlen);
10134 42 : return;
10135 : }
10136 : }
10137 : else
10138 0 : gcc_unreachable ();
10139 : }
10140 :
10141 :
10142 : /* The following routine generates code for the intrinsic
10143 : subroutines from the ISO_C_BINDING module:
10144 : * C_F_POINTER
10145 : * C_F_PROCPOINTER. */
10146 :
10147 : static tree
10148 3364 : conv_isocbinding_subroutine (gfc_code *code)
10149 : {
10150 3364 : gfc_expr *cptr, *fptr, *shape, *lower;
10151 3364 : gfc_se se, cptrse, fptrse, shapese, lowerse;
10152 3364 : gfc_ss *shape_ss, *lower_ss;
10153 3364 : tree desc, dim, tmp, stride, offset, lbound, ubound;
10154 3364 : stmtblock_t body, block;
10155 3364 : gfc_loopinfo loop;
10156 3364 : gfc_actual_arglist *arg;
10157 :
10158 3364 : arg = code->ext.actual;
10159 3364 : cptr = arg->expr;
10160 3364 : fptr = arg->next->expr;
10161 3364 : shape = arg->next->next ? arg->next->next->expr : NULL;
10162 3282 : lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
10163 :
10164 3364 : gfc_init_se (&se, NULL);
10165 3364 : gfc_init_se (&cptrse, NULL);
10166 3364 : gfc_conv_expr (&cptrse, cptr);
10167 3364 : gfc_add_block_to_block (&se.pre, &cptrse.pre);
10168 3364 : gfc_add_block_to_block (&se.post, &cptrse.post);
10169 :
10170 3364 : gfc_init_se (&fptrse, NULL);
10171 3364 : if (fptr->rank == 0)
10172 : {
10173 2878 : fptrse.want_pointer = 1;
10174 2878 : gfc_conv_expr (&fptrse, fptr);
10175 2878 : gfc_add_block_to_block (&se.pre, &fptrse.pre);
10176 2878 : gfc_add_block_to_block (&se.post, &fptrse.post);
10177 2878 : if (fptr->symtree->n.sym->attr.proc_pointer
10178 81 : && fptr->symtree->n.sym->attr.dummy)
10179 19 : fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
10180 2878 : se.expr
10181 2878 : = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
10182 : fptrse.expr,
10183 2878 : fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
10184 2878 : gfc_add_expr_to_block (&se.pre, se.expr);
10185 2878 : gfc_add_block_to_block (&se.pre, &se.post);
10186 2878 : return gfc_finish_block (&se.pre);
10187 : }
10188 :
10189 486 : gfc_start_block (&block);
10190 :
10191 : /* Get the descriptor of the Fortran pointer. */
10192 486 : fptrse.descriptor_only = 1;
10193 486 : gfc_conv_expr_descriptor (&fptrse, fptr);
10194 486 : gfc_add_block_to_block (&block, &fptrse.pre);
10195 486 : desc = fptrse.expr;
10196 :
10197 : /* Set the span field. */
10198 486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
10199 486 : tmp = fold_convert (gfc_array_index_type, tmp);
10200 486 : gfc_conv_descriptor_span_set (&block, desc, tmp);
10201 :
10202 : /* Set data value, dtype, and offset. */
10203 486 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
10204 486 : gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
10205 486 : gfc_conv_descriptor_dtype_set (&block, desc,
10206 486 : gfc_get_dtype (TREE_TYPE (desc)));
10207 :
10208 : /* Start scalarization of the bounds, using the shape argument. */
10209 :
10210 486 : shape_ss = gfc_walk_expr (shape);
10211 486 : gcc_assert (shape_ss != gfc_ss_terminator);
10212 486 : gfc_init_se (&shapese, NULL);
10213 486 : if (lower)
10214 : {
10215 12 : lower_ss = gfc_walk_expr (lower);
10216 12 : gcc_assert (lower_ss != gfc_ss_terminator);
10217 12 : gfc_init_se (&lowerse, NULL);
10218 : }
10219 :
10220 486 : gfc_init_loopinfo (&loop);
10221 486 : gfc_add_ss_to_loop (&loop, shape_ss);
10222 486 : if (lower)
10223 12 : gfc_add_ss_to_loop (&loop, lower_ss);
10224 486 : gfc_conv_ss_startstride (&loop);
10225 486 : gfc_conv_loop_setup (&loop, &fptr->where);
10226 486 : gfc_mark_ss_chain_used (shape_ss, 1);
10227 486 : if (lower)
10228 12 : gfc_mark_ss_chain_used (lower_ss, 1);
10229 :
10230 486 : gfc_copy_loopinfo_to_se (&shapese, &loop);
10231 486 : shapese.ss = shape_ss;
10232 486 : if (lower)
10233 : {
10234 12 : gfc_copy_loopinfo_to_se (&lowerse, &loop);
10235 12 : lowerse.ss = lower_ss;
10236 : }
10237 :
10238 486 : stride = gfc_create_var (gfc_array_index_type, "stride");
10239 486 : offset = gfc_create_var (gfc_array_index_type, "offset");
10240 486 : gfc_add_modify (&block, stride, gfc_index_one_node);
10241 486 : gfc_add_modify (&block, offset, gfc_index_zero_node);
10242 :
10243 : /* Loop body. */
10244 486 : gfc_start_scalarized_body (&loop, &body);
10245 :
10246 486 : dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10247 : loop.loopvar[0], loop.from[0]);
10248 :
10249 486 : if (lower)
10250 : {
10251 12 : gfc_conv_expr (&lowerse, lower);
10252 12 : gfc_add_block_to_block (&body, &lowerse.pre);
10253 12 : lbound = fold_convert (gfc_array_index_type, lowerse.expr);
10254 12 : gfc_add_block_to_block (&body, &lowerse.post);
10255 : }
10256 : else
10257 474 : lbound = gfc_index_one_node;
10258 :
10259 : /* Set bounds and stride. */
10260 486 : gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
10261 486 : gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
10262 :
10263 486 : gfc_conv_expr (&shapese, shape);
10264 486 : gfc_add_block_to_block (&body, &shapese.pre);
10265 486 : ubound = fold_build2_loc (
10266 : input_location, MINUS_EXPR, gfc_array_index_type,
10267 : fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
10268 : fold_convert (gfc_array_index_type, shapese.expr)),
10269 : gfc_index_one_node);
10270 486 : gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
10271 486 : gfc_add_block_to_block (&body, &shapese.post);
10272 :
10273 : /* Calculate offset. */
10274 486 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10275 : stride, lbound);
10276 486 : gfc_add_modify (&body, offset,
10277 : fold_build2_loc (input_location, PLUS_EXPR,
10278 : gfc_array_index_type, offset, tmp));
10279 :
10280 : /* Update stride. */
10281 486 : gfc_add_modify (
10282 : &body, stride,
10283 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
10284 : fold_convert (gfc_array_index_type, shapese.expr)));
10285 : /* Finish scalarization loop. */
10286 486 : gfc_trans_scalarizing_loops (&loop, &body);
10287 486 : gfc_add_block_to_block (&block, &loop.pre);
10288 486 : gfc_add_block_to_block (&block, &loop.post);
10289 486 : gfc_add_block_to_block (&block, &fptrse.post);
10290 486 : gfc_cleanup_loop (&loop);
10291 :
10292 486 : gfc_add_modify (&block, offset,
10293 : fold_build1_loc (input_location, NEGATE_EXPR,
10294 : gfc_array_index_type, offset));
10295 486 : gfc_conv_descriptor_offset_set (&block, desc, offset);
10296 :
10297 486 : gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
10298 486 : gfc_add_block_to_block (&se.pre, &se.post);
10299 486 : return gfc_finish_block (&se.pre);
10300 : }
10301 :
10302 :
10303 : /* The following routine generates code for both forms of the intrinsic
10304 : subroutine C_F_STRPOINTER from the ISO_C_BINDING module. */
10305 : static tree
10306 60 : conv_isocbinding_subroutine_strpointer (gfc_code *code)
10307 : {
10308 60 : gfc_actual_arglist *arg = code->ext.actual;
10309 60 : gfc_expr *arg0 = arg->expr;
10310 60 : gfc_expr *fstrptr = arg->next->expr;
10311 60 : gfc_expr *nchars = arg->next->next->expr;
10312 60 : tree ptr;
10313 60 : tree size = NULL_TREE;
10314 60 : tree nc = NULL_TREE;
10315 60 : tree fstrptr_ptr, fstrptr_len;
10316 60 : stmtblock_t block;
10317 60 : gfc_init_block (&block);
10318 60 : gfc_se se0, se1, se2;
10319 60 : gfc_init_se (&se0, NULL);
10320 60 : gfc_init_se (&se1, NULL);
10321 60 : gfc_init_se (&se2, NULL);
10322 :
10323 : /* arg0 can either be a simply contiguous rank-one character array,
10324 : or a scalar of type c_ptr that points to a contiguous array.
10325 : In the first case nchars may be omitted and defaults to the size
10326 : of the array. */
10327 60 : if (arg0->rank == 1)
10328 : {
10329 42 : gfc_array_ref *ar = gfc_find_array_ref (arg0);
10330 42 : if (ar->as && ar->as->type == AS_ASSUMED_SIZE
10331 12 : && (ar->type == AR_FULL || ar->end[0] == nullptr))
10332 : /* No size available. */
10333 12 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, NULL);
10334 : else
10335 : {
10336 30 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, &size);
10337 30 : gcc_assert (size);
10338 : }
10339 42 : ptr = se0.expr;
10340 : }
10341 18 : else if (arg0->rank == 0)
10342 : {
10343 : /* Scalar case. arg0 is a C pointer to the string, and the
10344 : nchars argument is required. */
10345 18 : gfc_conv_expr (&se0, arg0);
10346 18 : ptr = se0.expr;
10347 : /* We already issued a diagnostic for this in parsing. */
10348 18 : gcc_assert (nchars);
10349 : }
10350 : else
10351 0 : gcc_unreachable ();
10352 :
10353 : /* Translate the fortran array pointer argument. AFAICT the
10354 : representation here is that this returns the pointer location in
10355 : se1.expr and there is a separate decl for the length.
10356 : Of course none of this is properly documented.... :-( */
10357 60 : gfc_conv_expr (&se1, fstrptr);
10358 60 : fstrptr_ptr = se1.expr;
10359 60 : gcc_assert (fstrptr->ts.u.cl && fstrptr->ts.u.cl->backend_decl);
10360 60 : fstrptr_len = fstrptr->ts.u.cl->backend_decl;
10361 :
10362 : /* Translate nchars, if provided. If we have both the array size
10363 : and nchars, take the minimum value. NC is the tree expr to hold
10364 : the value. */
10365 60 : if (nchars)
10366 : {
10367 30 : gfc_conv_expr (&se2, nchars);
10368 30 : nc = se2.expr;
10369 30 : if (size)
10370 0 : nc = fold_build2_loc (input_location, MIN_EXPR,
10371 0 : TREE_TYPE (nc), nc, size);
10372 : /* Check for the case where an optional dummy parameter is
10373 : passed as the optional nchars argument. It's not supposed to
10374 : be omitted if we don't also have an array size; rather than
10375 : produce a run-time error, assume size 0. */
10376 30 : if (nchars->expr_type == EXPR_VARIABLE
10377 18 : && nchars->symtree->n.sym->attr.dummy
10378 18 : && nchars->symtree->n.sym->attr.optional)
10379 : {
10380 12 : tree present = gfc_conv_expr_present (nchars->symtree->n.sym);
10381 12 : nc = build3_loc (input_location, COND_EXPR,
10382 12 : TREE_TYPE (nc), present, nc,
10383 24 : size ? size : build_int_cst (TREE_TYPE (nc), 0));
10384 : }
10385 : }
10386 : else
10387 : {
10388 30 : gcc_assert (size);
10389 : nc = size;
10390 : }
10391 :
10392 : /* Collect argument side-effect statements. */
10393 60 : gfc_add_block_to_block (&block, &se0.pre);
10394 60 : gfc_add_block_to_block (&block, &se1.pre);
10395 60 : gfc_add_block_to_block (&block, &se2.pre);
10396 :
10397 : /* Generate a call to builtin_strnlen to get the C string length
10398 : for the output fstrptr. */
10399 60 : ptr = gfc_evaluate_now (ptr, &block);
10400 60 : size = build_call_expr_loc (input_location,
10401 : builtin_decl_explicit (BUILT_IN_STRNLEN), 2,
10402 : fold_convert (const_ptr_type_node, ptr),
10403 : fold_convert (size_type_node, nc));
10404 :
10405 : /* Stuff the raw C char pointer PTR and actual length SIZE into fstrptr. */
10406 60 : gfc_add_modify (&block, fstrptr_ptr,
10407 60 : fold_convert (TREE_TYPE (fstrptr_ptr), ptr));
10408 60 : gfc_add_modify (&block, fstrptr_len,
10409 : fold_convert (gfc_charlen_type_node, size));
10410 :
10411 : /* Collect argument cleanups. */
10412 60 : gfc_add_block_to_block (&block, &se2.post);
10413 60 : gfc_add_block_to_block (&block, &se1.post);
10414 60 : gfc_add_block_to_block (&block, &se0.post);
10415 :
10416 60 : return gfc_finish_block (&block);
10417 : }
10418 :
10419 : /* Save and restore floating-point state. */
10420 :
10421 : tree
10422 945 : gfc_save_fp_state (stmtblock_t *block)
10423 : {
10424 945 : tree type, fpstate, tmp;
10425 :
10426 945 : type = build_array_type (char_type_node,
10427 : build_range_type (size_type_node, size_zero_node,
10428 : size_int (GFC_FPE_STATE_BUFFER_SIZE)));
10429 945 : fpstate = gfc_create_var (type, "fpstate");
10430 945 : fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
10431 :
10432 945 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
10433 : 1, fpstate);
10434 945 : gfc_add_expr_to_block (block, tmp);
10435 :
10436 945 : return fpstate;
10437 : }
10438 :
10439 :
10440 : void
10441 945 : gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
10442 : {
10443 945 : tree tmp;
10444 :
10445 945 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
10446 : 1, fpstate);
10447 945 : gfc_add_expr_to_block (block, tmp);
10448 945 : }
10449 :
10450 :
10451 : /* Generate code for arguments of IEEE functions. */
10452 :
10453 : static void
10454 12457 : conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
10455 : int nargs)
10456 : {
10457 12457 : gfc_actual_arglist *actual;
10458 12457 : gfc_expr *e;
10459 12457 : gfc_se argse;
10460 12457 : int arg;
10461 :
10462 12457 : actual = expr->value.function.actual;
10463 34461 : for (arg = 0; arg < nargs; arg++, actual = actual->next)
10464 : {
10465 22004 : gcc_assert (actual);
10466 22004 : e = actual->expr;
10467 :
10468 22004 : gfc_init_se (&argse, se);
10469 22004 : gfc_conv_expr_val (&argse, e);
10470 :
10471 22004 : gfc_add_block_to_block (&se->pre, &argse.pre);
10472 22004 : gfc_add_block_to_block (&se->post, &argse.post);
10473 22004 : argarray[arg] = argse.expr;
10474 : }
10475 12457 : }
10476 :
10477 :
10478 : /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
10479 : and IEEE_UNORDERED, which translate directly to GCC type-generic
10480 : built-ins. */
10481 :
10482 : static void
10483 1062 : conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
10484 : enum built_in_function code, int nargs)
10485 : {
10486 1062 : tree args[2];
10487 1062 : gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
10488 :
10489 1062 : conv_ieee_function_args (se, expr, args, nargs);
10490 1062 : se->expr = build_call_expr_loc_array (input_location,
10491 : builtin_decl_explicit (code),
10492 : nargs, args);
10493 2388 : STRIP_TYPE_NOPS (se->expr);
10494 1062 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10495 1062 : }
10496 :
10497 :
10498 : /* Generate code for intrinsics IEEE_SIGNBIT. */
10499 :
10500 : static void
10501 624 : conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
10502 : {
10503 624 : tree arg, signbit;
10504 :
10505 624 : conv_ieee_function_args (se, expr, &arg, 1);
10506 624 : signbit = build_call_expr_loc (input_location,
10507 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10508 : 1, arg);
10509 624 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10510 : signbit, integer_zero_node);
10511 624 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
10512 624 : }
10513 :
10514 :
10515 : /* Generate code for IEEE_IS_NORMAL intrinsic:
10516 : IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
10517 :
10518 : static void
10519 312 : conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
10520 : {
10521 312 : tree arg, isnormal, iszero;
10522 :
10523 : /* Convert arg, evaluate it only once. */
10524 312 : conv_ieee_function_args (se, expr, &arg, 1);
10525 312 : arg = gfc_evaluate_now (arg, &se->pre);
10526 :
10527 312 : isnormal = build_call_expr_loc (input_location,
10528 : builtin_decl_explicit (BUILT_IN_ISNORMAL),
10529 : 1, arg);
10530 312 : iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
10531 312 : build_real_from_int_cst (TREE_TYPE (arg),
10532 312 : integer_zero_node));
10533 312 : se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10534 : logical_type_node, isnormal, iszero);
10535 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10536 312 : }
10537 :
10538 :
10539 : /* Generate code for IEEE_IS_NEGATIVE intrinsic:
10540 : IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10541 :
10542 : static void
10543 312 : conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
10544 : {
10545 312 : tree arg, signbit, isnan;
10546 :
10547 : /* Convert arg, evaluate it only once. */
10548 312 : conv_ieee_function_args (se, expr, &arg, 1);
10549 312 : arg = gfc_evaluate_now (arg, &se->pre);
10550 :
10551 312 : isnan = build_call_expr_loc (input_location,
10552 : builtin_decl_explicit (BUILT_IN_ISNAN),
10553 : 1, arg);
10554 936 : STRIP_TYPE_NOPS (isnan);
10555 :
10556 312 : signbit = build_call_expr_loc (input_location,
10557 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10558 : 1, arg);
10559 312 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10560 : signbit, integer_zero_node);
10561 :
10562 312 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10563 : logical_type_node, signbit,
10564 : fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10565 312 : TREE_TYPE(isnan), isnan));
10566 :
10567 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10568 312 : }
10569 :
10570 :
10571 : /* Generate code for IEEE_LOGB and IEEE_RINT. */
10572 :
10573 : static void
10574 240 : conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
10575 : enum built_in_function code)
10576 : {
10577 240 : tree arg, decl, call, fpstate;
10578 240 : int argprec;
10579 :
10580 240 : conv_ieee_function_args (se, expr, &arg, 1);
10581 240 : argprec = TYPE_PRECISION (TREE_TYPE (arg));
10582 240 : decl = builtin_decl_for_precision (code, argprec);
10583 :
10584 : /* Save floating-point state. */
10585 240 : fpstate = gfc_save_fp_state (&se->pre);
10586 :
10587 : /* Make the function call. */
10588 240 : call = build_call_expr_loc (input_location, decl, 1, arg);
10589 240 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
10590 :
10591 : /* Restore floating-point state. */
10592 240 : gfc_restore_fp_state (&se->post, fpstate);
10593 240 : }
10594 :
10595 :
10596 : /* Generate code for IEEE_REM. */
10597 :
10598 : static void
10599 84 : conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
10600 : {
10601 84 : tree args[2], decl, call, fpstate;
10602 84 : int argprec;
10603 :
10604 84 : conv_ieee_function_args (se, expr, args, 2);
10605 :
10606 : /* If arguments have unequal size, convert them to the larger. */
10607 84 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
10608 84 : > TYPE_PRECISION (TREE_TYPE (args[1])))
10609 6 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10610 78 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
10611 78 : > TYPE_PRECISION (TREE_TYPE (args[0])))
10612 24 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
10613 :
10614 84 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10615 84 : decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
10616 :
10617 : /* Save floating-point state. */
10618 84 : fpstate = gfc_save_fp_state (&se->pre);
10619 :
10620 : /* Make the function call. */
10621 84 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10622 84 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10623 :
10624 : /* Restore floating-point state. */
10625 84 : gfc_restore_fp_state (&se->post, fpstate);
10626 84 : }
10627 :
10628 :
10629 : /* Generate code for IEEE_NEXT_AFTER. */
10630 :
10631 : static void
10632 180 : conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
10633 : {
10634 180 : tree args[2], decl, call, fpstate;
10635 180 : int argprec;
10636 :
10637 180 : conv_ieee_function_args (se, expr, args, 2);
10638 :
10639 : /* Result has the characteristics of first argument. */
10640 180 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10641 180 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10642 180 : decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
10643 :
10644 : /* Save floating-point state. */
10645 180 : fpstate = gfc_save_fp_state (&se->pre);
10646 :
10647 : /* Make the function call. */
10648 180 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10649 180 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10650 :
10651 : /* Restore floating-point state. */
10652 180 : gfc_restore_fp_state (&se->post, fpstate);
10653 180 : }
10654 :
10655 :
10656 : /* Generate code for IEEE_SCALB. */
10657 :
10658 : static void
10659 228 : conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10660 : {
10661 228 : tree args[2], decl, call, huge, type;
10662 228 : int argprec, n;
10663 :
10664 228 : conv_ieee_function_args (se, expr, args, 2);
10665 :
10666 : /* Result has the characteristics of first argument. */
10667 228 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10668 228 : decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10669 :
10670 228 : if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10671 : {
10672 : /* We need to fold the integer into the range of a C int. */
10673 18 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10674 18 : type = TREE_TYPE (args[1]);
10675 :
10676 18 : n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10677 18 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10678 : gfc_c_int_kind);
10679 18 : huge = fold_convert (type, huge);
10680 18 : args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10681 : huge);
10682 18 : args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10683 : fold_build1_loc (input_location, NEGATE_EXPR,
10684 : type, huge));
10685 : }
10686 :
10687 228 : args[1] = fold_convert (integer_type_node, args[1]);
10688 :
10689 : /* Make the function call. */
10690 228 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10691 228 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10692 228 : }
10693 :
10694 :
10695 : /* Generate code for IEEE_COPY_SIGN. */
10696 :
10697 : static void
10698 576 : conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10699 : {
10700 576 : tree args[2], decl, sign;
10701 576 : int argprec;
10702 :
10703 576 : conv_ieee_function_args (se, expr, args, 2);
10704 :
10705 : /* Get the sign of the second argument. */
10706 576 : sign = build_call_expr_loc (input_location,
10707 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10708 : 1, args[1]);
10709 576 : sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10710 : sign, integer_zero_node);
10711 :
10712 : /* Create a value of one, with the right sign. */
10713 576 : sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10714 : sign,
10715 : fold_build1_loc (input_location, NEGATE_EXPR,
10716 : integer_type_node,
10717 : integer_one_node),
10718 : integer_one_node);
10719 576 : args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10720 :
10721 576 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10722 576 : decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10723 :
10724 576 : se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10725 576 : }
10726 :
10727 :
10728 : /* Generate code for IEEE_CLASS. */
10729 :
10730 : static void
10731 648 : conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10732 : {
10733 648 : tree arg, c, t1, t2, t3, t4;
10734 :
10735 : /* Convert arg, evaluate it only once. */
10736 648 : conv_ieee_function_args (se, expr, &arg, 1);
10737 648 : arg = gfc_evaluate_now (arg, &se->pre);
10738 :
10739 648 : c = build_call_expr_loc (input_location,
10740 : builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
10741 : build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10742 : build_int_cst (integer_type_node,
10743 : IEEE_POSITIVE_INF),
10744 : build_int_cst (integer_type_node,
10745 : IEEE_POSITIVE_NORMAL),
10746 : build_int_cst (integer_type_node,
10747 : IEEE_POSITIVE_DENORMAL),
10748 : build_int_cst (integer_type_node,
10749 : IEEE_POSITIVE_ZERO),
10750 : arg);
10751 648 : c = gfc_evaluate_now (c, &se->pre);
10752 648 : t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10753 : c, build_int_cst (integer_type_node,
10754 : IEEE_QUIET_NAN));
10755 648 : t2 = build_call_expr_loc (input_location,
10756 : builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
10757 : arg);
10758 648 : t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10759 648 : t2, build_zero_cst (TREE_TYPE (t2)));
10760 648 : t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10761 : logical_type_node, t1, t2);
10762 648 : t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10763 : c, build_int_cst (integer_type_node,
10764 : IEEE_POSITIVE_ZERO));
10765 648 : t4 = build_call_expr_loc (input_location,
10766 : builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
10767 : arg);
10768 648 : t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10769 648 : t4, build_zero_cst (TREE_TYPE (t4)));
10770 648 : t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10771 : logical_type_node, t3, t4);
10772 648 : int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10773 648 : gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10774 648 : gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10775 648 : gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10776 648 : gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10777 648 : gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10778 648 : t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10779 648 : build_int_cst (TREE_TYPE (c), s), c);
10780 648 : t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10781 : t3, t4, c);
10782 648 : t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10783 648 : build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10784 : t3);
10785 648 : tree type = gfc_typenode_for_spec (&expr->ts);
10786 : /* Perform a quick sanity check that the return type is
10787 : IEEE_CLASS_TYPE derived type defined in
10788 : libgfortran/ieee/ieee_arithmetic.F90
10789 : Primarily check that it is a derived type with a single
10790 : member in it. */
10791 648 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10792 648 : tree field = NULL_TREE;
10793 1296 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10794 648 : if (TREE_CODE (f) == FIELD_DECL)
10795 : {
10796 648 : gcc_assert (field == NULL_TREE);
10797 : field = f;
10798 : }
10799 648 : gcc_assert (field);
10800 648 : t1 = fold_convert (TREE_TYPE (field), t1);
10801 648 : se->expr = build_constructor_single (type, field, t1);
10802 648 : }
10803 :
10804 :
10805 : /* Generate code for IEEE_VALUE. */
10806 :
10807 : static void
10808 1111 : conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10809 : {
10810 1111 : tree args[2], arg, ret, tmp;
10811 1111 : stmtblock_t body;
10812 :
10813 : /* Convert args, evaluate the second one only once. */
10814 1111 : conv_ieee_function_args (se, expr, args, 2);
10815 1111 : arg = gfc_evaluate_now (args[1], &se->pre);
10816 :
10817 1111 : tree type = TREE_TYPE (arg);
10818 : /* Perform a quick sanity check that the second argument's type is
10819 : IEEE_CLASS_TYPE derived type defined in
10820 : libgfortran/ieee/ieee_arithmetic.F90
10821 : Primarily check that it is a derived type with a single
10822 : member in it. */
10823 1111 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10824 1111 : tree field = NULL_TREE;
10825 2222 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10826 1111 : if (TREE_CODE (f) == FIELD_DECL)
10827 : {
10828 1111 : gcc_assert (field == NULL_TREE);
10829 : field = f;
10830 : }
10831 1111 : gcc_assert (field);
10832 1111 : arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10833 : arg, field, NULL_TREE);
10834 1111 : arg = gfc_evaluate_now (arg, &se->pre);
10835 :
10836 1111 : type = gfc_typenode_for_spec (&expr->ts);
10837 1111 : gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10838 1111 : ret = gfc_create_var (type, NULL);
10839 :
10840 1111 : gfc_init_block (&body);
10841 :
10842 1111 : tree end_label = gfc_build_label_decl (NULL_TREE);
10843 13332 : for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10844 : {
10845 11110 : tree label = gfc_build_label_decl (NULL_TREE);
10846 11110 : tree low = build_int_cst (TREE_TYPE (arg), c);
10847 11110 : tmp = build_case_label (low, low, label);
10848 11110 : gfc_add_expr_to_block (&body, tmp);
10849 :
10850 11110 : REAL_VALUE_TYPE real;
10851 11110 : int k;
10852 11110 : switch (c)
10853 : {
10854 1111 : case IEEE_SIGNALING_NAN:
10855 1111 : real_nan (&real, "", 0, TYPE_MODE (type));
10856 1111 : break;
10857 1111 : case IEEE_QUIET_NAN:
10858 1111 : real_nan (&real, "", 1, TYPE_MODE (type));
10859 1111 : break;
10860 1111 : case IEEE_NEGATIVE_INF:
10861 1111 : real_inf (&real);
10862 1111 : real = real_value_negate (&real);
10863 1111 : break;
10864 1111 : case IEEE_NEGATIVE_NORMAL:
10865 1111 : real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10866 1111 : break;
10867 1111 : case IEEE_NEGATIVE_DENORMAL:
10868 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10869 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10870 : type, GFC_RND_MODE);
10871 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10872 1111 : real = real_value_negate (&real);
10873 1111 : break;
10874 1111 : case IEEE_NEGATIVE_ZERO:
10875 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10876 1111 : real = real_value_negate (&real);
10877 1111 : break;
10878 1111 : case IEEE_POSITIVE_ZERO:
10879 : /* Make this also the default: label. The other possibility
10880 : would be to add a separate default: label followed by
10881 : __builtin_unreachable (). */
10882 1111 : label = gfc_build_label_decl (NULL_TREE);
10883 1111 : tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10884 1111 : gfc_add_expr_to_block (&body, tmp);
10885 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10886 1111 : break;
10887 1111 : case IEEE_POSITIVE_DENORMAL:
10888 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10889 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10890 : type, GFC_RND_MODE);
10891 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10892 1111 : break;
10893 1111 : case IEEE_POSITIVE_NORMAL:
10894 1111 : real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10895 1111 : break;
10896 1111 : case IEEE_POSITIVE_INF:
10897 1111 : real_inf (&real);
10898 1111 : break;
10899 : default:
10900 : gcc_unreachable ();
10901 : }
10902 :
10903 11110 : tree val = build_real (type, real);
10904 11110 : gfc_add_modify (&body, ret, val);
10905 :
10906 11110 : tmp = build1_v (GOTO_EXPR, end_label);
10907 11110 : gfc_add_expr_to_block (&body, tmp);
10908 : }
10909 :
10910 1111 : tmp = gfc_finish_block (&body);
10911 1111 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10912 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10913 :
10914 1111 : tmp = build1_v (LABEL_EXPR, end_label);
10915 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10916 :
10917 1111 : se->expr = ret;
10918 1111 : }
10919 :
10920 :
10921 : /* Generate code for IEEE_FMA. */
10922 :
10923 : static void
10924 120 : conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10925 : {
10926 120 : tree args[3], decl, call;
10927 120 : int argprec;
10928 :
10929 120 : conv_ieee_function_args (se, expr, args, 3);
10930 :
10931 : /* All three arguments should have the same type. */
10932 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10933 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10934 :
10935 : /* Call the type-generic FMA built-in. */
10936 120 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10937 120 : decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
10938 120 : call = build_call_expr_loc_array (input_location, decl, 3, args);
10939 :
10940 : /* Convert to the final type. */
10941 120 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10942 120 : }
10943 :
10944 :
10945 : /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10946 :
10947 : static void
10948 3072 : conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10949 : const char *name)
10950 : {
10951 3072 : tree args[2], func;
10952 3072 : built_in_function fn;
10953 :
10954 3072 : conv_ieee_function_args (se, expr, args, 2);
10955 3072 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10956 3072 : args[0] = gfc_evaluate_now (args[0], &se->pre);
10957 3072 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10958 :
10959 3072 : if (startswith (name, "mag"))
10960 : {
10961 : /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10962 : fminmag() and fmaxmag(), which do not exist as built-ins.
10963 :
10964 : Following glibc, we emit this:
10965 :
10966 : fminmag (x, y) {
10967 : ax = ABS (x);
10968 : ay = ABS (y);
10969 : if (isless (ax, ay))
10970 : return x;
10971 : else if (isgreater (ax, ay))
10972 : return y;
10973 : else if (ax == ay)
10974 : return x < y ? x : y;
10975 : else if (issignaling (x) || issignaling (y))
10976 : return x + y;
10977 : else
10978 : return isnan (y) ? x : y;
10979 : }
10980 :
10981 : fmaxmag (x, y) {
10982 : ax = ABS (x);
10983 : ay = ABS (y);
10984 : if (isgreater (ax, ay))
10985 : return x;
10986 : else if (isless (ax, ay))
10987 : return y;
10988 : else if (ax == ay)
10989 : return x > y ? x : y;
10990 : else if (issignaling (x) || issignaling (y))
10991 : return x + y;
10992 : else
10993 : return isnan (y) ? x : y;
10994 : }
10995 :
10996 : */
10997 :
10998 1536 : tree abs0, abs1, sig0, sig1;
10999 1536 : tree cond1, cond2, cond3, cond4, cond5;
11000 1536 : tree res;
11001 1536 : tree type = TREE_TYPE (args[0]);
11002 :
11003 1536 : func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
11004 1536 : abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
11005 1536 : abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
11006 1536 : abs0 = gfc_evaluate_now (abs0, &se->pre);
11007 1536 : abs1 = gfc_evaluate_now (abs1, &se->pre);
11008 :
11009 1536 : cond5 = build_call_expr_loc (input_location,
11010 : builtin_decl_explicit (BUILT_IN_ISNAN),
11011 : 1, args[1]);
11012 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
11013 : args[0], args[1]);
11014 :
11015 1536 : sig0 = build_call_expr_loc (input_location,
11016 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11017 : 1, args[0]);
11018 1536 : sig1 = build_call_expr_loc (input_location,
11019 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11020 : 1, args[1]);
11021 1536 : cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
11022 : logical_type_node, sig0, sig1);
11023 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
11024 : fold_build2_loc (input_location, PLUS_EXPR,
11025 : type, args[0], args[1]),
11026 : res);
11027 :
11028 1536 : cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11029 : abs0, abs1);
11030 2304 : res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
11031 : fold_build2_loc (input_location,
11032 : max ? MAX_EXPR : MIN_EXPR,
11033 : type, args[0], args[1]),
11034 : res);
11035 :
11036 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
11037 1536 : cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11038 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
11039 : args[1], res);
11040 :
11041 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
11042 1536 : cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11043 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
11044 : args[0], res);
11045 :
11046 1536 : se->expr = res;
11047 : }
11048 : else
11049 : {
11050 : /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
11051 1536 : fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
11052 1536 : func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind);
11053 1536 : se->expr = build_call_expr_loc_array (input_location, func, 2, args);
11054 : }
11055 3072 : }
11056 :
11057 :
11058 : /* Generate code for comparison functions IEEE_QUIET_* and
11059 : IEEE_SIGNALING_*. */
11060 :
11061 : static void
11062 3888 : conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
11063 : const char *name)
11064 : {
11065 3888 : tree args[2];
11066 3888 : tree arg1, arg2, res;
11067 :
11068 : /* Evaluate arguments only once. */
11069 3888 : conv_ieee_function_args (se, expr, args, 2);
11070 3888 : arg1 = gfc_evaluate_now (args[0], &se->pre);
11071 3888 : arg2 = gfc_evaluate_now (args[1], &se->pre);
11072 :
11073 3888 : if (startswith (name, "eq"))
11074 : {
11075 648 : if (signaling)
11076 324 : res = build_call_expr_loc (input_location,
11077 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11078 : 2, arg1, arg2);
11079 : else
11080 324 : res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11081 : arg1, arg2);
11082 : }
11083 3240 : else if (startswith (name, "ne"))
11084 : {
11085 648 : if (signaling)
11086 : {
11087 324 : res = build_call_expr_loc (input_location,
11088 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11089 : 2, arg1, arg2);
11090 324 : res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
11091 : logical_type_node, res);
11092 : }
11093 : else
11094 324 : res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
11095 : arg1, arg2);
11096 : }
11097 2592 : else if (startswith (name, "ge"))
11098 : {
11099 648 : if (signaling)
11100 324 : res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11101 : arg1, arg2);
11102 : else
11103 324 : res = build_call_expr_loc (input_location,
11104 : builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
11105 : 2, arg1, arg2);
11106 : }
11107 1944 : else if (startswith (name, "gt"))
11108 : {
11109 648 : if (signaling)
11110 324 : res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
11111 : arg1, arg2);
11112 : else
11113 324 : res = build_call_expr_loc (input_location,
11114 : builtin_decl_explicit (BUILT_IN_ISGREATER),
11115 : 2, arg1, arg2);
11116 : }
11117 1296 : else if (startswith (name, "le"))
11118 : {
11119 648 : if (signaling)
11120 324 : res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
11121 : arg1, arg2);
11122 : else
11123 324 : res = build_call_expr_loc (input_location,
11124 : builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
11125 : 2, arg1, arg2);
11126 : }
11127 648 : else if (startswith (name, "lt"))
11128 : {
11129 648 : if (signaling)
11130 324 : res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11131 : arg1, arg2);
11132 : else
11133 324 : res = build_call_expr_loc (input_location,
11134 : builtin_decl_explicit (BUILT_IN_ISLESS),
11135 : 2, arg1, arg2);
11136 : }
11137 : else
11138 0 : gcc_unreachable ();
11139 :
11140 3888 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
11141 3888 : }
11142 :
11143 :
11144 : /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
11145 : module. */
11146 :
11147 : bool
11148 13939 : gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
11149 : {
11150 13939 : const char *name = expr->value.function.name;
11151 :
11152 13939 : if (startswith (name, "_gfortran_ieee_is_nan"))
11153 522 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
11154 13417 : else if (startswith (name, "_gfortran_ieee_is_finite"))
11155 372 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
11156 13045 : else if (startswith (name, "_gfortran_ieee_unordered"))
11157 168 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
11158 12877 : else if (startswith (name, "_gfortran_ieee_signbit"))
11159 624 : conv_intrinsic_ieee_signbit (se, expr);
11160 12253 : else if (startswith (name, "_gfortran_ieee_is_normal"))
11161 312 : conv_intrinsic_ieee_is_normal (se, expr);
11162 11941 : else if (startswith (name, "_gfortran_ieee_is_negative"))
11163 312 : conv_intrinsic_ieee_is_negative (se, expr);
11164 11629 : else if (startswith (name, "_gfortran_ieee_copy_sign"))
11165 576 : conv_intrinsic_ieee_copy_sign (se, expr);
11166 11053 : else if (startswith (name, "_gfortran_ieee_scalb"))
11167 228 : conv_intrinsic_ieee_scalb (se, expr);
11168 10825 : else if (startswith (name, "_gfortran_ieee_next_after"))
11169 180 : conv_intrinsic_ieee_next_after (se, expr);
11170 10645 : else if (startswith (name, "_gfortran_ieee_rem"))
11171 84 : conv_intrinsic_ieee_rem (se, expr);
11172 10561 : else if (startswith (name, "_gfortran_ieee_logb"))
11173 144 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
11174 10417 : else if (startswith (name, "_gfortran_ieee_rint"))
11175 96 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
11176 10321 : else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
11177 648 : conv_intrinsic_ieee_class (se, expr);
11178 9673 : else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
11179 1111 : conv_intrinsic_ieee_value (se, expr);
11180 8562 : else if (startswith (name, "_gfortran_ieee_fma"))
11181 120 : conv_intrinsic_ieee_fma (se, expr);
11182 8442 : else if (startswith (name, "_gfortran_ieee_min_num_"))
11183 1536 : conv_intrinsic_ieee_minmax (se, expr, 0, name + 23);
11184 6906 : else if (startswith (name, "_gfortran_ieee_max_num_"))
11185 1536 : conv_intrinsic_ieee_minmax (se, expr, 1, name + 23);
11186 5370 : else if (startswith (name, "_gfortran_ieee_quiet_"))
11187 1944 : conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
11188 3426 : else if (startswith (name, "_gfortran_ieee_signaling_"))
11189 1944 : conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
11190 : else
11191 : /* It is not among the functions we translate directly. We return
11192 : false, so a library function call is emitted. */
11193 : return false;
11194 :
11195 : return true;
11196 : }
11197 :
11198 :
11199 : /* Generate a direct call to malloc() for the MALLOC intrinsic. */
11200 :
11201 : static void
11202 16 : gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
11203 : {
11204 16 : tree arg, res, restype;
11205 :
11206 16 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
11207 16 : arg = fold_convert (size_type_node, arg);
11208 16 : res = build_call_expr_loc (input_location,
11209 : builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
11210 16 : restype = gfc_typenode_for_spec (&expr->ts);
11211 16 : se->expr = fold_convert (restype, res);
11212 16 : }
11213 :
11214 :
11215 : /* Generate code for an intrinsic function. Some map directly to library
11216 : calls, others get special handling. In some cases the name of the function
11217 : used depends on the type specifiers. */
11218 :
11219 : void
11220 268501 : gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
11221 : {
11222 268501 : const char *name;
11223 268501 : int lib, kind;
11224 268501 : tree fndecl;
11225 :
11226 268501 : name = &expr->value.function.name[2];
11227 :
11228 268501 : if (expr->rank > 0)
11229 : {
11230 50592 : lib = gfc_is_intrinsic_libcall (expr);
11231 50592 : if (lib != 0)
11232 : {
11233 19230 : if (lib == 1)
11234 11792 : se->ignore_optional = 1;
11235 :
11236 19230 : switch (expr->value.function.isym->id)
11237 : {
11238 5867 : case GFC_ISYM_EOSHIFT:
11239 5867 : case GFC_ISYM_PACK:
11240 5867 : case GFC_ISYM_RESHAPE:
11241 5867 : case GFC_ISYM_REDUCE:
11242 : /* For all of those the first argument specifies the type and the
11243 : third is optional. */
11244 5867 : conv_generic_with_optional_char_arg (se, expr, 1, 3);
11245 5867 : break;
11246 :
11247 1116 : case GFC_ISYM_FINDLOC:
11248 1116 : gfc_conv_intrinsic_findloc (se, expr);
11249 1116 : break;
11250 :
11251 2935 : case GFC_ISYM_MINLOC:
11252 2935 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11253 2935 : break;
11254 :
11255 2439 : case GFC_ISYM_MAXLOC:
11256 2439 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11257 2439 : break;
11258 :
11259 6873 : default:
11260 6873 : gfc_conv_intrinsic_funcall (se, expr);
11261 6873 : break;
11262 : }
11263 :
11264 : return;
11265 : }
11266 : }
11267 :
11268 249271 : switch (expr->value.function.isym->id)
11269 : {
11270 0 : case GFC_ISYM_NONE:
11271 0 : gcc_unreachable ();
11272 :
11273 529 : case GFC_ISYM_REPEAT:
11274 529 : gfc_conv_intrinsic_repeat (se, expr);
11275 529 : break;
11276 :
11277 580 : case GFC_ISYM_TRIM:
11278 580 : gfc_conv_intrinsic_trim (se, expr);
11279 580 : break;
11280 :
11281 42 : case GFC_ISYM_SC_KIND:
11282 42 : gfc_conv_intrinsic_sc_kind (se, expr);
11283 42 : break;
11284 :
11285 45 : case GFC_ISYM_SI_KIND:
11286 45 : gfc_conv_intrinsic_si_kind (se, expr);
11287 45 : break;
11288 :
11289 6 : case GFC_ISYM_SL_KIND:
11290 6 : gfc_conv_intrinsic_sl_kind (se, expr);
11291 6 : break;
11292 :
11293 82 : case GFC_ISYM_SR_KIND:
11294 82 : gfc_conv_intrinsic_sr_kind (se, expr);
11295 82 : break;
11296 :
11297 228 : case GFC_ISYM_EXPONENT:
11298 228 : gfc_conv_intrinsic_exponent (se, expr);
11299 228 : break;
11300 :
11301 316 : case GFC_ISYM_SCAN:
11302 316 : kind = expr->value.function.actual->expr->ts.kind;
11303 316 : if (kind == 1)
11304 250 : fndecl = gfor_fndecl_string_scan;
11305 66 : else if (kind == 4)
11306 66 : fndecl = gfor_fndecl_string_scan_char4;
11307 : else
11308 0 : gcc_unreachable ();
11309 :
11310 316 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11311 316 : break;
11312 :
11313 94 : case GFC_ISYM_VERIFY:
11314 94 : kind = expr->value.function.actual->expr->ts.kind;
11315 94 : if (kind == 1)
11316 70 : fndecl = gfor_fndecl_string_verify;
11317 24 : else if (kind == 4)
11318 24 : fndecl = gfor_fndecl_string_verify_char4;
11319 : else
11320 0 : gcc_unreachable ();
11321 :
11322 94 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11323 94 : break;
11324 :
11325 7530 : case GFC_ISYM_ALLOCATED:
11326 7530 : gfc_conv_allocated (se, expr);
11327 7530 : break;
11328 :
11329 9671 : case GFC_ISYM_ASSOCIATED:
11330 9671 : gfc_conv_associated(se, expr);
11331 9671 : break;
11332 :
11333 409 : case GFC_ISYM_SAME_TYPE_AS:
11334 409 : gfc_conv_same_type_as (se, expr);
11335 409 : break;
11336 :
11337 7992 : case GFC_ISYM_ABS:
11338 7992 : gfc_conv_intrinsic_abs (se, expr);
11339 7992 : break;
11340 :
11341 345 : case GFC_ISYM_ADJUSTL:
11342 345 : if (expr->ts.kind == 1)
11343 291 : fndecl = gfor_fndecl_adjustl;
11344 54 : else if (expr->ts.kind == 4)
11345 54 : fndecl = gfor_fndecl_adjustl_char4;
11346 : else
11347 0 : gcc_unreachable ();
11348 :
11349 345 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11350 345 : break;
11351 :
11352 123 : case GFC_ISYM_ADJUSTR:
11353 123 : if (expr->ts.kind == 1)
11354 68 : fndecl = gfor_fndecl_adjustr;
11355 55 : else if (expr->ts.kind == 4)
11356 55 : fndecl = gfor_fndecl_adjustr_char4;
11357 : else
11358 0 : gcc_unreachable ();
11359 :
11360 123 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11361 123 : break;
11362 :
11363 440 : case GFC_ISYM_AIMAG:
11364 440 : gfc_conv_intrinsic_imagpart (se, expr);
11365 440 : break;
11366 :
11367 146 : case GFC_ISYM_AINT:
11368 146 : gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
11369 146 : break;
11370 :
11371 432 : case GFC_ISYM_ALL:
11372 432 : gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
11373 432 : break;
11374 :
11375 74 : case GFC_ISYM_ANINT:
11376 74 : gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
11377 74 : break;
11378 :
11379 90 : case GFC_ISYM_AND:
11380 90 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11381 90 : break;
11382 :
11383 38386 : case GFC_ISYM_ANY:
11384 38386 : gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
11385 38386 : break;
11386 :
11387 270 : case GFC_ISYM_ACOSD:
11388 270 : case GFC_ISYM_ASIND:
11389 270 : case GFC_ISYM_ATAND:
11390 270 : gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
11391 270 : break;
11392 :
11393 102 : case GFC_ISYM_COTAN:
11394 102 : gfc_conv_intrinsic_cotan (se, expr);
11395 102 : break;
11396 :
11397 108 : case GFC_ISYM_COTAND:
11398 108 : gfc_conv_intrinsic_cotand (se, expr);
11399 108 : break;
11400 :
11401 138 : case GFC_ISYM_ATAN2D:
11402 138 : gfc_conv_intrinsic_atan2d (se, expr);
11403 138 : break;
11404 :
11405 145 : case GFC_ISYM_BTEST:
11406 145 : gfc_conv_intrinsic_btest (se, expr);
11407 145 : break;
11408 :
11409 54 : case GFC_ISYM_BGE:
11410 54 : gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
11411 54 : break;
11412 :
11413 54 : case GFC_ISYM_BGT:
11414 54 : gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
11415 54 : break;
11416 :
11417 54 : case GFC_ISYM_BLE:
11418 54 : gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
11419 54 : break;
11420 :
11421 54 : case GFC_ISYM_BLT:
11422 54 : gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
11423 54 : break;
11424 :
11425 9939 : case GFC_ISYM_C_ASSOCIATED:
11426 9939 : case GFC_ISYM_C_FUNLOC:
11427 9939 : case GFC_ISYM_C_LOC:
11428 9939 : case GFC_ISYM_F_C_STRING:
11429 9939 : conv_isocbinding_function (se, expr);
11430 9939 : break;
11431 :
11432 2020 : case GFC_ISYM_ACHAR:
11433 2020 : case GFC_ISYM_CHAR:
11434 2020 : gfc_conv_intrinsic_char (se, expr);
11435 2020 : break;
11436 :
11437 41184 : case GFC_ISYM_CONVERSION:
11438 41184 : case GFC_ISYM_DBLE:
11439 41184 : case GFC_ISYM_DFLOAT:
11440 41184 : case GFC_ISYM_FLOAT:
11441 41184 : case GFC_ISYM_LOGICAL:
11442 41184 : case GFC_ISYM_REAL:
11443 41184 : case GFC_ISYM_REALPART:
11444 41184 : case GFC_ISYM_SNGL:
11445 41184 : gfc_conv_intrinsic_conversion (se, expr);
11446 41184 : break;
11447 :
11448 : /* Integer conversions are handled separately to make sure we get the
11449 : correct rounding mode. */
11450 2836 : case GFC_ISYM_INT:
11451 2836 : case GFC_ISYM_INT2:
11452 2836 : case GFC_ISYM_INT8:
11453 2836 : case GFC_ISYM_LONG:
11454 2836 : case GFC_ISYM_UINT:
11455 2836 : gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
11456 2836 : break;
11457 :
11458 162 : case GFC_ISYM_NINT:
11459 162 : gfc_conv_intrinsic_int (se, expr, RND_ROUND);
11460 162 : break;
11461 :
11462 16 : case GFC_ISYM_CEILING:
11463 16 : gfc_conv_intrinsic_int (se, expr, RND_CEIL);
11464 16 : break;
11465 :
11466 116 : case GFC_ISYM_FLOOR:
11467 116 : gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
11468 116 : break;
11469 :
11470 3379 : case GFC_ISYM_MOD:
11471 3379 : gfc_conv_intrinsic_mod (se, expr, 0);
11472 3379 : break;
11473 :
11474 442 : case GFC_ISYM_MODULO:
11475 442 : gfc_conv_intrinsic_mod (se, expr, 1);
11476 442 : break;
11477 :
11478 1006 : case GFC_ISYM_CAF_GET:
11479 1006 : gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL);
11480 1006 : break;
11481 :
11482 239 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
11483 239 : gfc_conv_intrinsic_caf_is_present_remote (se, expr);
11484 239 : break;
11485 :
11486 485 : case GFC_ISYM_CMPLX:
11487 485 : gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
11488 485 : break;
11489 :
11490 10 : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
11491 10 : gfc_conv_intrinsic_iargc (se, expr);
11492 10 : break;
11493 :
11494 6 : case GFC_ISYM_COMPLEX:
11495 6 : gfc_conv_intrinsic_cmplx (se, expr, 1);
11496 6 : break;
11497 :
11498 257 : case GFC_ISYM_CONJG:
11499 257 : gfc_conv_intrinsic_conjg (se, expr);
11500 257 : break;
11501 :
11502 4 : case GFC_ISYM_COSHAPE:
11503 4 : conv_intrinsic_cobound (se, expr);
11504 4 : break;
11505 :
11506 143 : case GFC_ISYM_COUNT:
11507 143 : gfc_conv_intrinsic_count (se, expr);
11508 143 : break;
11509 :
11510 0 : case GFC_ISYM_CTIME:
11511 0 : gfc_conv_intrinsic_ctime (se, expr);
11512 0 : break;
11513 :
11514 96 : case GFC_ISYM_DIM:
11515 96 : gfc_conv_intrinsic_dim (se, expr);
11516 96 : break;
11517 :
11518 113 : case GFC_ISYM_DOT_PRODUCT:
11519 113 : gfc_conv_intrinsic_dot_product (se, expr);
11520 113 : break;
11521 :
11522 13 : case GFC_ISYM_DPROD:
11523 13 : gfc_conv_intrinsic_dprod (se, expr);
11524 13 : break;
11525 :
11526 66 : case GFC_ISYM_DSHIFTL:
11527 66 : gfc_conv_intrinsic_dshift (se, expr, true);
11528 66 : break;
11529 :
11530 66 : case GFC_ISYM_DSHIFTR:
11531 66 : gfc_conv_intrinsic_dshift (se, expr, false);
11532 66 : break;
11533 :
11534 0 : case GFC_ISYM_FDATE:
11535 0 : gfc_conv_intrinsic_fdate (se, expr);
11536 0 : break;
11537 :
11538 60 : case GFC_ISYM_FRACTION:
11539 60 : gfc_conv_intrinsic_fraction (se, expr);
11540 60 : break;
11541 :
11542 24 : case GFC_ISYM_IALL:
11543 24 : gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
11544 24 : break;
11545 :
11546 606 : case GFC_ISYM_IAND:
11547 606 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11548 606 : break;
11549 :
11550 12 : case GFC_ISYM_IANY:
11551 12 : gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
11552 12 : break;
11553 :
11554 168 : case GFC_ISYM_IBCLR:
11555 168 : gfc_conv_intrinsic_singlebitop (se, expr, 0);
11556 168 : break;
11557 :
11558 27 : case GFC_ISYM_IBITS:
11559 27 : gfc_conv_intrinsic_ibits (se, expr);
11560 27 : break;
11561 :
11562 138 : case GFC_ISYM_IBSET:
11563 138 : gfc_conv_intrinsic_singlebitop (se, expr, 1);
11564 138 : break;
11565 :
11566 2033 : case GFC_ISYM_IACHAR:
11567 2033 : case GFC_ISYM_ICHAR:
11568 : /* We assume ASCII character sequence. */
11569 2033 : gfc_conv_intrinsic_ichar (se, expr);
11570 2033 : break;
11571 :
11572 2 : case GFC_ISYM_IARGC:
11573 2 : gfc_conv_intrinsic_iargc (se, expr);
11574 2 : break;
11575 :
11576 694 : case GFC_ISYM_IEOR:
11577 694 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11578 694 : break;
11579 :
11580 341 : case GFC_ISYM_INDEX:
11581 341 : kind = expr->value.function.actual->expr->ts.kind;
11582 341 : if (kind == 1)
11583 275 : fndecl = gfor_fndecl_string_index;
11584 66 : else if (kind == 4)
11585 66 : fndecl = gfor_fndecl_string_index_char4;
11586 : else
11587 0 : gcc_unreachable ();
11588 :
11589 341 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11590 341 : break;
11591 :
11592 495 : case GFC_ISYM_IOR:
11593 495 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11594 495 : break;
11595 :
11596 12 : case GFC_ISYM_IPARITY:
11597 12 : gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
11598 12 : break;
11599 :
11600 6 : case GFC_ISYM_IS_IOSTAT_END:
11601 6 : gfc_conv_has_intvalue (se, expr, LIBERROR_END);
11602 6 : break;
11603 :
11604 18 : case GFC_ISYM_IS_IOSTAT_EOR:
11605 18 : gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
11606 18 : break;
11607 :
11608 754 : case GFC_ISYM_IS_CONTIGUOUS:
11609 754 : gfc_conv_intrinsic_is_contiguous (se, expr);
11610 754 : break;
11611 :
11612 432 : case GFC_ISYM_ISNAN:
11613 432 : gfc_conv_intrinsic_isnan (se, expr);
11614 432 : break;
11615 :
11616 8 : case GFC_ISYM_KILL:
11617 8 : conv_intrinsic_kill (se, expr);
11618 8 : break;
11619 :
11620 90 : case GFC_ISYM_LSHIFT:
11621 90 : gfc_conv_intrinsic_shift (se, expr, false, false);
11622 90 : break;
11623 :
11624 24 : case GFC_ISYM_RSHIFT:
11625 24 : gfc_conv_intrinsic_shift (se, expr, true, true);
11626 24 : break;
11627 :
11628 78 : case GFC_ISYM_SHIFTA:
11629 78 : gfc_conv_intrinsic_shift (se, expr, true, true);
11630 78 : break;
11631 :
11632 234 : case GFC_ISYM_SHIFTL:
11633 234 : gfc_conv_intrinsic_shift (se, expr, false, false);
11634 234 : break;
11635 :
11636 66 : case GFC_ISYM_SHIFTR:
11637 66 : gfc_conv_intrinsic_shift (se, expr, true, false);
11638 66 : break;
11639 :
11640 318 : case GFC_ISYM_ISHFT:
11641 318 : gfc_conv_intrinsic_ishft (se, expr);
11642 318 : break;
11643 :
11644 658 : case GFC_ISYM_ISHFTC:
11645 658 : gfc_conv_intrinsic_ishftc (se, expr);
11646 658 : break;
11647 :
11648 270 : case GFC_ISYM_LEADZ:
11649 270 : gfc_conv_intrinsic_leadz (se, expr);
11650 270 : break;
11651 :
11652 282 : case GFC_ISYM_TRAILZ:
11653 282 : gfc_conv_intrinsic_trailz (se, expr);
11654 282 : break;
11655 :
11656 103 : case GFC_ISYM_POPCNT:
11657 103 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
11658 103 : break;
11659 :
11660 31 : case GFC_ISYM_POPPAR:
11661 31 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
11662 31 : break;
11663 :
11664 5589 : case GFC_ISYM_LBOUND:
11665 5589 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
11666 5589 : break;
11667 :
11668 210 : case GFC_ISYM_LCOBOUND:
11669 210 : conv_intrinsic_cobound (se, expr);
11670 210 : break;
11671 :
11672 774 : case GFC_ISYM_TRANSPOSE:
11673 : /* The scalarizer has already been set up for reversed dimension access
11674 : order ; now we just get the argument value normally. */
11675 774 : gfc_conv_expr (se, expr->value.function.actual->expr);
11676 774 : break;
11677 :
11678 5898 : case GFC_ISYM_LEN:
11679 5898 : gfc_conv_intrinsic_len (se, expr);
11680 5898 : break;
11681 :
11682 2340 : case GFC_ISYM_LEN_TRIM:
11683 2340 : gfc_conv_intrinsic_len_trim (se, expr);
11684 2340 : break;
11685 :
11686 18 : case GFC_ISYM_LGE:
11687 18 : gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
11688 18 : break;
11689 :
11690 36 : case GFC_ISYM_LGT:
11691 36 : gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
11692 36 : break;
11693 :
11694 18 : case GFC_ISYM_LLE:
11695 18 : gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
11696 18 : break;
11697 :
11698 27 : case GFC_ISYM_LLT:
11699 27 : gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
11700 27 : break;
11701 :
11702 16 : case GFC_ISYM_MALLOC:
11703 16 : gfc_conv_intrinsic_malloc (se, expr);
11704 16 : break;
11705 :
11706 32 : case GFC_ISYM_MASKL:
11707 32 : gfc_conv_intrinsic_mask (se, expr, 1);
11708 32 : break;
11709 :
11710 32 : case GFC_ISYM_MASKR:
11711 32 : gfc_conv_intrinsic_mask (se, expr, 0);
11712 32 : break;
11713 :
11714 1049 : case GFC_ISYM_MAX:
11715 1049 : if (expr->ts.type == BT_CHARACTER)
11716 138 : gfc_conv_intrinsic_minmax_char (se, expr, 1);
11717 : else
11718 911 : gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
11719 : break;
11720 :
11721 6348 : case GFC_ISYM_MAXLOC:
11722 6348 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11723 6348 : break;
11724 :
11725 216 : case GFC_ISYM_FINDLOC:
11726 216 : gfc_conv_intrinsic_findloc (se, expr);
11727 216 : break;
11728 :
11729 1101 : case GFC_ISYM_MAXVAL:
11730 1101 : gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
11731 1101 : break;
11732 :
11733 949 : case GFC_ISYM_MERGE:
11734 949 : gfc_conv_intrinsic_merge (se, expr);
11735 949 : break;
11736 :
11737 42 : case GFC_ISYM_MERGE_BITS:
11738 42 : gfc_conv_intrinsic_merge_bits (se, expr);
11739 42 : break;
11740 :
11741 598 : case GFC_ISYM_MIN:
11742 598 : if (expr->ts.type == BT_CHARACTER)
11743 144 : gfc_conv_intrinsic_minmax_char (se, expr, -1);
11744 : else
11745 454 : gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
11746 : break;
11747 :
11748 7176 : case GFC_ISYM_MINLOC:
11749 7176 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11750 7176 : break;
11751 :
11752 1316 : case GFC_ISYM_MINVAL:
11753 1316 : gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
11754 1316 : break;
11755 :
11756 1595 : case GFC_ISYM_NEAREST:
11757 1595 : gfc_conv_intrinsic_nearest (se, expr);
11758 1595 : break;
11759 :
11760 68 : case GFC_ISYM_NORM2:
11761 68 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
11762 68 : break;
11763 :
11764 230 : case GFC_ISYM_NOT:
11765 230 : gfc_conv_intrinsic_not (se, expr);
11766 230 : break;
11767 :
11768 12 : case GFC_ISYM_OR:
11769 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11770 12 : break;
11771 :
11772 468 : case GFC_ISYM_OUT_OF_RANGE:
11773 468 : gfc_conv_intrinsic_out_of_range (se, expr);
11774 468 : break;
11775 :
11776 36 : case GFC_ISYM_PARITY:
11777 36 : gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
11778 36 : break;
11779 :
11780 5088 : case GFC_ISYM_PRESENT:
11781 5088 : gfc_conv_intrinsic_present (se, expr);
11782 5088 : break;
11783 :
11784 358 : case GFC_ISYM_PRODUCT:
11785 358 : gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
11786 358 : break;
11787 :
11788 13346 : case GFC_ISYM_RANK:
11789 13346 : gfc_conv_intrinsic_rank (se, expr);
11790 13346 : break;
11791 :
11792 48 : case GFC_ISYM_RRSPACING:
11793 48 : gfc_conv_intrinsic_rrspacing (se, expr);
11794 48 : break;
11795 :
11796 262 : case GFC_ISYM_SET_EXPONENT:
11797 262 : gfc_conv_intrinsic_set_exponent (se, expr);
11798 262 : break;
11799 :
11800 72 : case GFC_ISYM_SCALE:
11801 72 : gfc_conv_intrinsic_scale (se, expr);
11802 72 : break;
11803 :
11804 5012 : case GFC_ISYM_SHAPE:
11805 5012 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
11806 5012 : break;
11807 :
11808 423 : case GFC_ISYM_SIGN:
11809 423 : gfc_conv_intrinsic_sign (se, expr);
11810 423 : break;
11811 :
11812 15517 : case GFC_ISYM_SIZE:
11813 15517 : gfc_conv_intrinsic_size (se, expr);
11814 15517 : break;
11815 :
11816 1309 : case GFC_ISYM_SIZEOF:
11817 1309 : case GFC_ISYM_C_SIZEOF:
11818 1309 : gfc_conv_intrinsic_sizeof (se, expr);
11819 1309 : break;
11820 :
11821 865 : case GFC_ISYM_STORAGE_SIZE:
11822 865 : gfc_conv_intrinsic_storage_size (se, expr);
11823 865 : break;
11824 :
11825 70 : case GFC_ISYM_SPACING:
11826 70 : gfc_conv_intrinsic_spacing (se, expr);
11827 70 : break;
11828 :
11829 2423 : case GFC_ISYM_STRIDE:
11830 2423 : conv_intrinsic_stride (se, expr);
11831 2423 : break;
11832 :
11833 2011 : case GFC_ISYM_SUM:
11834 2011 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
11835 2011 : break;
11836 :
11837 21 : case GFC_ISYM_TEAM_NUMBER:
11838 21 : conv_intrinsic_team_number (se, expr);
11839 21 : break;
11840 :
11841 4256 : case GFC_ISYM_TRANSFER:
11842 4256 : if (se->ss && se->ss->info->useflags)
11843 : /* Access the previously obtained result. */
11844 281 : gfc_conv_tmp_array_ref (se);
11845 : else
11846 3975 : gfc_conv_intrinsic_transfer (se, expr);
11847 : break;
11848 :
11849 0 : case GFC_ISYM_TTYNAM:
11850 0 : gfc_conv_intrinsic_ttynam (se, expr);
11851 0 : break;
11852 :
11853 5748 : case GFC_ISYM_UBOUND:
11854 5748 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
11855 5748 : break;
11856 :
11857 244 : case GFC_ISYM_UCOBOUND:
11858 244 : conv_intrinsic_cobound (se, expr);
11859 244 : break;
11860 :
11861 18 : case GFC_ISYM_XOR:
11862 18 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11863 18 : break;
11864 :
11865 8993 : case GFC_ISYM_LOC:
11866 8993 : gfc_conv_intrinsic_loc (se, expr);
11867 8993 : break;
11868 :
11869 1514 : case GFC_ISYM_THIS_IMAGE:
11870 : /* For num_images() == 1, handle as LCOBOUND. */
11871 1514 : if (expr->value.function.actual->expr
11872 526 : && flag_coarray == GFC_FCOARRAY_SINGLE)
11873 208 : conv_intrinsic_cobound (se, expr);
11874 : else
11875 1306 : trans_this_image (se, expr);
11876 : break;
11877 :
11878 193 : case GFC_ISYM_IMAGE_INDEX:
11879 193 : trans_image_index (se, expr);
11880 193 : break;
11881 :
11882 25 : case GFC_ISYM_IMAGE_STATUS:
11883 25 : conv_intrinsic_image_status (se, expr);
11884 25 : break;
11885 :
11886 812 : case GFC_ISYM_NUM_IMAGES:
11887 812 : trans_num_images (se, expr);
11888 812 : break;
11889 :
11890 1400 : case GFC_ISYM_ACCESS:
11891 1400 : case GFC_ISYM_CHDIR:
11892 1400 : case GFC_ISYM_CHMOD:
11893 1400 : case GFC_ISYM_DTIME:
11894 1400 : case GFC_ISYM_ETIME:
11895 1400 : case GFC_ISYM_EXTENDS_TYPE_OF:
11896 1400 : case GFC_ISYM_FGET:
11897 1400 : case GFC_ISYM_FGETC:
11898 1400 : case GFC_ISYM_FNUM:
11899 1400 : case GFC_ISYM_FPUT:
11900 1400 : case GFC_ISYM_FPUTC:
11901 1400 : case GFC_ISYM_FSTAT:
11902 1400 : case GFC_ISYM_FTELL:
11903 1400 : case GFC_ISYM_GETCWD:
11904 1400 : case GFC_ISYM_GETGID:
11905 1400 : case GFC_ISYM_GETPID:
11906 1400 : case GFC_ISYM_GETUID:
11907 1400 : case GFC_ISYM_GET_TEAM:
11908 1400 : case GFC_ISYM_HOSTNM:
11909 1400 : case GFC_ISYM_IERRNO:
11910 1400 : case GFC_ISYM_IRAND:
11911 1400 : case GFC_ISYM_ISATTY:
11912 1400 : case GFC_ISYM_JN2:
11913 1400 : case GFC_ISYM_LINK:
11914 1400 : case GFC_ISYM_LSTAT:
11915 1400 : case GFC_ISYM_MATMUL:
11916 1400 : case GFC_ISYM_MCLOCK:
11917 1400 : case GFC_ISYM_MCLOCK8:
11918 1400 : case GFC_ISYM_RAND:
11919 1400 : case GFC_ISYM_REDUCE:
11920 1400 : case GFC_ISYM_RENAME:
11921 1400 : case GFC_ISYM_SECOND:
11922 1400 : case GFC_ISYM_SECNDS:
11923 1400 : case GFC_ISYM_SIGNAL:
11924 1400 : case GFC_ISYM_STAT:
11925 1400 : case GFC_ISYM_SYMLNK:
11926 1400 : case GFC_ISYM_SYSTEM:
11927 1400 : case GFC_ISYM_TIME:
11928 1400 : case GFC_ISYM_TIME8:
11929 1400 : case GFC_ISYM_UMASK:
11930 1400 : case GFC_ISYM_UNLINK:
11931 1400 : case GFC_ISYM_YN2:
11932 1400 : gfc_conv_intrinsic_funcall (se, expr);
11933 1400 : break;
11934 :
11935 0 : case GFC_ISYM_EOSHIFT:
11936 0 : case GFC_ISYM_PACK:
11937 0 : case GFC_ISYM_RESHAPE:
11938 : /* For those, expr->rank should always be >0 and thus the if above the
11939 : switch should have matched. */
11940 0 : gcc_unreachable ();
11941 3928 : break;
11942 :
11943 3928 : default:
11944 3928 : gfc_conv_intrinsic_lib_function (se, expr);
11945 3928 : break;
11946 : }
11947 : }
11948 :
11949 :
11950 : static gfc_ss *
11951 1674 : walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11952 : {
11953 1674 : gfc_ss *arg_ss, *tmp_ss;
11954 1674 : gfc_actual_arglist *arg;
11955 :
11956 1674 : arg = expr->value.function.actual;
11957 :
11958 1674 : gcc_assert (arg->expr);
11959 :
11960 1674 : arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11961 1674 : gcc_assert (arg_ss != gfc_ss_terminator);
11962 :
11963 : for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11964 : {
11965 1785 : if (tmp_ss->info->type != GFC_SS_SCALAR
11966 : && tmp_ss->info->type != GFC_SS_REFERENCE)
11967 : {
11968 1742 : gcc_assert (tmp_ss->dimen == 2);
11969 :
11970 : /* We just invert dimensions. */
11971 1742 : std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
11972 : }
11973 :
11974 : /* Stop when tmp_ss points to the last valid element of the chain... */
11975 1785 : if (tmp_ss->next == gfc_ss_terminator)
11976 : break;
11977 : }
11978 :
11979 : /* ... so that we can attach the rest of the chain to it. */
11980 1674 : tmp_ss->next = ss;
11981 :
11982 1674 : return arg_ss;
11983 : }
11984 :
11985 :
11986 : /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11987 : This has the side effect of reversing the nested list, so there is no
11988 : need to call gfc_reverse_ss on it (the given list is assumed not to be
11989 : reversed yet). */
11990 :
11991 : static gfc_ss *
11992 3371 : nest_loop_dimension (gfc_ss *ss, int dim)
11993 : {
11994 3371 : int ss_dim, i;
11995 3371 : gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11996 3371 : gfc_loopinfo *new_loop;
11997 :
11998 3371 : gcc_assert (ss != gfc_ss_terminator);
11999 :
12000 8118 : for (; ss != gfc_ss_terminator; ss = ss->next)
12001 : {
12002 4747 : new_ss = gfc_get_ss ();
12003 4747 : new_ss->next = prev_ss;
12004 4747 : new_ss->parent = ss;
12005 4747 : new_ss->info = ss->info;
12006 4747 : new_ss->info->refcount++;
12007 4747 : if (ss->dimen != 0)
12008 : {
12009 4684 : gcc_assert (ss->info->type != GFC_SS_SCALAR
12010 : && ss->info->type != GFC_SS_REFERENCE);
12011 :
12012 4684 : new_ss->dimen = 1;
12013 4684 : new_ss->dim[0] = ss->dim[dim];
12014 :
12015 4684 : gcc_assert (dim < ss->dimen);
12016 :
12017 4684 : ss_dim = --ss->dimen;
12018 10430 : for (i = dim; i < ss_dim; i++)
12019 5746 : ss->dim[i] = ss->dim[i + 1];
12020 :
12021 4684 : ss->dim[ss_dim] = 0;
12022 : }
12023 4747 : prev_ss = new_ss;
12024 :
12025 4747 : if (ss->nested_ss)
12026 : {
12027 81 : ss->nested_ss->parent = new_ss;
12028 81 : new_ss->nested_ss = ss->nested_ss;
12029 : }
12030 4747 : ss->nested_ss = new_ss;
12031 : }
12032 :
12033 3371 : new_loop = gfc_get_loopinfo ();
12034 3371 : gfc_init_loopinfo (new_loop);
12035 :
12036 3371 : gcc_assert (prev_ss != NULL);
12037 3371 : gcc_assert (prev_ss != gfc_ss_terminator);
12038 3371 : gfc_add_ss_to_loop (new_loop, prev_ss);
12039 3371 : return new_ss->parent;
12040 : }
12041 :
12042 :
12043 : /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
12044 : is to be inlined. */
12045 :
12046 : static gfc_ss *
12047 575 : walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
12048 : {
12049 575 : gfc_ss *tmp_ss, *tail, *array_ss;
12050 575 : gfc_actual_arglist *arg1, *arg2, *arg3;
12051 575 : int sum_dim;
12052 575 : bool scalar_mask = false;
12053 :
12054 : /* The rank of the result will be determined later. */
12055 575 : arg1 = expr->value.function.actual;
12056 575 : arg2 = arg1->next;
12057 575 : arg3 = arg2->next;
12058 575 : gcc_assert (arg3 != NULL);
12059 :
12060 575 : if (expr->rank == 0)
12061 : return ss;
12062 :
12063 575 : tmp_ss = gfc_ss_terminator;
12064 :
12065 575 : if (arg3->expr)
12066 : {
12067 118 : gfc_ss *mask_ss;
12068 :
12069 118 : mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
12070 118 : if (mask_ss == tmp_ss)
12071 34 : scalar_mask = 1;
12072 :
12073 : tmp_ss = mask_ss;
12074 : }
12075 :
12076 575 : array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
12077 575 : gcc_assert (array_ss != tmp_ss);
12078 :
12079 : /* Odd thing: If the mask is scalar, it is used by the frontend after
12080 : the array (to make an if around the nested loop). Thus it shall
12081 : be after array_ss once the gfc_ss list is reversed. */
12082 575 : if (scalar_mask)
12083 34 : tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
12084 : else
12085 : tmp_ss = array_ss;
12086 :
12087 : /* "Hide" the dimension on which we will sum in the first arg's scalarization
12088 : chain. */
12089 575 : sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
12090 575 : tail = nest_loop_dimension (tmp_ss, sum_dim);
12091 575 : tail->next = ss;
12092 :
12093 575 : return tmp_ss;
12094 : }
12095 :
12096 :
12097 : /* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the
12098 : function is to be inlined. */
12099 :
12100 : static gfc_ss *
12101 6085 : walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
12102 : {
12103 6085 : if (expr->rank == 0)
12104 : return ss;
12105 :
12106 6085 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12107 6085 : gfc_actual_arglist *dim_arg = array_arg->next;
12108 6085 : gfc_actual_arglist *mask_arg = dim_arg->next;
12109 6085 : gfc_actual_arglist *kind_arg = mask_arg->next;
12110 6085 : gfc_actual_arglist *back_arg = kind_arg->next;
12111 :
12112 6085 : gfc_expr *array = array_arg->expr;
12113 6085 : gfc_expr *dim = dim_arg->expr;
12114 6085 : gfc_expr *mask = mask_arg->expr;
12115 6085 : gfc_expr *back = back_arg->expr;
12116 :
12117 6085 : if (dim == nullptr)
12118 3289 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12119 :
12120 2796 : gfc_ss *tmp_ss = gfc_ss_terminator;
12121 :
12122 2796 : bool scalar_mask = false;
12123 2796 : if (mask)
12124 : {
12125 1866 : gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
12126 1866 : if (mask_ss == tmp_ss)
12127 : scalar_mask = true;
12128 1174 : else if (maybe_absent_optional_variable (mask))
12129 20 : mask_ss->info->can_be_null_ref = true;
12130 :
12131 : tmp_ss = mask_ss;
12132 : }
12133 :
12134 2796 : gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
12135 2796 : gcc_assert (array_ss != tmp_ss);
12136 :
12137 2796 : tmp_ss = array_ss;
12138 :
12139 : /* Move the dimension on which we will sum to a separate nested scalarization
12140 : chain, "hiding" that dimension from the outer scalarization. */
12141 2796 : int dim_val = mpz_get_si (dim->value.integer);
12142 2796 : gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
12143 :
12144 2796 : if (back && array->rank > 1)
12145 : {
12146 : /* If there are nested scalarization loops, include BACK in the
12147 : scalarization chains to avoid evaluating it multiple times in a loop.
12148 : Otherwise, prefer to handle it outside of scalarization. */
12149 2796 : gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
12150 2796 : back_ss->info->type = GFC_SS_REFERENCE;
12151 2796 : if (maybe_absent_optional_variable (back))
12152 16 : back_ss->info->can_be_null_ref = true;
12153 :
12154 2796 : tail->next = back_ss;
12155 2796 : }
12156 : else
12157 0 : tail->next = ss;
12158 :
12159 2796 : if (scalar_mask)
12160 : {
12161 692 : tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
12162 : /* MASK can be a forwarded optional argument, so make the necessary setup
12163 : to avoid the scalarizer generating any unguarded pointer dereference in
12164 : that case. */
12165 692 : tmp_ss->info->type = GFC_SS_REFERENCE;
12166 692 : if (maybe_absent_optional_variable (mask))
12167 4 : tmp_ss->info->can_be_null_ref = true;
12168 : }
12169 :
12170 : return tmp_ss;
12171 : }
12172 :
12173 :
12174 : static gfc_ss *
12175 8334 : walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
12176 : {
12177 :
12178 8334 : switch (expr->value.function.isym->id)
12179 : {
12180 575 : case GFC_ISYM_PRODUCT:
12181 575 : case GFC_ISYM_SUM:
12182 575 : return walk_inline_intrinsic_arith (ss, expr);
12183 :
12184 1674 : case GFC_ISYM_TRANSPOSE:
12185 1674 : return walk_inline_intrinsic_transpose (ss, expr);
12186 :
12187 6085 : case GFC_ISYM_MAXLOC:
12188 6085 : case GFC_ISYM_MINLOC:
12189 6085 : return walk_inline_intrinsic_minmaxloc (ss, expr);
12190 :
12191 0 : default:
12192 0 : gcc_unreachable ();
12193 : }
12194 : gcc_unreachable ();
12195 : }
12196 :
12197 :
12198 : /* This generates code to execute before entering the scalarization loop.
12199 : Currently does nothing. */
12200 :
12201 : void
12202 11605 : gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
12203 : {
12204 11605 : switch (ss->info->expr->value.function.isym->id)
12205 : {
12206 11605 : case GFC_ISYM_UBOUND:
12207 11605 : case GFC_ISYM_LBOUND:
12208 11605 : case GFC_ISYM_COSHAPE:
12209 11605 : case GFC_ISYM_UCOBOUND:
12210 11605 : case GFC_ISYM_LCOBOUND:
12211 11605 : case GFC_ISYM_MAXLOC:
12212 11605 : case GFC_ISYM_MINLOC:
12213 11605 : case GFC_ISYM_THIS_IMAGE:
12214 11605 : case GFC_ISYM_SHAPE:
12215 11605 : break;
12216 :
12217 0 : default:
12218 0 : gcc_unreachable ();
12219 : }
12220 11605 : }
12221 :
12222 :
12223 : /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
12224 : one parameter are expanded into code inside the scalarization loop. */
12225 :
12226 : static gfc_ss *
12227 10185 : gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
12228 : {
12229 10185 : if (expr->value.function.actual->expr->ts.type == BT_CLASS)
12230 438 : gfc_add_class_array_ref (expr->value.function.actual->expr);
12231 :
12232 : /* The two argument version returns a scalar. */
12233 10185 : if (expr->value.function.isym->id != GFC_ISYM_SHAPE
12234 3522 : && expr->value.function.isym->id != GFC_ISYM_COSHAPE
12235 3518 : && expr->value.function.actual->next->expr)
12236 : return ss;
12237 :
12238 10185 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12239 : }
12240 :
12241 :
12242 : /* Walk an intrinsic array libcall. */
12243 :
12244 : static gfc_ss *
12245 14506 : gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
12246 : {
12247 14506 : gcc_assert (expr->rank > 0);
12248 14506 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12249 : }
12250 :
12251 :
12252 : /* Return whether the function call expression EXPR will be expanded
12253 : inline by gfc_conv_intrinsic_function. */
12254 :
12255 : bool
12256 304338 : gfc_inline_intrinsic_function_p (gfc_expr *expr)
12257 : {
12258 304338 : gfc_actual_arglist *args, *dim_arg, *mask_arg;
12259 304338 : gfc_expr *maskexpr;
12260 :
12261 304338 : gfc_intrinsic_sym *isym = expr->value.function.isym;
12262 304338 : if (!isym)
12263 : return false;
12264 :
12265 304296 : switch (isym->id)
12266 : {
12267 5111 : case GFC_ISYM_PRODUCT:
12268 5111 : case GFC_ISYM_SUM:
12269 : /* Disable inline expansion if code size matters. */
12270 5111 : if (optimize_size)
12271 : return false;
12272 :
12273 4255 : args = expr->value.function.actual;
12274 4255 : dim_arg = args->next;
12275 :
12276 : /* We need to be able to subset the SUM argument at compile-time. */
12277 4255 : if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
12278 : return false;
12279 :
12280 : /* FIXME: If MASK is optional for a more than two-dimensional
12281 : argument, the scalarizer gets confused if the mask is
12282 : absent. See PR 82995. For now, fall back to the library
12283 : function. */
12284 :
12285 3643 : mask_arg = dim_arg->next;
12286 3643 : maskexpr = mask_arg->expr;
12287 :
12288 3643 : if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
12289 276 : && maskexpr->symtree->n.sym->attr.dummy
12290 48 : && maskexpr->symtree->n.sym->attr.optional)
12291 : return false;
12292 :
12293 : return true;
12294 :
12295 : case GFC_ISYM_TRANSPOSE:
12296 : return true;
12297 :
12298 57188 : case GFC_ISYM_MINLOC:
12299 57188 : case GFC_ISYM_MAXLOC:
12300 57188 : {
12301 57188 : if ((isym->id == GFC_ISYM_MINLOC
12302 30521 : && (flag_inline_intrinsics
12303 30521 : & GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0)
12304 46611 : || (isym->id == GFC_ISYM_MAXLOC
12305 26667 : && (flag_inline_intrinsics
12306 26667 : & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0))
12307 : return false;
12308 :
12309 37638 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12310 37638 : gfc_actual_arglist *dim_arg = array_arg->next;
12311 :
12312 37638 : gfc_expr *array = array_arg->expr;
12313 37638 : gfc_expr *dim = dim_arg->expr;
12314 :
12315 37638 : if (!(array->ts.type == BT_INTEGER
12316 : || array->ts.type == BT_REAL))
12317 : return false;
12318 :
12319 34658 : if (array->rank == 1)
12320 : return true;
12321 :
12322 20711 : if (dim != nullptr
12323 13372 : && dim->expr_type != EXPR_CONSTANT)
12324 : return false;
12325 :
12326 : return true;
12327 : }
12328 :
12329 : default:
12330 : return false;
12331 : }
12332 : }
12333 :
12334 :
12335 : /* Returns nonzero if the specified intrinsic function call maps directly to
12336 : an external library call. Should only be used for functions that return
12337 : arrays. */
12338 :
12339 : int
12340 88103 : gfc_is_intrinsic_libcall (gfc_expr * expr)
12341 : {
12342 88103 : gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
12343 88103 : gcc_assert (expr->rank > 0);
12344 :
12345 88103 : if (gfc_inline_intrinsic_function_p (expr))
12346 : return 0;
12347 :
12348 73486 : switch (expr->value.function.isym->id)
12349 : {
12350 : case GFC_ISYM_ALL:
12351 : case GFC_ISYM_ANY:
12352 : case GFC_ISYM_COUNT:
12353 : case GFC_ISYM_FINDLOC:
12354 : case GFC_ISYM_JN2:
12355 : case GFC_ISYM_IANY:
12356 : case GFC_ISYM_IALL:
12357 : case GFC_ISYM_IPARITY:
12358 : case GFC_ISYM_MATMUL:
12359 : case GFC_ISYM_MAXLOC:
12360 : case GFC_ISYM_MAXVAL:
12361 : case GFC_ISYM_MINLOC:
12362 : case GFC_ISYM_MINVAL:
12363 : case GFC_ISYM_NORM2:
12364 : case GFC_ISYM_PARITY:
12365 : case GFC_ISYM_PRODUCT:
12366 : case GFC_ISYM_SUM:
12367 : case GFC_ISYM_SPREAD:
12368 : case GFC_ISYM_YN2:
12369 : /* Ignore absent optional parameters. */
12370 : return 1;
12371 :
12372 15855 : case GFC_ISYM_CSHIFT:
12373 15855 : case GFC_ISYM_EOSHIFT:
12374 15855 : case GFC_ISYM_GET_TEAM:
12375 15855 : case GFC_ISYM_FAILED_IMAGES:
12376 15855 : case GFC_ISYM_STOPPED_IMAGES:
12377 15855 : case GFC_ISYM_PACK:
12378 15855 : case GFC_ISYM_REDUCE:
12379 15855 : case GFC_ISYM_RESHAPE:
12380 15855 : case GFC_ISYM_UNPACK:
12381 : /* Pass absent optional parameters. */
12382 15855 : return 2;
12383 :
12384 : default:
12385 : return 0;
12386 : }
12387 : }
12388 :
12389 : /* Walk an intrinsic function. */
12390 : gfc_ss *
12391 55955 : gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
12392 : gfc_intrinsic_sym * isym)
12393 : {
12394 55955 : gcc_assert (isym);
12395 :
12396 55955 : if (isym->elemental)
12397 18432 : return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
12398 : expr->value.function.isym,
12399 18432 : GFC_SS_SCALAR);
12400 :
12401 37523 : if (expr->rank == 0 && expr->corank == 0)
12402 : return ss;
12403 :
12404 33025 : if (gfc_inline_intrinsic_function_p (expr))
12405 8334 : return walk_inline_intrinsic_function (ss, expr);
12406 :
12407 24691 : if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
12408 13523 : return gfc_walk_intrinsic_libfunc (ss, expr);
12409 :
12410 : /* Special cases. */
12411 11168 : switch (isym->id)
12412 : {
12413 10185 : case GFC_ISYM_COSHAPE:
12414 10185 : case GFC_ISYM_LBOUND:
12415 10185 : case GFC_ISYM_LCOBOUND:
12416 10185 : case GFC_ISYM_UBOUND:
12417 10185 : case GFC_ISYM_UCOBOUND:
12418 10185 : case GFC_ISYM_THIS_IMAGE:
12419 10185 : case GFC_ISYM_SHAPE:
12420 10185 : return gfc_walk_intrinsic_bound (ss, expr);
12421 :
12422 983 : case GFC_ISYM_TRANSFER:
12423 983 : case GFC_ISYM_CAF_GET:
12424 983 : return gfc_walk_intrinsic_libfunc (ss, expr);
12425 :
12426 0 : default:
12427 : /* This probably meant someone forgot to add an intrinsic to the above
12428 : list(s) when they implemented it, or something's gone horribly
12429 : wrong. */
12430 0 : gcc_unreachable ();
12431 : }
12432 : }
12433 :
12434 : static tree
12435 91 : conv_co_collective (gfc_code *code)
12436 : {
12437 91 : gfc_se argse;
12438 91 : stmtblock_t block, post_block;
12439 91 : tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
12440 91 : gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
12441 :
12442 91 : gfc_start_block (&block);
12443 91 : gfc_init_block (&post_block);
12444 :
12445 91 : if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
12446 : {
12447 17 : opr_expr = code->ext.actual->next->expr;
12448 17 : image_idx_expr = code->ext.actual->next->next->expr;
12449 17 : stat_expr = code->ext.actual->next->next->next->expr;
12450 17 : errmsg_expr = code->ext.actual->next->next->next->next->expr;
12451 : }
12452 : else
12453 : {
12454 74 : opr_expr = NULL;
12455 74 : image_idx_expr = code->ext.actual->next->expr;
12456 74 : stat_expr = code->ext.actual->next->next->expr;
12457 74 : errmsg_expr = code->ext.actual->next->next->next->expr;
12458 : }
12459 :
12460 : /* stat. */
12461 91 : if (stat_expr)
12462 : {
12463 59 : gfc_init_se (&argse, NULL);
12464 59 : gfc_conv_expr (&argse, stat_expr);
12465 59 : gfc_add_block_to_block (&block, &argse.pre);
12466 59 : gfc_add_block_to_block (&post_block, &argse.post);
12467 59 : stat = argse.expr;
12468 59 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
12469 32 : stat = gfc_build_addr_expr (NULL_TREE, stat);
12470 : }
12471 32 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
12472 : stat = NULL_TREE;
12473 : else
12474 22 : stat = null_pointer_node;
12475 :
12476 : /* Early exit for GFC_FCOARRAY_SINGLE. */
12477 91 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
12478 : {
12479 37 : if (stat != NULL_TREE)
12480 : {
12481 : /* For optional stats, check the pointer is valid before zero'ing. */
12482 27 : if (gfc_expr_attr (stat_expr).optional)
12483 : {
12484 12 : tree tmp;
12485 12 : stmtblock_t ass_block;
12486 12 : gfc_start_block (&ass_block);
12487 12 : gfc_add_modify (&ass_block, stat,
12488 12 : fold_convert (TREE_TYPE (stat),
12489 : integer_zero_node));
12490 12 : tmp = fold_build2 (NE_EXPR, logical_type_node,
12491 : gfc_build_addr_expr (NULL_TREE, stat),
12492 : null_pointer_node);
12493 12 : tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
12494 : gfc_finish_block (&ass_block),
12495 : build_empty_stmt (input_location));
12496 12 : gfc_add_expr_to_block (&block, tmp);
12497 : }
12498 : else
12499 15 : gfc_add_modify (&block, stat,
12500 15 : fold_convert (TREE_TYPE (stat), integer_zero_node));
12501 : }
12502 37 : return gfc_finish_block (&block);
12503 : }
12504 :
12505 5 : gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
12506 54 : ? code->ext.actual->expr->ts.u.derived : NULL;
12507 :
12508 : /* Handle the array. */
12509 54 : gfc_init_se (&argse, NULL);
12510 54 : if (!derived || !derived->attr.alloc_comp
12511 1 : || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
12512 : {
12513 53 : if (code->ext.actual->expr->rank == 0)
12514 : {
12515 22 : symbol_attribute attr;
12516 22 : gfc_clear_attr (&attr);
12517 22 : gfc_init_se (&argse, NULL);
12518 22 : gfc_conv_expr (&argse, code->ext.actual->expr);
12519 22 : gfc_add_block_to_block (&block, &argse.pre);
12520 22 : gfc_add_block_to_block (&post_block, &argse.post);
12521 22 : array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
12522 22 : array = gfc_build_addr_expr (NULL_TREE, array);
12523 : }
12524 : else
12525 : {
12526 31 : argse.want_pointer = 1;
12527 31 : gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
12528 31 : array = argse.expr;
12529 : }
12530 : }
12531 :
12532 54 : gfc_add_block_to_block (&block, &argse.pre);
12533 54 : gfc_add_block_to_block (&post_block, &argse.post);
12534 :
12535 54 : if (code->ext.actual->expr->ts.type == BT_CHARACTER)
12536 15 : strlen = argse.string_length;
12537 : else
12538 39 : strlen = integer_zero_node;
12539 :
12540 : /* image_index. */
12541 54 : if (image_idx_expr)
12542 : {
12543 35 : gfc_init_se (&argse, NULL);
12544 35 : gfc_conv_expr (&argse, image_idx_expr);
12545 35 : gfc_add_block_to_block (&block, &argse.pre);
12546 35 : gfc_add_block_to_block (&post_block, &argse.post);
12547 35 : image_index = fold_convert (integer_type_node, argse.expr);
12548 : }
12549 : else
12550 19 : image_index = integer_zero_node;
12551 :
12552 : /* errmsg. */
12553 54 : if (errmsg_expr)
12554 : {
12555 25 : gfc_init_se (&argse, NULL);
12556 25 : gfc_conv_expr (&argse, errmsg_expr);
12557 25 : gfc_add_block_to_block (&block, &argse.pre);
12558 25 : gfc_add_block_to_block (&post_block, &argse.post);
12559 25 : errmsg = argse.expr;
12560 25 : errmsg_len = fold_convert (size_type_node, argse.string_length);
12561 : }
12562 : else
12563 : {
12564 29 : errmsg = null_pointer_node;
12565 29 : errmsg_len = build_zero_cst (size_type_node);
12566 : }
12567 :
12568 : /* Generate the function call. */
12569 54 : switch (code->resolved_isym->id)
12570 : {
12571 20 : case GFC_ISYM_CO_BROADCAST:
12572 20 : fndecl = gfor_fndecl_co_broadcast;
12573 20 : break;
12574 8 : case GFC_ISYM_CO_MAX:
12575 8 : fndecl = gfor_fndecl_co_max;
12576 8 : break;
12577 6 : case GFC_ISYM_CO_MIN:
12578 6 : fndecl = gfor_fndecl_co_min;
12579 6 : break;
12580 12 : case GFC_ISYM_CO_REDUCE:
12581 12 : fndecl = gfor_fndecl_co_reduce;
12582 12 : break;
12583 8 : case GFC_ISYM_CO_SUM:
12584 8 : fndecl = gfor_fndecl_co_sum;
12585 8 : break;
12586 0 : default:
12587 0 : gcc_unreachable ();
12588 : }
12589 :
12590 54 : if (derived && derived->attr.alloc_comp
12591 1 : && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12592 : /* The derived type has the attribute 'alloc_comp'. */
12593 : {
12594 2 : tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
12595 1 : code->ext.actual->expr->rank,
12596 : image_index, stat, errmsg, errmsg_len);
12597 1 : gfc_add_expr_to_block (&block, tmp);
12598 1 : }
12599 : else
12600 : {
12601 53 : if (code->resolved_isym->id == GFC_ISYM_CO_SUM
12602 45 : || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12603 27 : fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
12604 : image_index, stat, errmsg, errmsg_len);
12605 26 : else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
12606 14 : fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
12607 : image_index, stat, errmsg,
12608 : strlen, errmsg_len);
12609 : else
12610 : {
12611 12 : tree opr, opr_flags;
12612 :
12613 : // FIXME: Handle TS29113's bind(C) strings with descriptor.
12614 12 : int opr_flag_int;
12615 12 : if (gfc_is_proc_ptr_comp (opr_expr))
12616 : {
12617 0 : gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
12618 0 : opr_flag_int = sym->attr.dimension
12619 0 : || (sym->ts.type == BT_CHARACTER
12620 0 : && !sym->attr.is_bind_c)
12621 0 : ? GFC_CAF_BYREF : 0;
12622 0 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12623 0 : && !sym->attr.is_bind_c
12624 0 : ? GFC_CAF_HIDDENLEN : 0;
12625 0 : opr_flag_int |= sym->formal->sym->attr.value
12626 0 : ? GFC_CAF_ARG_VALUE : 0;
12627 : }
12628 : else
12629 : {
12630 12 : opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
12631 12 : ? GFC_CAF_BYREF : 0;
12632 24 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12633 0 : && !opr_expr->symtree->n.sym->attr.is_bind_c
12634 12 : ? GFC_CAF_HIDDENLEN : 0;
12635 12 : opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
12636 12 : ? GFC_CAF_ARG_VALUE : 0;
12637 : }
12638 12 : opr_flags = build_int_cst (integer_type_node, opr_flag_int);
12639 12 : gfc_conv_expr (&argse, opr_expr);
12640 12 : opr = argse.expr;
12641 12 : fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
12642 : opr_flags, image_index, stat, errmsg,
12643 : strlen, errmsg_len);
12644 : }
12645 : }
12646 :
12647 54 : gfc_add_expr_to_block (&block, fndecl);
12648 54 : gfc_add_block_to_block (&block, &post_block);
12649 :
12650 54 : return gfc_finish_block (&block);
12651 : }
12652 :
12653 :
12654 : static tree
12655 95 : conv_intrinsic_atomic_op (gfc_code *code)
12656 : {
12657 95 : gfc_se argse;
12658 95 : tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
12659 95 : stmtblock_t block, post_block;
12660 95 : gfc_expr *atom_expr = code->ext.actual->expr;
12661 95 : gfc_expr *stat_expr;
12662 95 : built_in_function fn;
12663 :
12664 95 : if (atom_expr->expr_type == EXPR_FUNCTION
12665 0 : && atom_expr->value.function.isym
12666 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12667 0 : atom_expr = atom_expr->value.function.actual->expr;
12668 :
12669 95 : gfc_start_block (&block);
12670 95 : gfc_init_block (&post_block);
12671 :
12672 95 : gfc_init_se (&argse, NULL);
12673 95 : argse.want_pointer = 1;
12674 95 : gfc_conv_expr (&argse, atom_expr);
12675 95 : gfc_add_block_to_block (&block, &argse.pre);
12676 95 : gfc_add_block_to_block (&post_block, &argse.post);
12677 95 : atom = argse.expr;
12678 :
12679 95 : gfc_init_se (&argse, NULL);
12680 95 : if (flag_coarray == GFC_FCOARRAY_LIB
12681 56 : && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
12682 54 : argse.want_pointer = 1;
12683 95 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12684 95 : gfc_add_block_to_block (&block, &argse.pre);
12685 95 : gfc_add_block_to_block (&post_block, &argse.post);
12686 95 : value = argse.expr;
12687 :
12688 95 : switch (code->resolved_isym->id)
12689 : {
12690 58 : case GFC_ISYM_ATOMIC_ADD:
12691 58 : case GFC_ISYM_ATOMIC_AND:
12692 58 : case GFC_ISYM_ATOMIC_DEF:
12693 58 : case GFC_ISYM_ATOMIC_OR:
12694 58 : case GFC_ISYM_ATOMIC_XOR:
12695 58 : stat_expr = code->ext.actual->next->next->expr;
12696 58 : if (flag_coarray == GFC_FCOARRAY_LIB)
12697 34 : old = null_pointer_node;
12698 : break;
12699 37 : default:
12700 37 : gfc_init_se (&argse, NULL);
12701 37 : if (flag_coarray == GFC_FCOARRAY_LIB)
12702 22 : argse.want_pointer = 1;
12703 37 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12704 37 : gfc_add_block_to_block (&block, &argse.pre);
12705 37 : gfc_add_block_to_block (&post_block, &argse.post);
12706 37 : old = argse.expr;
12707 37 : stat_expr = code->ext.actual->next->next->next->expr;
12708 : }
12709 :
12710 : /* STAT= */
12711 95 : if (stat_expr != NULL)
12712 : {
12713 82 : gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
12714 82 : gfc_init_se (&argse, NULL);
12715 82 : if (flag_coarray == GFC_FCOARRAY_LIB)
12716 48 : argse.want_pointer = 1;
12717 82 : gfc_conv_expr_val (&argse, stat_expr);
12718 82 : gfc_add_block_to_block (&block, &argse.pre);
12719 82 : gfc_add_block_to_block (&post_block, &argse.post);
12720 82 : stat = argse.expr;
12721 : }
12722 13 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12723 8 : stat = null_pointer_node;
12724 :
12725 95 : if (flag_coarray == GFC_FCOARRAY_LIB)
12726 : {
12727 56 : tree image_index, caf_decl, offset, token;
12728 56 : int op;
12729 :
12730 56 : switch (code->resolved_isym->id)
12731 : {
12732 : case GFC_ISYM_ATOMIC_ADD:
12733 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12734 : op = (int) GFC_CAF_ATOMIC_ADD;
12735 : break;
12736 12 : case GFC_ISYM_ATOMIC_AND:
12737 12 : case GFC_ISYM_ATOMIC_FETCH_AND:
12738 12 : op = (int) GFC_CAF_ATOMIC_AND;
12739 12 : break;
12740 12 : case GFC_ISYM_ATOMIC_OR:
12741 12 : case GFC_ISYM_ATOMIC_FETCH_OR:
12742 12 : op = (int) GFC_CAF_ATOMIC_OR;
12743 12 : break;
12744 12 : case GFC_ISYM_ATOMIC_XOR:
12745 12 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12746 12 : op = (int) GFC_CAF_ATOMIC_XOR;
12747 12 : break;
12748 11 : case GFC_ISYM_ATOMIC_DEF:
12749 11 : op = 0; /* Unused. */
12750 11 : break;
12751 0 : default:
12752 0 : gcc_unreachable ();
12753 : }
12754 :
12755 56 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12756 56 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12757 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12758 :
12759 56 : if (gfc_is_coindexed (atom_expr))
12760 48 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12761 : else
12762 8 : image_index = integer_zero_node;
12763 :
12764 : /* Ensure VALUE names addressable storage: taking the address of a
12765 : constant is invalid in C, and scalars need a temporary as well. */
12766 56 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12767 : {
12768 42 : tree elem
12769 42 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value);
12770 42 : elem = gfc_trans_force_lval (&block, elem);
12771 42 : value = gfc_build_addr_expr (NULL_TREE, elem);
12772 : }
12773 14 : else if (TREE_CODE (value) == ADDR_EXPR
12774 14 : && TREE_CONSTANT (TREE_OPERAND (value, 0)))
12775 : {
12776 0 : tree elem
12777 0 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)),
12778 : build_fold_indirect_ref (value));
12779 0 : elem = gfc_trans_force_lval (&block, elem);
12780 0 : value = gfc_build_addr_expr (NULL_TREE, elem);
12781 : }
12782 :
12783 56 : gfc_init_se (&argse, NULL);
12784 56 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12785 : atom_expr);
12786 :
12787 56 : gfc_add_block_to_block (&block, &argse.pre);
12788 56 : if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
12789 11 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
12790 : token, offset, image_index, value, stat,
12791 : build_int_cst (integer_type_node,
12792 11 : (int) atom_expr->ts.type),
12793 : build_int_cst (integer_type_node,
12794 11 : (int) atom_expr->ts.kind));
12795 : else
12796 45 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
12797 45 : build_int_cst (integer_type_node, op),
12798 : token, offset, image_index, value, old, stat,
12799 : build_int_cst (integer_type_node,
12800 45 : (int) atom_expr->ts.type),
12801 : build_int_cst (integer_type_node,
12802 45 : (int) atom_expr->ts.kind));
12803 :
12804 56 : gfc_add_expr_to_block (&block, tmp);
12805 56 : gfc_add_block_to_block (&block, &argse.post);
12806 56 : gfc_add_block_to_block (&block, &post_block);
12807 56 : return gfc_finish_block (&block);
12808 : }
12809 :
12810 :
12811 39 : switch (code->resolved_isym->id)
12812 : {
12813 : case GFC_ISYM_ATOMIC_ADD:
12814 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12815 : fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
12816 : break;
12817 8 : case GFC_ISYM_ATOMIC_AND:
12818 8 : case GFC_ISYM_ATOMIC_FETCH_AND:
12819 8 : fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12820 8 : break;
12821 9 : case GFC_ISYM_ATOMIC_DEF:
12822 9 : fn = BUILT_IN_ATOMIC_STORE_N;
12823 9 : break;
12824 8 : case GFC_ISYM_ATOMIC_OR:
12825 8 : case GFC_ISYM_ATOMIC_FETCH_OR:
12826 8 : fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12827 8 : break;
12828 8 : case GFC_ISYM_ATOMIC_XOR:
12829 8 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12830 8 : fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12831 8 : break;
12832 0 : default:
12833 0 : gcc_unreachable ();
12834 : }
12835 :
12836 39 : tmp = TREE_TYPE (TREE_TYPE (atom));
12837 78 : fn = (built_in_function) ((int) fn
12838 39 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12839 39 : + 1);
12840 39 : tree itype = TREE_TYPE (TREE_TYPE (atom));
12841 39 : tmp = builtin_decl_explicit (fn);
12842 :
12843 39 : switch (code->resolved_isym->id)
12844 : {
12845 24 : case GFC_ISYM_ATOMIC_ADD:
12846 24 : case GFC_ISYM_ATOMIC_AND:
12847 24 : case GFC_ISYM_ATOMIC_DEF:
12848 24 : case GFC_ISYM_ATOMIC_OR:
12849 24 : case GFC_ISYM_ATOMIC_XOR:
12850 24 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12851 : fold_convert (itype, value),
12852 : build_int_cst (NULL, MEMMODEL_RELAXED));
12853 24 : gfc_add_expr_to_block (&block, tmp);
12854 24 : break;
12855 15 : default:
12856 15 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12857 : fold_convert (itype, value),
12858 : build_int_cst (NULL, MEMMODEL_RELAXED));
12859 15 : gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12860 15 : break;
12861 : }
12862 :
12863 39 : if (stat != NULL_TREE)
12864 34 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12865 39 : gfc_add_block_to_block (&block, &post_block);
12866 39 : return gfc_finish_block (&block);
12867 : }
12868 :
12869 :
12870 : static tree
12871 176 : conv_intrinsic_atomic_ref (gfc_code *code)
12872 : {
12873 176 : gfc_se argse;
12874 176 : tree tmp, atom, value, stat = NULL_TREE;
12875 176 : stmtblock_t block, post_block;
12876 176 : built_in_function fn;
12877 176 : gfc_expr *atom_expr = code->ext.actual->next->expr;
12878 :
12879 176 : if (atom_expr->expr_type == EXPR_FUNCTION
12880 0 : && atom_expr->value.function.isym
12881 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12882 0 : atom_expr = atom_expr->value.function.actual->expr;
12883 :
12884 176 : gfc_start_block (&block);
12885 176 : gfc_init_block (&post_block);
12886 176 : gfc_init_se (&argse, NULL);
12887 176 : argse.want_pointer = 1;
12888 176 : gfc_conv_expr (&argse, atom_expr);
12889 176 : gfc_add_block_to_block (&block, &argse.pre);
12890 176 : gfc_add_block_to_block (&post_block, &argse.post);
12891 176 : atom = argse.expr;
12892 :
12893 176 : gfc_init_se (&argse, NULL);
12894 176 : if (flag_coarray == GFC_FCOARRAY_LIB
12895 115 : && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12896 109 : argse.want_pointer = 1;
12897 176 : gfc_conv_expr (&argse, code->ext.actual->expr);
12898 176 : gfc_add_block_to_block (&block, &argse.pre);
12899 176 : gfc_add_block_to_block (&post_block, &argse.post);
12900 176 : value = argse.expr;
12901 :
12902 : /* STAT= */
12903 176 : if (code->ext.actual->next->next->expr != NULL)
12904 : {
12905 164 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12906 : == EXPR_VARIABLE);
12907 164 : gfc_init_se (&argse, NULL);
12908 164 : if (flag_coarray == GFC_FCOARRAY_LIB)
12909 108 : argse.want_pointer = 1;
12910 164 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12911 164 : gfc_add_block_to_block (&block, &argse.pre);
12912 164 : gfc_add_block_to_block (&post_block, &argse.post);
12913 164 : stat = argse.expr;
12914 : }
12915 12 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12916 7 : stat = null_pointer_node;
12917 :
12918 176 : if (flag_coarray == GFC_FCOARRAY_LIB)
12919 : {
12920 115 : tree image_index, caf_decl, offset, token;
12921 115 : tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12922 :
12923 115 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12924 115 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12925 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12926 :
12927 115 : if (gfc_is_coindexed (atom_expr))
12928 103 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12929 : else
12930 12 : image_index = integer_zero_node;
12931 :
12932 115 : gfc_init_se (&argse, NULL);
12933 115 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12934 : atom_expr);
12935 115 : gfc_add_block_to_block (&block, &argse.pre);
12936 :
12937 : /* Different type, need type conversion. */
12938 115 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12939 : {
12940 6 : vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12941 6 : orig_value = value;
12942 6 : value = gfc_build_addr_expr (NULL_TREE, vardecl);
12943 : }
12944 :
12945 115 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12946 : token, offset, image_index, value, stat,
12947 : build_int_cst (integer_type_node,
12948 115 : (int) atom_expr->ts.type),
12949 : build_int_cst (integer_type_node,
12950 115 : (int) atom_expr->ts.kind));
12951 115 : gfc_add_expr_to_block (&block, tmp);
12952 115 : if (vardecl != NULL_TREE)
12953 6 : gfc_add_modify (&block, orig_value,
12954 6 : fold_convert (TREE_TYPE (orig_value), vardecl));
12955 115 : gfc_add_block_to_block (&block, &argse.post);
12956 115 : gfc_add_block_to_block (&block, &post_block);
12957 115 : return gfc_finish_block (&block);
12958 : }
12959 :
12960 61 : tmp = TREE_TYPE (TREE_TYPE (atom));
12961 122 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12962 61 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12963 61 : + 1);
12964 61 : tmp = builtin_decl_explicit (fn);
12965 61 : tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12966 : build_int_cst (integer_type_node,
12967 : MEMMODEL_RELAXED));
12968 61 : gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12969 :
12970 61 : if (stat != NULL_TREE)
12971 56 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12972 61 : gfc_add_block_to_block (&block, &post_block);
12973 61 : return gfc_finish_block (&block);
12974 : }
12975 :
12976 :
12977 : static tree
12978 14 : conv_intrinsic_atomic_cas (gfc_code *code)
12979 : {
12980 14 : gfc_se argse;
12981 14 : tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12982 14 : stmtblock_t block, post_block;
12983 14 : built_in_function fn;
12984 14 : gfc_expr *atom_expr = code->ext.actual->expr;
12985 :
12986 14 : if (atom_expr->expr_type == EXPR_FUNCTION
12987 0 : && atom_expr->value.function.isym
12988 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12989 0 : atom_expr = atom_expr->value.function.actual->expr;
12990 :
12991 14 : gfc_init_block (&block);
12992 14 : gfc_init_block (&post_block);
12993 14 : gfc_init_se (&argse, NULL);
12994 14 : argse.want_pointer = 1;
12995 14 : gfc_conv_expr (&argse, atom_expr);
12996 14 : atom = argse.expr;
12997 :
12998 14 : gfc_init_se (&argse, NULL);
12999 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13000 8 : argse.want_pointer = 1;
13001 14 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
13002 14 : gfc_add_block_to_block (&block, &argse.pre);
13003 14 : gfc_add_block_to_block (&post_block, &argse.post);
13004 14 : old = argse.expr;
13005 :
13006 14 : gfc_init_se (&argse, NULL);
13007 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13008 8 : argse.want_pointer = 1;
13009 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
13010 14 : gfc_add_block_to_block (&block, &argse.pre);
13011 14 : gfc_add_block_to_block (&post_block, &argse.post);
13012 14 : comp = argse.expr;
13013 :
13014 14 : gfc_init_se (&argse, NULL);
13015 14 : if (flag_coarray == GFC_FCOARRAY_LIB
13016 8 : && code->ext.actual->next->next->next->expr->ts.kind
13017 8 : == atom_expr->ts.kind)
13018 8 : argse.want_pointer = 1;
13019 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
13020 14 : gfc_add_block_to_block (&block, &argse.pre);
13021 14 : gfc_add_block_to_block (&post_block, &argse.post);
13022 14 : new_val = argse.expr;
13023 :
13024 : /* STAT= */
13025 14 : if (code->ext.actual->next->next->next->next->expr != NULL)
13026 : {
13027 14 : gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
13028 : == EXPR_VARIABLE);
13029 14 : gfc_init_se (&argse, NULL);
13030 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13031 8 : argse.want_pointer = 1;
13032 14 : gfc_conv_expr_val (&argse,
13033 14 : code->ext.actual->next->next->next->next->expr);
13034 14 : gfc_add_block_to_block (&block, &argse.pre);
13035 14 : gfc_add_block_to_block (&post_block, &argse.post);
13036 14 : stat = argse.expr;
13037 : }
13038 0 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13039 0 : stat = null_pointer_node;
13040 :
13041 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13042 : {
13043 8 : tree image_index, caf_decl, offset, token;
13044 :
13045 8 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
13046 8 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
13047 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
13048 :
13049 8 : if (gfc_is_coindexed (atom_expr))
13050 8 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
13051 : else
13052 0 : image_index = integer_zero_node;
13053 :
13054 8 : if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
13055 : {
13056 0 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
13057 0 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
13058 0 : new_val = gfc_build_addr_expr (NULL_TREE, tmp);
13059 : }
13060 :
13061 8 : gfc_init_se (&argse, NULL);
13062 8 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
13063 : atom_expr);
13064 8 : gfc_add_block_to_block (&block, &argse.pre);
13065 :
13066 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
13067 : token, offset, image_index, old, comp, new_val,
13068 : stat, build_int_cst (integer_type_node,
13069 8 : (int) atom_expr->ts.type),
13070 : build_int_cst (integer_type_node,
13071 8 : (int) atom_expr->ts.kind));
13072 8 : gfc_add_expr_to_block (&block, tmp);
13073 8 : gfc_add_block_to_block (&block, &argse.post);
13074 8 : gfc_add_block_to_block (&block, &post_block);
13075 8 : return gfc_finish_block (&block);
13076 : }
13077 :
13078 6 : tmp = TREE_TYPE (TREE_TYPE (atom));
13079 12 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
13080 6 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
13081 6 : + 1);
13082 6 : tmp = builtin_decl_explicit (fn);
13083 :
13084 6 : gfc_add_modify (&block, old, comp);
13085 12 : tmp = build_call_expr_loc (input_location, tmp, 6, atom,
13086 : gfc_build_addr_expr (NULL, old),
13087 6 : fold_convert (TREE_TYPE (old), new_val),
13088 : boolean_false_node,
13089 : build_int_cst (NULL, MEMMODEL_RELAXED),
13090 : build_int_cst (NULL, MEMMODEL_RELAXED));
13091 6 : gfc_add_expr_to_block (&block, tmp);
13092 :
13093 6 : if (stat != NULL_TREE)
13094 6 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
13095 6 : gfc_add_block_to_block (&block, &post_block);
13096 6 : return gfc_finish_block (&block);
13097 : }
13098 :
13099 : static tree
13100 105 : conv_intrinsic_event_query (gfc_code *code)
13101 : {
13102 105 : gfc_se se, argse;
13103 105 : tree stat = NULL_TREE, stat2 = NULL_TREE;
13104 105 : tree count = NULL_TREE, count2 = NULL_TREE;
13105 :
13106 105 : gfc_expr *event_expr = code->ext.actual->expr;
13107 :
13108 105 : if (code->ext.actual->next->next->expr)
13109 : {
13110 18 : gcc_assert (code->ext.actual->next->next->expr->expr_type
13111 : == EXPR_VARIABLE);
13112 18 : gfc_init_se (&argse, NULL);
13113 18 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
13114 18 : stat = argse.expr;
13115 : }
13116 87 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13117 58 : stat = null_pointer_node;
13118 :
13119 105 : if (code->ext.actual->next->expr)
13120 : {
13121 105 : gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
13122 105 : gfc_init_se (&argse, NULL);
13123 105 : gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
13124 105 : count = argse.expr;
13125 : }
13126 :
13127 105 : gfc_start_block (&se.pre);
13128 105 : if (flag_coarray == GFC_FCOARRAY_LIB)
13129 : {
13130 70 : tree tmp, token, image_index;
13131 70 : tree index = build_zero_cst (gfc_array_index_type);
13132 :
13133 70 : if (event_expr->expr_type == EXPR_FUNCTION
13134 0 : && event_expr->value.function.isym
13135 0 : && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
13136 0 : event_expr = event_expr->value.function.actual->expr;
13137 :
13138 70 : tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
13139 :
13140 70 : if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
13141 70 : || event_expr->symtree->n.sym->ts.u.derived->from_intmod
13142 : != INTMOD_ISO_FORTRAN_ENV
13143 70 : || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
13144 : != ISOFORTRAN_EVENT_TYPE)
13145 : {
13146 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
13147 : "yet supported", &event_expr->where);
13148 0 : return NULL_TREE;
13149 : }
13150 :
13151 70 : if (gfc_is_coindexed (event_expr))
13152 : {
13153 0 : gfc_error ("The event variable at %L shall not be coindexed",
13154 : &event_expr->where);
13155 0 : return NULL_TREE;
13156 : }
13157 :
13158 70 : image_index = integer_zero_node;
13159 :
13160 70 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
13161 : event_expr);
13162 :
13163 : /* For arrays, obtain the array index. */
13164 70 : if (gfc_expr_attr (event_expr).dimension)
13165 : {
13166 52 : tree desc, tmp, extent, lbound, ubound;
13167 52 : gfc_array_ref *ar, ar2;
13168 52 : int i;
13169 :
13170 : /* TODO: Extend this, once DT components are supported. */
13171 52 : ar = &event_expr->ref->u.ar;
13172 52 : ar2 = *ar;
13173 52 : memset (ar, '\0', sizeof (*ar));
13174 52 : ar->as = ar2.as;
13175 52 : ar->type = AR_FULL;
13176 :
13177 52 : gfc_init_se (&argse, NULL);
13178 52 : argse.descriptor_only = 1;
13179 52 : gfc_conv_expr_descriptor (&argse, event_expr);
13180 52 : gfc_add_block_to_block (&se.pre, &argse.pre);
13181 52 : desc = argse.expr;
13182 52 : *ar = ar2;
13183 :
13184 52 : extent = build_one_cst (gfc_array_index_type);
13185 156 : for (i = 0; i < ar->dimen; i++)
13186 : {
13187 52 : gfc_init_se (&argse, NULL);
13188 52 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
13189 52 : gfc_add_block_to_block (&argse.pre, &argse.pre);
13190 52 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
13191 52 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
13192 52 : TREE_TYPE (lbound), argse.expr, lbound);
13193 52 : tmp = fold_build2_loc (input_location, MULT_EXPR,
13194 52 : TREE_TYPE (tmp), extent, tmp);
13195 52 : index = fold_build2_loc (input_location, PLUS_EXPR,
13196 52 : TREE_TYPE (tmp), index, tmp);
13197 52 : if (i < ar->dimen - 1)
13198 : {
13199 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
13200 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
13201 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
13202 0 : TREE_TYPE (tmp), extent, tmp);
13203 : }
13204 : }
13205 : }
13206 :
13207 70 : if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
13208 : {
13209 0 : count2 = count;
13210 0 : count = gfc_create_var (integer_type_node, "count");
13211 : }
13212 :
13213 70 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
13214 : {
13215 0 : stat2 = stat;
13216 0 : stat = gfc_create_var (integer_type_node, "stat");
13217 : }
13218 :
13219 70 : index = fold_convert (size_type_node, index);
13220 140 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
13221 : token, index, image_index, count
13222 70 : ? gfc_build_addr_expr (NULL, count) : count,
13223 70 : stat != null_pointer_node
13224 12 : ? gfc_build_addr_expr (NULL, stat) : stat);
13225 70 : gfc_add_expr_to_block (&se.pre, tmp);
13226 :
13227 70 : if (count2 != NULL_TREE)
13228 0 : gfc_add_modify (&se.pre, count2,
13229 0 : fold_convert (TREE_TYPE (count2), count));
13230 :
13231 70 : if (stat2 != NULL_TREE)
13232 0 : gfc_add_modify (&se.pre, stat2,
13233 0 : fold_convert (TREE_TYPE (stat2), stat));
13234 :
13235 70 : return gfc_finish_block (&se.pre);
13236 : }
13237 :
13238 35 : gfc_init_se (&argse, NULL);
13239 35 : gfc_conv_expr_val (&argse, code->ext.actual->expr);
13240 35 : gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
13241 :
13242 35 : if (stat != NULL_TREE)
13243 6 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
13244 :
13245 35 : return gfc_finish_block (&se.pre);
13246 : }
13247 :
13248 :
13249 : /* This is a peculiar case because of the need to do dependency checking.
13250 : It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
13251 : a special case and this function called instead of
13252 : gfc_conv_procedure_call. */
13253 : void
13254 197 : gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
13255 : gfc_loopinfo *loop)
13256 : {
13257 197 : gfc_actual_arglist *actual;
13258 197 : gfc_se argse[5];
13259 197 : gfc_expr *arg[5];
13260 197 : gfc_ss *lss;
13261 197 : int n;
13262 :
13263 197 : tree from, frompos, len, to, topos;
13264 197 : tree lenmask, oldbits, newbits, bitsize;
13265 197 : tree type, utype, above, mask1, mask2;
13266 :
13267 197 : if (loop)
13268 67 : lss = loop->ss;
13269 : else
13270 130 : lss = gfc_ss_terminator;
13271 :
13272 197 : actual = actual_args;
13273 1182 : for (n = 0; n < 5; n++, actual = actual->next)
13274 : {
13275 985 : arg[n] = actual->expr;
13276 985 : gfc_init_se (&argse[n], NULL);
13277 :
13278 985 : if (lss != gfc_ss_terminator)
13279 : {
13280 335 : gfc_copy_loopinfo_to_se (&argse[n], loop);
13281 : /* Find the ss for the expression if it is there. */
13282 335 : argse[n].ss = lss;
13283 335 : gfc_mark_ss_chain_used (lss, 1);
13284 : }
13285 :
13286 985 : gfc_conv_expr (&argse[n], arg[n]);
13287 :
13288 985 : if (loop)
13289 335 : lss = argse[n].ss;
13290 : }
13291 :
13292 197 : from = argse[0].expr;
13293 197 : frompos = argse[1].expr;
13294 197 : len = argse[2].expr;
13295 197 : to = argse[3].expr;
13296 197 : topos = argse[4].expr;
13297 :
13298 : /* The type of the result (TO). */
13299 197 : type = TREE_TYPE (to);
13300 197 : bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
13301 :
13302 : /* Optionally generate code for runtime argument check. */
13303 197 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
13304 : {
13305 18 : tree nbits, below, ccond;
13306 18 : tree fp = fold_convert (long_integer_type_node, frompos);
13307 18 : tree ln = fold_convert (long_integer_type_node, len);
13308 18 : tree tp = fold_convert (long_integer_type_node, topos);
13309 18 : below = fold_build2_loc (input_location, LT_EXPR,
13310 : logical_type_node, frompos,
13311 18 : build_int_cst (TREE_TYPE (frompos), 0));
13312 18 : above = fold_build2_loc (input_location, GT_EXPR,
13313 : logical_type_node, frompos,
13314 18 : fold_convert (TREE_TYPE (frompos), bitsize));
13315 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13316 : logical_type_node, below, above);
13317 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13318 18 : &arg[1]->where,
13319 : "FROMPOS argument (%ld) out of range 0:%d "
13320 : "in intrinsic MVBITS", fp, bitsize);
13321 18 : below = fold_build2_loc (input_location, LT_EXPR,
13322 : logical_type_node, len,
13323 18 : build_int_cst (TREE_TYPE (len), 0));
13324 18 : above = fold_build2_loc (input_location, GT_EXPR,
13325 : logical_type_node, len,
13326 18 : fold_convert (TREE_TYPE (len), bitsize));
13327 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13328 : logical_type_node, below, above);
13329 18 : gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
13330 18 : &arg[2]->where,
13331 : "LEN argument (%ld) out of range 0:%d "
13332 : "in intrinsic MVBITS", ln, bitsize);
13333 18 : below = fold_build2_loc (input_location, LT_EXPR,
13334 : logical_type_node, topos,
13335 18 : build_int_cst (TREE_TYPE (topos), 0));
13336 18 : above = fold_build2_loc (input_location, GT_EXPR,
13337 : logical_type_node, topos,
13338 18 : fold_convert (TREE_TYPE (topos), bitsize));
13339 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13340 : logical_type_node, below, above);
13341 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13342 18 : &arg[4]->where,
13343 : "TOPOS argument (%ld) out of range 0:%d "
13344 : "in intrinsic MVBITS", tp, bitsize);
13345 :
13346 : /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
13347 : integers. Additions below cannot overflow. */
13348 18 : nbits = fold_convert (long_integer_type_node, bitsize);
13349 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13350 : long_integer_type_node, fp, ln);
13351 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13352 : logical_type_node, above, nbits);
13353 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13354 : &arg[1]->where,
13355 : "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13356 : "in intrinsic MVBITS", fp, ln, bitsize);
13357 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13358 : long_integer_type_node, tp, ln);
13359 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13360 : logical_type_node, above, nbits);
13361 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13362 : &arg[4]->where,
13363 : "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13364 : "in intrinsic MVBITS", tp, ln, bitsize);
13365 : }
13366 :
13367 1182 : for (n = 0; n < 5; n++)
13368 : {
13369 985 : gfc_add_block_to_block (&se->pre, &argse[n].pre);
13370 985 : gfc_add_block_to_block (&se->post, &argse[n].post);
13371 : }
13372 :
13373 : /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
13374 197 : above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
13375 197 : len, fold_convert (TREE_TYPE (len), bitsize));
13376 197 : mask1 = build_int_cst (type, -1);
13377 197 : mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13378 : build_int_cst (type, 1), len);
13379 197 : mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
13380 : mask2, build_int_cst (type, 1));
13381 197 : lenmask = fold_build3_loc (input_location, COND_EXPR, type,
13382 : above, mask1, mask2);
13383 :
13384 : /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
13385 : * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
13386 : * not strictly necessary; artificial bits from rshift will be masked. */
13387 197 : utype = unsigned_type_for (type);
13388 197 : newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
13389 : fold_convert (utype, from), frompos);
13390 197 : newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
13391 : fold_convert (type, newbits), lenmask);
13392 197 : newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13393 : newbits, topos);
13394 :
13395 : /* oldbits = TO & (~(lenmask << TOPOS)). */
13396 197 : oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13397 : lenmask, topos);
13398 197 : oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
13399 197 : oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
13400 :
13401 : /* TO = newbits | oldbits. */
13402 197 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
13403 : oldbits, newbits);
13404 :
13405 : /* Return the assignment. */
13406 197 : se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
13407 : void_type_node, to, se->expr);
13408 197 : }
13409 :
13410 : /* Comes from trans-stmt.cc, but we don't want the whole header included. */
13411 : extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
13412 : tree *stat, tree *errmsg, tree *errmsg_len);
13413 :
13414 : static tree
13415 269 : conv_intrinsic_move_alloc (gfc_code *code)
13416 : {
13417 269 : stmtblock_t block;
13418 269 : gfc_expr *from_expr, *to_expr;
13419 269 : gfc_se from_se, to_se;
13420 269 : tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE;
13421 269 : bool coarray, from_is_class, from_is_scalar;
13422 269 : gfc_actual_arglist *arg = code->ext.actual;
13423 269 : sync_stat tmp_sync_stat = {nullptr, nullptr};
13424 :
13425 269 : gfc_start_block (&block);
13426 :
13427 269 : from_expr = arg->expr;
13428 269 : arg = arg->next;
13429 269 : to_expr = arg->expr;
13430 269 : arg = arg->next;
13431 :
13432 807 : while (arg)
13433 : {
13434 538 : if (arg->expr)
13435 : {
13436 0 : if (!strcmp ("stat", arg->name))
13437 0 : tmp_sync_stat.stat = arg->expr;
13438 0 : else if (!strcmp ("errmsg", arg->name))
13439 0 : tmp_sync_stat.errmsg = arg->expr;
13440 : }
13441 538 : arg = arg->next;
13442 : }
13443 :
13444 269 : gfc_init_se (&from_se, NULL);
13445 269 : gfc_init_se (&to_se, NULL);
13446 :
13447 269 : gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len);
13448 269 : if (stat != null_pointer_node)
13449 0 : fin_label = gfc_build_label_decl (NULL_TREE);
13450 :
13451 269 : gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
13452 269 : coarray = from_expr->corank != 0;
13453 :
13454 269 : from_is_class = from_expr->ts.type == BT_CLASS;
13455 269 : from_is_scalar = from_expr->rank == 0 && !coarray;
13456 269 : if (to_expr->ts.type == BT_CLASS || from_is_scalar)
13457 : {
13458 169 : from_se.want_pointer = 1;
13459 169 : if (from_is_scalar)
13460 121 : gfc_conv_expr (&from_se, from_expr);
13461 : else
13462 48 : gfc_conv_expr_descriptor (&from_se, from_expr);
13463 169 : if (from_is_class)
13464 64 : from_tree = gfc_class_data_get (from_se.expr);
13465 : else
13466 : {
13467 105 : gfc_symbol *vtab;
13468 105 : from_tree = from_se.expr;
13469 :
13470 105 : if (to_expr->ts.type == BT_CLASS)
13471 : {
13472 42 : vtab = gfc_find_vtab (&from_expr->ts);
13473 42 : gcc_assert (vtab);
13474 42 : from_se.expr = gfc_get_symbol_decl (vtab);
13475 : }
13476 : }
13477 169 : gfc_add_block_to_block (&block, &from_se.pre);
13478 :
13479 169 : to_se.want_pointer = 1;
13480 169 : if (to_expr->rank == 0)
13481 121 : gfc_conv_expr (&to_se, to_expr);
13482 : else
13483 48 : gfc_conv_expr_descriptor (&to_se, to_expr);
13484 169 : if (to_expr->ts.type == BT_CLASS)
13485 106 : to_tree = gfc_class_data_get (to_se.expr);
13486 : else
13487 63 : to_tree = to_se.expr;
13488 169 : gfc_add_block_to_block (&block, &to_se.pre);
13489 :
13490 : /* Deallocate "to". */
13491 169 : if (to_expr->rank == 0)
13492 : {
13493 121 : tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
13494 : true, to_expr, to_expr->ts,
13495 : NULL_TREE, false, true,
13496 : errmsg, errmsg_len);
13497 121 : gfc_add_expr_to_block (&block, tmp);
13498 : }
13499 :
13500 169 : if (from_is_scalar)
13501 : {
13502 : /* Assign (_data) pointers. */
13503 121 : gfc_add_modify_loc (input_location, &block, to_tree,
13504 121 : fold_convert (TREE_TYPE (to_tree), from_tree));
13505 :
13506 : /* Set "from" to NULL. */
13507 121 : gfc_add_modify_loc (input_location, &block, from_tree,
13508 121 : fold_convert (TREE_TYPE (from_tree),
13509 : null_pointer_node));
13510 :
13511 121 : gfc_add_block_to_block (&block, &from_se.post);
13512 : }
13513 169 : gfc_add_block_to_block (&block, &to_se.post);
13514 :
13515 : /* Set _vptr. */
13516 169 : if (to_expr->ts.type == BT_CLASS)
13517 : {
13518 106 : gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
13519 106 : if (from_is_class)
13520 64 : gfc_reset_vptr (&block, from_expr);
13521 106 : if (UNLIMITED_POLY (to_expr))
13522 : {
13523 20 : tree to_len = gfc_class_len_get (to_se.class_container);
13524 20 : tmp = from_expr->ts.type == BT_CHARACTER && from_se.string_length
13525 20 : ? from_se.string_length
13526 : : size_zero_node;
13527 20 : gfc_add_modify_loc (input_location, &block, to_len,
13528 20 : fold_convert (TREE_TYPE (to_len), tmp));
13529 : }
13530 : }
13531 :
13532 169 : if (from_is_scalar)
13533 : {
13534 121 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13535 : {
13536 6 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13537 6 : fold_convert (TREE_TYPE (to_se.string_length),
13538 : from_se.string_length));
13539 6 : if (from_expr->ts.deferred)
13540 6 : gfc_add_modify_loc (
13541 : input_location, &block, from_se.string_length,
13542 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13543 : }
13544 121 : if (UNLIMITED_POLY (from_expr))
13545 2 : gfc_reset_len (&block, from_expr);
13546 :
13547 121 : return gfc_finish_block (&block);
13548 : }
13549 :
13550 48 : gfc_init_se (&to_se, NULL);
13551 48 : gfc_init_se (&from_se, NULL);
13552 : }
13553 :
13554 : /* Deallocate "to". */
13555 148 : if (from_expr->rank == 0)
13556 : {
13557 4 : to_se.want_coarray = 1;
13558 4 : from_se.want_coarray = 1;
13559 : }
13560 148 : gfc_conv_expr_descriptor (&to_se, to_expr);
13561 148 : gfc_conv_expr_descriptor (&from_se, from_expr);
13562 148 : gfc_add_block_to_block (&block, &to_se.pre);
13563 148 : gfc_add_block_to_block (&block, &from_se.pre);
13564 :
13565 : /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
13566 : is an image control "statement", cf. IR F08/0040 in 12-006A. */
13567 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13568 : {
13569 6 : tree cond;
13570 :
13571 6 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13572 : fin_label, true, to_expr,
13573 : GFC_CAF_COARRAY_DEALLOCATE_ONLY,
13574 : NULL_TREE, NULL_TREE,
13575 : gfc_conv_descriptor_token (to_se.expr),
13576 : true);
13577 6 : gfc_add_expr_to_block (&block, tmp);
13578 :
13579 6 : tmp = gfc_conv_descriptor_data_get (to_se.expr);
13580 6 : cond = fold_build2_loc (input_location, EQ_EXPR,
13581 : logical_type_node, tmp,
13582 6 : fold_convert (TREE_TYPE (tmp),
13583 : null_pointer_node));
13584 6 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
13585 : 3, null_pointer_node, null_pointer_node,
13586 : integer_zero_node);
13587 :
13588 6 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
13589 : tmp, build_empty_stmt (input_location));
13590 6 : gfc_add_expr_to_block (&block, tmp);
13591 6 : }
13592 : else
13593 : {
13594 142 : if (to_expr->ts.type == BT_DERIVED
13595 25 : && to_expr->ts.u.derived->attr.alloc_comp)
13596 : {
13597 19 : tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
13598 : to_se.expr, to_expr->rank);
13599 19 : gfc_add_expr_to_block (&block, tmp);
13600 : }
13601 :
13602 142 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13603 : fin_label, true, to_expr,
13604 : GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
13605 : NULL_TREE, NULL_TREE, true);
13606 142 : gfc_add_expr_to_block (&block, tmp);
13607 : }
13608 :
13609 : /* Copy the array descriptor data. */
13610 148 : gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
13611 :
13612 : /* Set "from" to NULL. */
13613 148 : gfc_conv_descriptor_data_set (&block, from_se.expr, null_pointer_node);
13614 :
13615 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13616 : {
13617 : /* Copy the array descriptor data has overwritten the to-token and cleared
13618 : from.data. Now also clear the from.token. */
13619 6 : gfc_conv_descriptor_token_set (&block, from_se.expr, null_pointer_node);
13620 : }
13621 :
13622 148 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13623 : {
13624 7 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13625 7 : fold_convert (TREE_TYPE (to_se.string_length),
13626 : from_se.string_length));
13627 7 : if (from_expr->ts.deferred)
13628 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
13629 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13630 : }
13631 148 : if (fin_label)
13632 0 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
13633 :
13634 148 : gfc_add_block_to_block (&block, &to_se.post);
13635 148 : gfc_add_block_to_block (&block, &from_se.post);
13636 :
13637 148 : return gfc_finish_block (&block);
13638 : }
13639 :
13640 :
13641 : tree
13642 6990 : gfc_conv_intrinsic_subroutine (gfc_code *code)
13643 : {
13644 6990 : tree res;
13645 :
13646 6990 : gcc_assert (code->resolved_isym);
13647 :
13648 6990 : switch (code->resolved_isym->id)
13649 : {
13650 269 : case GFC_ISYM_MOVE_ALLOC:
13651 269 : res = conv_intrinsic_move_alloc (code);
13652 269 : break;
13653 :
13654 14 : case GFC_ISYM_ATOMIC_CAS:
13655 14 : res = conv_intrinsic_atomic_cas (code);
13656 14 : break;
13657 :
13658 95 : case GFC_ISYM_ATOMIC_ADD:
13659 95 : case GFC_ISYM_ATOMIC_AND:
13660 95 : case GFC_ISYM_ATOMIC_DEF:
13661 95 : case GFC_ISYM_ATOMIC_OR:
13662 95 : case GFC_ISYM_ATOMIC_XOR:
13663 95 : case GFC_ISYM_ATOMIC_FETCH_ADD:
13664 95 : case GFC_ISYM_ATOMIC_FETCH_AND:
13665 95 : case GFC_ISYM_ATOMIC_FETCH_OR:
13666 95 : case GFC_ISYM_ATOMIC_FETCH_XOR:
13667 95 : res = conv_intrinsic_atomic_op (code);
13668 95 : break;
13669 :
13670 176 : case GFC_ISYM_ATOMIC_REF:
13671 176 : res = conv_intrinsic_atomic_ref (code);
13672 176 : break;
13673 :
13674 105 : case GFC_ISYM_EVENT_QUERY:
13675 105 : res = conv_intrinsic_event_query (code);
13676 105 : break;
13677 :
13678 3364 : case GFC_ISYM_C_F_POINTER:
13679 3364 : case GFC_ISYM_C_F_PROCPOINTER:
13680 3364 : res = conv_isocbinding_subroutine (code);
13681 3364 : break;
13682 :
13683 60 : case GFC_ISYM_C_F_STRPOINTER:
13684 60 : res = conv_isocbinding_subroutine_strpointer (code);
13685 60 : break;
13686 :
13687 360 : case GFC_ISYM_CAF_SEND:
13688 360 : res = conv_caf_send_to_remote (code);
13689 360 : break;
13690 :
13691 140 : case GFC_ISYM_CAF_SENDGET:
13692 140 : res = conv_caf_sendget (code);
13693 140 : break;
13694 :
13695 91 : case GFC_ISYM_CO_BROADCAST:
13696 91 : case GFC_ISYM_CO_MIN:
13697 91 : case GFC_ISYM_CO_MAX:
13698 91 : case GFC_ISYM_CO_REDUCE:
13699 91 : case GFC_ISYM_CO_SUM:
13700 91 : res = conv_co_collective (code);
13701 91 : break;
13702 :
13703 10 : case GFC_ISYM_FREE:
13704 10 : res = conv_intrinsic_free (code);
13705 10 : break;
13706 :
13707 55 : case GFC_ISYM_FSTAT:
13708 55 : case GFC_ISYM_LSTAT:
13709 55 : case GFC_ISYM_STAT:
13710 55 : res = conv_intrinsic_fstat_lstat_stat_sub (code);
13711 55 : break;
13712 :
13713 90 : case GFC_ISYM_RANDOM_INIT:
13714 90 : res = conv_intrinsic_random_init (code);
13715 90 : break;
13716 :
13717 15 : case GFC_ISYM_KILL:
13718 15 : res = conv_intrinsic_kill_sub (code);
13719 15 : break;
13720 :
13721 : case GFC_ISYM_MVBITS:
13722 : res = NULL_TREE;
13723 : break;
13724 :
13725 196 : case GFC_ISYM_SYSTEM_CLOCK:
13726 196 : res = conv_intrinsic_system_clock (code);
13727 196 : break;
13728 :
13729 102 : case GFC_ISYM_SPLIT:
13730 102 : res = conv_intrinsic_split (code);
13731 102 : break;
13732 :
13733 : default:
13734 : res = NULL_TREE;
13735 : break;
13736 : }
13737 :
13738 6990 : return res;
13739 : }
13740 :
13741 : #include "gt-fortran-trans-intrinsic.h"
|
