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 81791 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
202 : tree *argarray, int nargs)
203 : {
204 81791 : gfc_actual_arglist *actual;
205 81791 : gfc_expr *e;
206 81791 : gfc_intrinsic_arg *formal;
207 81791 : gfc_se argse;
208 81791 : int curr_arg;
209 :
210 81791 : formal = expr->value.function.isym->formal;
211 81791 : actual = expr->value.function.actual;
212 :
213 184242 : for (curr_arg = 0; curr_arg < nargs; curr_arg++,
214 63432 : actual = actual->next,
215 102451 : formal = formal ? formal->next : NULL)
216 : {
217 102451 : gcc_assert (actual);
218 102451 : e = actual->expr;
219 : /* Skip omitted optional arguments. */
220 102451 : if (!e)
221 : {
222 31 : --curr_arg;
223 31 : continue;
224 : }
225 :
226 : /* Evaluate the parameter. This will substitute scalarized
227 : references automatically. */
228 102420 : gfc_init_se (&argse, se);
229 :
230 102420 : if (e->ts.type == BT_CHARACTER)
231 : {
232 9628 : gfc_conv_expr (&argse, e);
233 9628 : gfc_conv_string_parameter (&argse);
234 9628 : argarray[curr_arg++] = argse.string_length;
235 9628 : gcc_assert (curr_arg < nargs);
236 : }
237 : else
238 92792 : 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 102420 : if (e->expr_type == EXPR_VARIABLE
243 52166 : && 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 102420 : gfc_add_block_to_block (&se->pre, &argse.pre);
249 102420 : gfc_add_block_to_block (&se->post, &argse.post);
250 102420 : argarray[curr_arg] = argse.expr;
251 : }
252 81791 : }
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 56622 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
259 : {
260 56622 : int n = 0;
261 56622 : gfc_actual_arglist *actual;
262 :
263 128473 : for (actual = expr->value.function.actual; actual; actual = actual->next)
264 : {
265 71851 : if (!actual->expr)
266 6358 : continue;
267 :
268 65493 : if (actual->expr->ts.type == BT_CHARACTER)
269 4549 : n += 2;
270 : else
271 60944 : n++;
272 : }
273 :
274 56622 : 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 40447 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
283 : {
284 40447 : tree type;
285 40447 : tree *args;
286 40447 : int nargs;
287 :
288 40447 : nargs = gfc_intrinsic_argument_list_length (expr);
289 40447 : 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 40447 : type = gfc_typenode_for_spec (&expr->ts);
295 40447 : gcc_assert (expr->value.function.actual->expr);
296 40447 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
297 :
298 : /* Conversion between character kinds involves a call to a library
299 : function. */
300 40447 : 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 40199 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
337 40199 : && 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 40199 : 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 669123 : define_quad_builtin (const char *name, tree type, bool is_const)
595 : {
596 669123 : tree fndecl;
597 669123 : fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
598 : type);
599 :
600 : /* Mark the decl as external. */
601 669123 : DECL_EXTERNAL (fndecl) = 1;
602 669123 : TREE_PUBLIC (fndecl) = 1;
603 :
604 : /* Mark it __attribute__((const)). */
605 669123 : TREE_READONLY (fndecl) = is_const;
606 :
607 669123 : rest_of_decl_compilation (fndecl, 1, 0);
608 :
609 669123 : 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 45812320 : add_simd_flag_for_built_in (tree fndecl)
617 : {
618 45812320 : if (gfc_vectorized_builtins == NULL
619 18377910 : || fndecl == NULL_TREE)
620 37869325 : return;
621 :
622 7942995 : const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
623 7942995 : int *clauses = gfc_vectorized_builtins->get (name);
624 7942995 : if (clauses)
625 : {
626 4983228 : for (unsigned i = 0; i < 3; i++)
627 3737421 : if (*clauses & (1 << i))
628 : {
629 1245812 : gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
630 1245812 : tree omp_clause = NULL_TREE;
631 1245812 : if (simd_type == SIMD_NONE)
632 : ; /* No SIMD clause. */
633 : else
634 : {
635 1245812 : omp_clause_code code
636 : = (simd_type == SIMD_INBRANCH
637 1245812 : ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
638 1245812 : omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
639 1245812 : omp_clause = build_tree_list (NULL_TREE, omp_clause);
640 : }
641 :
642 1245812 : DECL_ATTRIBUTES (fndecl)
643 2491624 : = tree_cons (get_identifier ("omp declare simd"), omp_clause,
644 1245812 : 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 77648 : gfc_adjust_builtins (void)
654 : {
655 77648 : gfc_intrinsic_map_t *m;
656 4658880 : for (m = gfc_intrinsic_map;
657 4658880 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
658 : {
659 4581232 : add_simd_flag_for_built_in (m->real4_decl);
660 4581232 : add_simd_flag_for_built_in (m->complex4_decl);
661 4581232 : add_simd_flag_for_built_in (m->real8_decl);
662 4581232 : add_simd_flag_for_built_in (m->complex8_decl);
663 4581232 : add_simd_flag_for_built_in (m->real10_decl);
664 4581232 : add_simd_flag_for_built_in (m->complex10_decl);
665 4581232 : add_simd_flag_for_built_in (m->real16_decl);
666 4581232 : add_simd_flag_for_built_in (m->complex16_decl);
667 4581232 : add_simd_flag_for_built_in (m->real16_decl);
668 4581232 : add_simd_flag_for_built_in (m->complex16_decl);
669 : }
670 :
671 : /* Release all strings. */
672 77648 : if (gfc_vectorized_builtins != NULL)
673 : {
674 1712986 : for (hash_map<nofree_string_hash, int>::iterator it
675 31149 : = gfc_vectorized_builtins->begin ();
676 1712986 : it != gfc_vectorized_builtins->end (); ++it)
677 1681837 : free (const_cast<char *> ((*it).first));
678 :
679 62298 : delete gfc_vectorized_builtins;
680 31149 : gfc_vectorized_builtins = NULL;
681 : }
682 77648 : }
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 31863 : gfc_build_intrinsic_lib_fndecls (void)
689 : {
690 31863 : gfc_intrinsic_map_t *m;
691 31863 : tree quad_decls[END_BUILTINS + 1];
692 :
693 31863 : 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 31863 : tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
700 31863 : tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
701 :
702 31863 : memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
703 :
704 31863 : type = gfc_float128_type_node;
705 31863 : complex_type = gfc_complex_float128_type_node;
706 : /* type (*) (type) */
707 31863 : func_1 = build_function_type_list (type, type, NULL_TREE);
708 : /* int (*) (type) */
709 31863 : func_iround = build_function_type_list (integer_type_node,
710 : type, NULL_TREE);
711 : /* long (*) (type) */
712 31863 : func_lround = build_function_type_list (long_integer_type_node,
713 : type, NULL_TREE);
714 : /* long long (*) (type) */
715 31863 : func_llround = build_function_type_list (long_long_integer_type_node,
716 : type, NULL_TREE);
717 : /* type (*) (type, type) */
718 31863 : func_2 = build_function_type_list (type, type, type, NULL_TREE);
719 : /* type (*) (type, type, type) */
720 31863 : func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
721 : /* type (*) (type, &int) */
722 31863 : func_frexp
723 31863 : = build_function_type_list (type,
724 : type,
725 : build_pointer_type (integer_type_node),
726 : NULL_TREE);
727 : /* type (*) (type, int) */
728 31863 : func_scalbn = build_function_type_list (type,
729 : type, integer_type_node, NULL_TREE);
730 : /* type (*) (complex type) */
731 31863 : func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
732 : /* complex type (*) (complex type, complex type) */
733 31863 : func_cpow
734 31863 : = 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 31863 : quad_decls[BUILT_IN_SQRT]
762 31863 : = define_quad_builtin (gfc_real16_use_iec_60559
763 : ? "sqrtf128" : "sqrtq", func_1, true);
764 : }
765 :
766 : /* Add GCC builtin functions. */
767 1879917 : for (m = gfc_intrinsic_map;
768 1911780 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
769 : {
770 1879917 : if (m->float_built_in != END_BUILTINS)
771 1752465 : m->real4_decl = builtin_decl_explicit (m->float_built_in);
772 1879917 : if (m->complex_float_built_in != END_BUILTINS)
773 509808 : m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
774 1879917 : if (m->double_built_in != END_BUILTINS)
775 1752465 : m->real8_decl = builtin_decl_explicit (m->double_built_in);
776 1879917 : if (m->complex_double_built_in != END_BUILTINS)
777 509808 : m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
778 :
779 : /* If real(kind=10) exists, it is always long double. */
780 1879917 : if (m->long_double_built_in != END_BUILTINS)
781 1752465 : m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
782 1879917 : if (m->complex_long_double_built_in != END_BUILTINS)
783 509808 : m->complex10_decl
784 509808 : = builtin_decl_explicit (m->complex_long_double_built_in);
785 :
786 1879917 : 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 1879917 : 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 669123 : m->real16_decl = quad_decls[m->double_built_in];
800 : }
801 1210794 : 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 31863 : }
808 :
809 :
810 : /* Create a fndecl for a simple intrinsic library function. */
811 :
812 : static tree
813 4545 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
814 : {
815 4545 : tree type;
816 4545 : vec<tree, va_gc> *argtypes;
817 4545 : tree fndecl;
818 4545 : gfc_actual_arglist *actual;
819 4545 : tree *pdecl;
820 4545 : gfc_typespec *ts;
821 4545 : char name[GFC_MAX_SYMBOL_LEN + 3];
822 :
823 4545 : ts = &expr->ts;
824 4545 : if (ts->type == BT_REAL)
825 : {
826 3683 : 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 599 : case 10:
835 599 : pdecl = &m->real10_decl;
836 599 : break;
837 469 : case 16:
838 469 : pdecl = &m->real16_decl;
839 469 : 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 4545 : if (*pdecl)
870 4137 : return *pdecl;
871 :
872 408 : if (m->libm_name)
873 : {
874 177 : int n = gfc_validate_kind (BT_REAL, ts->kind, false);
875 177 : 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 177 : 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 177 : 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 177 : else if (gfc_real_kinds[n].c_float128)
885 177 : snprintf (name, sizeof (name), "%s%s%s",
886 177 : ts->type == BT_COMPLEX ? "c" : "", m->name,
887 177 : 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 408 : argtypes = NULL;
899 836 : for (actual = expr->value.function.actual; actual; actual = actual->next)
900 : {
901 428 : type = gfc_typenode_for_spec (&actual->expr->ts);
902 428 : vec_safe_push (argtypes, type);
903 : }
904 1224 : type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
905 408 : fndecl = build_decl (input_location,
906 : FUNCTION_DECL, get_identifier (name), type);
907 :
908 : /* Mark the decl as external. */
909 408 : DECL_EXTERNAL (fndecl) = 1;
910 408 : TREE_PUBLIC (fndecl) = 1;
911 :
912 : /* Mark it __attribute__((const)), if possible. */
913 408 : TREE_READONLY (fndecl) = m->is_constant;
914 :
915 408 : rest_of_decl_compilation (fndecl, 1, 0);
916 :
917 408 : (*pdecl) = fndecl;
918 408 : return fndecl;
919 : }
920 :
921 :
922 : /* Convert an intrinsic function into an external or builtin call. */
923 :
924 : static void
925 3927 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
926 : {
927 3927 : gfc_intrinsic_map_t *m;
928 3927 : tree fndecl;
929 3927 : tree rettype;
930 3927 : tree *args;
931 3927 : unsigned int num_args;
932 3927 : gfc_isym_id id;
933 :
934 3927 : id = expr->value.function.isym->id;
935 : /* Find the entry for this function. */
936 82775 : for (m = gfc_intrinsic_map;
937 82775 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
938 : {
939 82775 : if (id == m->id)
940 : break;
941 : }
942 :
943 3927 : 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 3927 : num_args = gfc_intrinsic_argument_list_length (expr);
951 3927 : args = XALLOCAVEC (tree, num_args);
952 :
953 3927 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
954 3927 : fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
955 3927 : rettype = TREE_TYPE (TREE_TYPE (fndecl));
956 :
957 3927 : fndecl = build_addr (fndecl);
958 3927 : se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
959 3927 : }
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 1550 : gfc_trans_same_strlen_check (const char* intr_name, locus* where,
968 : tree a, tree b, stmtblock_t* target)
969 : {
970 1550 : tree cond;
971 1550 : tree name;
972 :
973 : /* If bounds-checking is disabled, do nothing. */
974 1550 : 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 1434 : conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
1031 : gfc_expr *hash)
1032 : {
1033 1434 : char *name;
1034 1434 : gfc_se argse;
1035 1434 : gfc_expr func_index;
1036 1434 : gfc_symtree *index_st;
1037 1434 : tree func_index_tree;
1038 1434 : stmtblock_t blk;
1039 :
1040 : /* Need to get namespace where static variables are possible. */
1041 1434 : while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
1042 0 : ns = ns->parent;
1043 1434 : gcc_assert (ns);
1044 :
1045 1434 : name = xasprintf (pat, caf_call_cnt);
1046 1434 : gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
1047 1434 : free (name);
1048 :
1049 1434 : index_st->n.sym->attr.flavor = FL_VARIABLE;
1050 1434 : index_st->n.sym->attr.save = SAVE_EXPLICIT;
1051 1434 : index_st->n.sym->value
1052 1434 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1053 : &gfc_current_locus);
1054 1434 : mpz_set_si (index_st->n.sym->value->value.integer, -1);
1055 1434 : index_st->n.sym->ts.type = BT_INTEGER;
1056 1434 : index_st->n.sym->ts.kind = gfc_default_integer_kind;
1057 1434 : gfc_set_sym_referenced (index_st->n.sym);
1058 1434 : memset (&func_index, 0, sizeof (gfc_expr));
1059 1434 : gfc_clear_ts (&func_index.ts);
1060 1434 : func_index.expr_type = EXPR_VARIABLE;
1061 1434 : func_index.symtree = index_st;
1062 1434 : func_index.ts = index_st->n.sym->ts;
1063 1434 : gfc_commit_symbol (index_st->n.sym);
1064 :
1065 1434 : gfc_init_se (&argse, NULL);
1066 1434 : gfc_conv_expr (&argse, &func_index);
1067 1434 : gfc_add_block_to_block (block, &argse.pre);
1068 1434 : func_index_tree = argse.expr;
1069 :
1070 1434 : gfc_init_se (&argse, NULL);
1071 1434 : gfc_conv_expr (&argse, hash);
1072 :
1073 1434 : gfc_init_block (&blk);
1074 1434 : gfc_add_modify (&blk, func_index_tree,
1075 : build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1,
1076 : argse.expr));
1077 1434 : 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 1434 : return func_index_tree;
1086 : }
1087 :
1088 : static tree
1089 1434 : conv_caf_add_call_data (stmtblock_t *blk, gfc_namespace *ns, const char *pat,
1090 : gfc_symbol *data_sym, tree *data_size)
1091 : {
1092 1434 : char *name;
1093 1434 : gfc_symtree *data_st;
1094 1434 : gfc_constructor *con;
1095 1434 : gfc_expr data, data_init;
1096 1434 : gfc_se argse;
1097 1434 : tree data_tree;
1098 :
1099 1434 : memset (&data, 0, sizeof (gfc_expr));
1100 1434 : gfc_clear_ts (&data.ts);
1101 1434 : data.expr_type = EXPR_VARIABLE;
1102 1434 : name = xasprintf (pat, caf_call_cnt);
1103 1434 : gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false));
1104 1434 : free (name);
1105 1434 : data_st->n.sym->attr.flavor = FL_VARIABLE;
1106 1434 : data_st->n.sym->ts = data_sym->ts;
1107 1434 : data.symtree = data_st;
1108 1434 : gfc_set_sym_referenced (data.symtree->n.sym);
1109 1434 : data.ts = data_st->n.sym->ts;
1110 1434 : gfc_commit_symbol (data_st->n.sym);
1111 :
1112 1434 : memset (&data_init, 0, sizeof (gfc_expr));
1113 1434 : gfc_clear_ts (&data_init.ts);
1114 1434 : data_init.expr_type = EXPR_STRUCTURE;
1115 1434 : data_init.ts = data.ts;
1116 1750 : 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 1434 : 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 1324 : data_tree = build_zero_cst (pvoid_type_node);
1140 1324 : *data_size = build_zero_cst (size_type_node);
1141 : }
1142 :
1143 1434 : 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 167 : gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
1374 : {
1375 167 : gfc_expr *caf_expr, *hash, *present_fn;
1376 167 : gfc_symbol *add_data_sym;
1377 167 : tree fn_index, add_data_tree, add_data_size, caf_decl, image_index, token;
1378 :
1379 167 : gcc_assert (e->expr_type == EXPR_FUNCTION
1380 : && e->value.function.isym->id
1381 : == GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE);
1382 167 : caf_expr = e->value.function.actual->expr;
1383 167 : hash = e->value.function.actual->next->expr;
1384 167 : present_fn = e->value.function.actual->next->next->expr;
1385 167 : add_data_sym = present_fn->symtree->n.sym->formal->sym;
1386 :
1387 167 : fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns,
1388 : "__caf_present_on_remote_fn_index_%d", hash);
1389 167 : add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns,
1390 : "__caf_present_on_remote_add_data_%d",
1391 : add_data_sym, &add_data_size);
1392 167 : ++caf_call_cnt;
1393 :
1394 167 : caf_decl = gfc_get_tree_for_caf_expr (caf_expr);
1395 167 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1396 4 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1397 :
1398 167 : image_index = gfc_caf_get_image_index (&se->pre, caf_expr, caf_decl);
1399 167 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, caf_expr);
1400 :
1401 167 : se->expr
1402 167 : = fold_convert (logical_type_node,
1403 : build_call_expr_loc (input_location,
1404 : gfor_fndecl_caf_is_present_on_remote,
1405 : 5, token, image_index, fn_index,
1406 : add_data_tree, add_data_size));
1407 167 : }
1408 :
1409 : static tree
1410 360 : conv_caf_send_to_remote (gfc_code *code)
1411 : {
1412 360 : gfc_expr *lhs_expr, *rhs_expr, *lhs_hash, *receiver_fn_expr;
1413 360 : gfc_symbol *add_data_sym;
1414 360 : gfc_se lhs_se, rhs_se;
1415 360 : stmtblock_t block;
1416 360 : gfc_namespace *ns;
1417 360 : tree caf_decl, token, rhs_size, image_index, tmp, rhs_data;
1418 360 : tree lhs_stat, lhs_team, lhs_team_no, opt_lhs_charlen, opt_rhs_charlen;
1419 360 : tree opt_lhs_desc = NULL_TREE, opt_rhs_desc = NULL_TREE;
1420 360 : tree receiver_fn_index_tree, add_data_tree, add_data_size;
1421 :
1422 360 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1423 360 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SEND);
1424 :
1425 360 : lhs_expr = code->ext.actual->expr;
1426 360 : rhs_expr = code->ext.actual->next->expr;
1427 360 : lhs_hash = code->ext.actual->next->next->expr;
1428 360 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1429 360 : add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1430 :
1431 360 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1432 360 : && !lhs_expr->symtree->n.sym->attr.associate_var
1433 360 : ? lhs_expr->symtree->n.sym->ns
1434 : : gfc_current_ns;
1435 :
1436 360 : gfc_init_block (&block);
1437 :
1438 : /* LHS. */
1439 360 : gfc_init_se (&lhs_se, NULL);
1440 360 : caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1441 360 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1442 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1443 360 : if (lhs_expr->rank == 0)
1444 : {
1445 266 : if (lhs_expr->ts.type == BT_CHARACTER)
1446 : {
1447 24 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1448 24 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1449 24 : opt_lhs_charlen = gfc_build_addr_expr (
1450 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1451 : }
1452 : else
1453 242 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1454 266 : opt_lhs_desc = null_pointer_node;
1455 : }
1456 : else
1457 : {
1458 94 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1459 94 : gfc_add_block_to_block (&block, &lhs_se.pre);
1460 94 : opt_lhs_desc = lhs_se.expr;
1461 94 : if (lhs_expr->ts.type == BT_CHARACTER)
1462 44 : opt_lhs_charlen = gfc_build_addr_expr (
1463 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1464 : else
1465 50 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1466 : /* Get the third formal argument of the receiver function. (This is the
1467 : location where to put the data on the remote image.) Need to look at
1468 : the argument in the function decl, because in the gfc_symbol's formal
1469 : argument an array may have no descriptor while in the generated
1470 : function decl it has. */
1471 94 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1472 : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1473 94 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1474 56 : opt_lhs_desc = null_pointer_node;
1475 : else
1476 38 : opt_lhs_desc
1477 38 : = gfc_build_addr_expr (NULL_TREE,
1478 : gfc_trans_force_lval (&block, opt_lhs_desc));
1479 : }
1480 :
1481 : /* Obtain token, offset and image index for the LHS. */
1482 360 : image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
1483 360 : gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL, lhs_expr);
1484 :
1485 : /* RHS. */
1486 360 : gfc_init_se (&rhs_se, NULL);
1487 360 : if (rhs_expr->rank == 0)
1488 : {
1489 436 : rhs_se.want_pointer = rhs_expr->ts.type == BT_CHARACTER
1490 218 : && rhs_expr->expr_type != EXPR_CONSTANT;
1491 218 : gfc_conv_expr (&rhs_se, rhs_expr);
1492 218 : gfc_add_block_to_block (&block, &rhs_se.pre);
1493 218 : opt_rhs_desc = null_pointer_node;
1494 218 : if (rhs_expr->ts.type == BT_CHARACTER)
1495 : {
1496 40 : rhs_data
1497 40 : = rhs_expr->expr_type == EXPR_CONSTANT
1498 40 : ? gfc_build_addr_expr (NULL_TREE,
1499 : gfc_trans_force_lval (&block,
1500 : rhs_se.expr))
1501 : : rhs_se.expr;
1502 40 : opt_rhs_charlen = gfc_build_addr_expr (
1503 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1504 40 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1505 : }
1506 : else
1507 : {
1508 178 : rhs_data
1509 178 : = gfc_build_addr_expr (NULL_TREE,
1510 : gfc_trans_force_lval (&block, rhs_se.expr));
1511 178 : opt_rhs_charlen
1512 178 : = build_zero_cst (build_pointer_type (size_type_node));
1513 178 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1514 : }
1515 : }
1516 : else
1517 : {
1518 284 : rhs_se.force_tmp = rhs_expr->shape == NULL
1519 142 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1520 142 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1521 142 : gfc_add_block_to_block (&block, &rhs_se.pre);
1522 142 : opt_rhs_desc = rhs_se.expr;
1523 142 : if (rhs_expr->ts.type == BT_CHARACTER)
1524 : {
1525 28 : opt_rhs_charlen = gfc_build_addr_expr (
1526 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1527 28 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1528 : }
1529 : else
1530 : {
1531 114 : opt_rhs_charlen
1532 114 : = build_zero_cst (build_pointer_type (size_type_node));
1533 114 : rhs_size = fold_build2 (
1534 : MULT_EXPR, size_type_node,
1535 : fold_convert (size_type_node,
1536 : rhs_expr->shape
1537 : ? conv_shape_to_cst (rhs_expr)
1538 : : gfc_conv_descriptor_size (rhs_se.expr,
1539 : rhs_expr->rank)),
1540 : fold_convert (size_type_node,
1541 : gfc_conv_descriptor_span_get (rhs_se.expr)));
1542 : }
1543 :
1544 142 : rhs_data = gfc_build_addr_expr (
1545 : NULL_TREE, gfc_trans_force_lval (&block, gfc_conv_descriptor_data_get (
1546 : opt_rhs_desc)));
1547 142 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1548 : }
1549 360 : gfc_add_block_to_block (&block, &rhs_se.pre);
1550 :
1551 360 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1552 :
1553 360 : receiver_fn_index_tree
1554 360 : = conv_caf_func_index (&block, ns, "__caf_send_to_remote_fn_index_%d",
1555 : lhs_hash);
1556 360 : add_data_tree
1557 360 : = conv_caf_add_call_data (&block, ns, "__caf_send_to_remote_add_data_%d",
1558 : add_data_sym, &add_data_size);
1559 360 : ++caf_call_cnt;
1560 :
1561 360 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_to_remote, 14,
1562 : token, opt_lhs_desc, opt_lhs_charlen, image_index,
1563 : rhs_size, rhs_data, opt_rhs_charlen, opt_rhs_desc,
1564 : receiver_fn_index_tree, add_data_tree,
1565 : add_data_size, lhs_stat, lhs_team, lhs_team_no);
1566 :
1567 360 : gfc_add_expr_to_block (&block, tmp);
1568 360 : gfc_add_block_to_block (&block, &lhs_se.post);
1569 360 : gfc_add_block_to_block (&block, &rhs_se.post);
1570 :
1571 : /* It guarantees memory consistency within the same segment. */
1572 360 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1573 360 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1574 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1575 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1576 360 : ASM_VOLATILE_P (tmp) = 1;
1577 360 : gfc_add_expr_to_block (&block, tmp);
1578 :
1579 360 : return gfc_finish_block (&block);
1580 : }
1581 :
1582 : /* Send-get data to a remote coarray. */
1583 :
1584 : static tree
1585 140 : conv_caf_sendget (gfc_code *code)
1586 : {
1587 : /* lhs stuff */
1588 140 : gfc_expr *lhs_expr, *lhs_hash, *receiver_fn_expr;
1589 140 : gfc_symbol *lhs_add_data_sym;
1590 140 : gfc_se lhs_se;
1591 140 : tree lhs_caf_decl, lhs_token, opt_lhs_charlen,
1592 140 : opt_lhs_desc = NULL_TREE, receiver_fn_index_tree, lhs_image_index,
1593 : lhs_add_data_tree, lhs_add_data_size, lhs_stat, lhs_team, lhs_team_no;
1594 140 : int transfer_rank;
1595 :
1596 : /* rhs stuff */
1597 140 : gfc_expr *rhs_expr, *rhs_hash, *sender_fn_expr;
1598 140 : gfc_symbol *rhs_add_data_sym;
1599 140 : gfc_se rhs_se;
1600 140 : tree rhs_caf_decl, rhs_token, opt_rhs_charlen,
1601 140 : opt_rhs_desc = NULL_TREE, sender_fn_index_tree, rhs_image_index,
1602 : rhs_add_data_tree, rhs_add_data_size, rhs_stat, rhs_team, rhs_team_no;
1603 :
1604 : /* shared */
1605 140 : stmtblock_t block;
1606 140 : gfc_namespace *ns;
1607 140 : tree tmp, rhs_size;
1608 :
1609 140 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1610 140 : gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SENDGET);
1611 :
1612 140 : lhs_expr = code->ext.actual->expr;
1613 140 : rhs_expr = code->ext.actual->next->expr;
1614 140 : lhs_hash = code->ext.actual->next->next->expr;
1615 140 : receiver_fn_expr = code->ext.actual->next->next->next->expr;
1616 140 : rhs_hash = code->ext.actual->next->next->next->next->expr;
1617 140 : sender_fn_expr = code->ext.actual->next->next->next->next->next->expr;
1618 :
1619 140 : lhs_add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
1620 140 : rhs_add_data_sym = sender_fn_expr->symtree->n.sym->formal->sym;
1621 :
1622 140 : ns = lhs_expr->expr_type == EXPR_VARIABLE
1623 140 : && !lhs_expr->symtree->n.sym->attr.associate_var
1624 140 : ? lhs_expr->symtree->n.sym->ns
1625 : : gfc_current_ns;
1626 :
1627 140 : gfc_init_block (&block);
1628 :
1629 140 : lhs_stat = null_pointer_node;
1630 140 : lhs_team = null_pointer_node;
1631 140 : rhs_stat = null_pointer_node;
1632 140 : rhs_team = null_pointer_node;
1633 :
1634 : /* LHS. */
1635 140 : gfc_init_se (&lhs_se, NULL);
1636 140 : lhs_caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1637 140 : if (TREE_CODE (TREE_TYPE (lhs_caf_decl)) == REFERENCE_TYPE)
1638 0 : lhs_caf_decl = build_fold_indirect_ref_loc (input_location, lhs_caf_decl);
1639 140 : if (lhs_expr->rank == 0)
1640 : {
1641 78 : if (lhs_expr->ts.type == BT_CHARACTER)
1642 : {
1643 16 : gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
1644 16 : lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
1645 16 : opt_lhs_charlen = gfc_build_addr_expr (
1646 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1647 : }
1648 : else
1649 62 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1650 78 : opt_lhs_desc = null_pointer_node;
1651 : }
1652 : else
1653 : {
1654 62 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1655 62 : gfc_add_block_to_block (&block, &lhs_se.pre);
1656 62 : opt_lhs_desc = lhs_se.expr;
1657 62 : if (lhs_expr->ts.type == BT_CHARACTER)
1658 32 : opt_lhs_charlen = gfc_build_addr_expr (
1659 : NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
1660 : else
1661 30 : opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
1662 : /* Get the third formal argument of the receiver function. (This is the
1663 : location where to put the data on the remote image.) Need to look at
1664 : the argument in the function decl, because in the gfc_symbol's formal
1665 : argument an array may have no descriptor while in the generated
1666 : function decl it has. */
1667 62 : tmp = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1668 : TREE_TYPE (receiver_fn_expr->symtree->n.sym->backend_decl)))));
1669 62 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1670 54 : opt_lhs_desc = null_pointer_node;
1671 : else
1672 8 : opt_lhs_desc
1673 8 : = gfc_build_addr_expr (NULL_TREE,
1674 : gfc_trans_force_lval (&block, opt_lhs_desc));
1675 : }
1676 :
1677 : /* Obtain token, offset and image index for the LHS. */
1678 140 : lhs_image_index = gfc_caf_get_image_index (&block, lhs_expr, lhs_caf_decl);
1679 140 : gfc_get_caf_token_offset (&lhs_se, &lhs_token, NULL, lhs_caf_decl, NULL,
1680 : lhs_expr);
1681 :
1682 : /* RHS. */
1683 140 : rhs_caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
1684 140 : if (TREE_CODE (TREE_TYPE (rhs_caf_decl)) == REFERENCE_TYPE)
1685 0 : rhs_caf_decl = build_fold_indirect_ref_loc (input_location, rhs_caf_decl);
1686 140 : transfer_rank = rhs_expr->rank;
1687 140 : gfc_expression_rank (rhs_expr);
1688 140 : gfc_init_se (&rhs_se, NULL);
1689 140 : if (rhs_expr->rank == 0)
1690 : {
1691 80 : opt_rhs_desc = null_pointer_node;
1692 80 : if (rhs_expr->ts.type == BT_CHARACTER)
1693 : {
1694 32 : gfc_conv_expr (&rhs_se, rhs_expr);
1695 32 : gfc_add_block_to_block (&block, &rhs_se.pre);
1696 32 : opt_rhs_charlen = gfc_build_addr_expr (
1697 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1698 32 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1699 : }
1700 : else
1701 : {
1702 48 : gfc_typespec *ts
1703 48 : = &sender_fn_expr->symtree->n.sym->formal->next->next->sym->ts;
1704 :
1705 48 : opt_rhs_charlen
1706 48 : = build_zero_cst (build_pointer_type (size_type_node));
1707 48 : rhs_size = gfc_typenode_for_spec (ts)->type_common.size_unit;
1708 : }
1709 : }
1710 : /* Get the fifth formal argument of the getter function. This is the argument
1711 : pointing to the data to get on the remote image. Need to look at the
1712 : argument in the function decl, because in the gfc_symbol's formal argument
1713 : an array may have no descriptor while in the generated function decl it
1714 : has. */
1715 60 : else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_VALUE (
1716 : TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TYPE_ARG_TYPES (
1717 : TREE_TYPE (sender_fn_expr->symtree->n.sym->backend_decl))))))))))
1718 : {
1719 52 : rhs_se.data_not_needed = 1;
1720 52 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1721 52 : gfc_add_block_to_block (&block, &rhs_se.pre);
1722 52 : if (rhs_expr->ts.type == BT_CHARACTER)
1723 : {
1724 16 : opt_rhs_charlen = gfc_build_addr_expr (
1725 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1726 16 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1727 : }
1728 : else
1729 : {
1730 36 : opt_rhs_charlen
1731 36 : = build_zero_cst (build_pointer_type (size_type_node));
1732 36 : rhs_size = TREE_TYPE (rhs_se.expr)->type_common.size_unit;
1733 : }
1734 52 : opt_rhs_desc = null_pointer_node;
1735 : }
1736 : else
1737 : {
1738 8 : gfc_ref *arr_ref = rhs_expr->ref;
1739 8 : while (arr_ref && arr_ref->type != REF_ARRAY)
1740 0 : arr_ref = arr_ref->next;
1741 8 : rhs_se.force_tmp
1742 16 : = (rhs_expr->shape == NULL
1743 8 : && (!arr_ref || !gfc_full_array_ref_p (arr_ref, nullptr)))
1744 16 : || !gfc_is_simply_contiguous (rhs_expr, false, false);
1745 8 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
1746 8 : gfc_add_block_to_block (&block, &rhs_se.pre);
1747 8 : opt_rhs_desc = rhs_se.expr;
1748 8 : if (rhs_expr->ts.type == BT_CHARACTER)
1749 : {
1750 0 : opt_rhs_charlen = gfc_build_addr_expr (
1751 : NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
1752 0 : rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
1753 : }
1754 : else
1755 : {
1756 8 : opt_rhs_charlen
1757 8 : = build_zero_cst (build_pointer_type (size_type_node));
1758 8 : rhs_size = fold_build2 (
1759 : MULT_EXPR, size_type_node,
1760 : fold_convert (size_type_node,
1761 : rhs_expr->shape
1762 : ? conv_shape_to_cst (rhs_expr)
1763 : : gfc_conv_descriptor_size (rhs_se.expr,
1764 : rhs_expr->rank)),
1765 : fold_convert (size_type_node,
1766 : gfc_conv_descriptor_span_get (rhs_se.expr)));
1767 : }
1768 :
1769 8 : opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
1770 : }
1771 140 : gfc_add_block_to_block (&block, &rhs_se.pre);
1772 :
1773 : /* Obtain token, offset and image index for the RHS. */
1774 140 : rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, rhs_caf_decl);
1775 140 : gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, rhs_caf_decl, NULL,
1776 : rhs_expr);
1777 :
1778 : /* stat and team. */
1779 140 : conv_stat_and_team (&block, lhs_expr, &lhs_stat, &lhs_team, &lhs_team_no);
1780 140 : conv_stat_and_team (&block, rhs_expr, &rhs_stat, &rhs_team, &rhs_team_no);
1781 :
1782 140 : sender_fn_index_tree
1783 140 : = conv_caf_func_index (&block, ns, "__caf_transfer_from_fn_index_%d",
1784 : rhs_hash);
1785 140 : rhs_add_data_tree
1786 140 : = conv_caf_add_call_data (&block, ns,
1787 : "__caf_transfer_from_remote_add_data_%d",
1788 : rhs_add_data_sym, &rhs_add_data_size);
1789 140 : receiver_fn_index_tree
1790 140 : = conv_caf_func_index (&block, ns, "__caf_transfer_to_remote_fn_index_%d",
1791 : lhs_hash);
1792 140 : lhs_add_data_tree
1793 140 : = conv_caf_add_call_data (&block, ns,
1794 : "__caf_transfer_to_remote_add_data_%d",
1795 : lhs_add_data_sym, &lhs_add_data_size);
1796 140 : ++caf_call_cnt;
1797 :
1798 140 : tmp = build_call_expr_loc (
1799 : input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token,
1800 : opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree,
1801 : lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc,
1802 : opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree,
1803 : rhs_add_data_size, rhs_size,
1804 : transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat,
1805 : rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no);
1806 :
1807 140 : gfc_add_expr_to_block (&block, tmp);
1808 140 : gfc_add_block_to_block (&block, &lhs_se.post);
1809 140 : gfc_add_block_to_block (&block, &rhs_se.post);
1810 :
1811 : /* It guarantees memory consistency within the same segment. */
1812 140 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1813 140 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1814 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1815 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1816 140 : ASM_VOLATILE_P (tmp) = 1;
1817 140 : gfc_add_expr_to_block (&block, tmp);
1818 :
1819 140 : return gfc_finish_block (&block);
1820 : }
1821 :
1822 :
1823 : static void
1824 1298 : trans_this_image (gfc_se * se, gfc_expr *expr)
1825 : {
1826 1298 : stmtblock_t loop;
1827 1298 : tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound,
1828 : ubound, extent, ml, team;
1829 1298 : gfc_se argse;
1830 1298 : int rank, corank;
1831 :
1832 : /* The case -fcoarray=single is handled elsewhere. */
1833 1298 : gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
1834 :
1835 : /* Translate team, if present. */
1836 1298 : 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 1280 : team = null_pointer_node;
1846 :
1847 : /* Argument-free version: THIS_IMAGE(). */
1848 1298 : if (expr->value.function.actual->expr == NULL)
1849 : {
1850 980 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1851 : team);
1852 980 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1853 : tmp);
1854 988 : 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 443 : for (codim = corank + rank - 2; codim >= rank; codim--)
2207 : {
2208 250 : tree extent, ubound;
2209 :
2210 : /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2211 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2212 250 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2213 250 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2214 :
2215 : /* coindex *= extent. */
2216 250 : coindex = fold_build2_loc (input_location, MULT_EXPR,
2217 : gfc_array_index_type, coindex, extent);
2218 :
2219 : /* coindex += sub(codim). */
2220 250 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2221 250 : coindex = fold_build2_loc (input_location, PLUS_EXPR,
2222 : gfc_array_index_type, coindex,
2223 : fold_convert (gfc_array_index_type, tmp));
2224 :
2225 : /* coindex -= lbound(codim). */
2226 250 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2227 250 : coindex = fold_build2_loc (input_location, MINUS_EXPR,
2228 : gfc_array_index_type, coindex, lbound);
2229 : }
2230 :
2231 193 : coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2232 : fold_convert(type, coindex),
2233 : build_int_cst (type, 1));
2234 :
2235 : /* Return 0 if "coindex" exceeds num_images(). */
2236 :
2237 193 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2238 108 : num_images = build_int_cst (type, 1);
2239 : else
2240 : {
2241 85 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2242 : team, team_number);
2243 85 : num_images = fold_convert (type, tmp);
2244 : }
2245 :
2246 193 : tmp = gfc_create_var (type, NULL);
2247 193 : gfc_add_modify (&se->pre, tmp, coindex);
2248 :
2249 193 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2250 : num_images);
2251 193 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2252 : cond,
2253 : fold_convert (logical_type_node, invalid_bound));
2254 193 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2255 : build_int_cst (type, 0), tmp);
2256 193 : }
2257 :
2258 : static void
2259 810 : trans_num_images (gfc_se * se, gfc_expr *expr)
2260 : {
2261 810 : tree tmp, team = null_pointer_node, team_number = null_pointer_node;
2262 810 : gfc_se argse;
2263 :
2264 810 : if (expr->value.function.actual->expr)
2265 : {
2266 18 : gfc_init_se (&argse, NULL);
2267 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2268 18 : if (expr->value.function.actual->expr->ts.type == BT_DERIVED)
2269 6 : team = argse.expr;
2270 : else
2271 12 : team_number = gfc_build_addr_expr (
2272 : NULL_TREE,
2273 : gfc_trans_force_lval (&se->pre,
2274 : fold_convert (integer_type_node, argse.expr)));
2275 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
2276 18 : gfc_add_block_to_block (&se->post, &argse.post);
2277 : }
2278 :
2279 810 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2280 : team, team_number);
2281 810 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2282 810 : }
2283 :
2284 :
2285 : static void
2286 13016 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2287 : {
2288 13016 : gfc_se argse;
2289 :
2290 13016 : gfc_init_se (&argse, NULL);
2291 13016 : argse.data_not_needed = 1;
2292 13016 : argse.descriptor_only = 1;
2293 :
2294 13016 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2295 13016 : gfc_add_block_to_block (&se->pre, &argse.pre);
2296 13016 : gfc_add_block_to_block (&se->post, &argse.post);
2297 :
2298 13016 : se->expr = gfc_conv_descriptor_rank (argse.expr);
2299 13016 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2300 : se->expr);
2301 13016 : }
2302 :
2303 :
2304 : static void
2305 735 : gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2306 : {
2307 735 : gfc_expr *arg;
2308 735 : arg = expr->value.function.actual->expr;
2309 735 : gfc_conv_is_contiguous_expr (se, arg);
2310 735 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2311 735 : }
2312 :
2313 : /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2314 : plus it can be called directly. */
2315 :
2316 : void
2317 2077 : gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2318 : {
2319 2077 : gfc_ss *ss;
2320 2077 : gfc_se argse;
2321 2077 : tree desc, tmp, stride, extent, cond;
2322 2077 : int i;
2323 2077 : tree fncall0;
2324 2077 : gfc_array_spec *as;
2325 2077 : gfc_symbol *sym = NULL;
2326 :
2327 2077 : if (arg->ts.type == BT_CLASS)
2328 90 : gfc_add_class_array_ref (arg);
2329 :
2330 2077 : if (arg->expr_type == EXPR_VARIABLE)
2331 2041 : sym = arg->symtree->n.sym;
2332 :
2333 2077 : ss = gfc_walk_expr (arg);
2334 2077 : gcc_assert (ss != gfc_ss_terminator);
2335 2077 : gfc_init_se (&argse, NULL);
2336 2077 : argse.data_not_needed = 1;
2337 2077 : gfc_conv_expr_descriptor (&argse, arg);
2338 :
2339 2077 : 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 2077 : if (as && as->type == AS_ASSUMED_RANK)
2345 : {
2346 : /* Build the call to is_contiguous0. */
2347 243 : argse.want_pointer = 1;
2348 243 : gfc_conv_expr_descriptor (&argse, arg);
2349 243 : gfc_add_block_to_block (&se->pre, &argse.pre);
2350 243 : gfc_add_block_to_block (&se->post, &argse.post);
2351 243 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2352 243 : fncall0 = build_call_expr_loc (input_location,
2353 : gfor_fndecl_is_contiguous0, 1, desc);
2354 243 : se->expr = fncall0;
2355 243 : se->expr = convert (boolean_type_node, se->expr);
2356 : }
2357 : else
2358 : {
2359 1834 : gfc_add_block_to_block (&se->pre, &argse.pre);
2360 1834 : gfc_add_block_to_block (&se->post, &argse.post);
2361 1834 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2362 :
2363 1834 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2364 1834 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2365 1834 : stride, build_int_cst (TREE_TYPE (stride), 1));
2366 :
2367 2157 : for (i = 0; i < arg->rank - 1; i++)
2368 : {
2369 323 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2370 323 : extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2371 323 : extent = fold_build2_loc (input_location, MINUS_EXPR,
2372 : gfc_array_index_type, extent, tmp);
2373 323 : extent = fold_build2_loc (input_location, PLUS_EXPR,
2374 : gfc_array_index_type, extent,
2375 : gfc_index_one_node);
2376 323 : tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2377 323 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2378 : tmp, extent);
2379 323 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2380 323 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2381 : stride, tmp);
2382 323 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2383 : boolean_type_node, cond, tmp);
2384 : }
2385 1834 : se->expr = cond;
2386 : }
2387 :
2388 : /* A pointer that does not have the CONTIGUOUS attribute needs to be checked
2389 : if it points to an array whose span differs from the element size. */
2390 2077 : if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous)
2391 : {
2392 180 : tree span = gfc_conv_descriptor_span_get (desc);
2393 180 : tmp = fold_convert (TREE_TYPE (span),
2394 : gfc_conv_descriptor_elem_len (desc));
2395 180 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2396 : span, tmp);
2397 180 : se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2398 : boolean_type_node, cond,
2399 : convert (boolean_type_node, se->expr));
2400 : }
2401 :
2402 2077 : gfc_free_ss_chain (ss);
2403 2077 : }
2404 :
2405 :
2406 : /* Evaluate a single upper or lower bound. */
2407 : /* TODO: bound intrinsic generates way too much unnecessary code. */
2408 :
2409 : static void
2410 16297 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2411 : {
2412 16297 : gfc_actual_arglist *arg;
2413 16297 : gfc_actual_arglist *arg2;
2414 16297 : tree desc;
2415 16297 : tree type;
2416 16297 : tree bound;
2417 16297 : tree tmp;
2418 16297 : tree cond, cond1;
2419 16297 : tree ubound;
2420 16297 : tree lbound;
2421 16297 : tree size;
2422 16297 : gfc_se argse;
2423 16297 : gfc_array_spec * as;
2424 16297 : bool assumed_rank_lb_one;
2425 :
2426 16297 : arg = expr->value.function.actual;
2427 16297 : arg2 = arg->next;
2428 :
2429 16297 : if (se->ss)
2430 : {
2431 : /* Create an implicit second parameter from the loop variable. */
2432 7992 : gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2433 7992 : gcc_assert (se->loop->dimen == 1);
2434 7992 : gcc_assert (se->ss->info->expr == expr);
2435 7992 : gfc_advance_se_ss_chain (se);
2436 7992 : bound = se->loop->loopvar[0];
2437 7992 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2438 : gfc_array_index_type, bound,
2439 : se->loop->from[0]);
2440 7992 : bound = fold_convert_loc (input_location, gfc_array_dim_rank_type,
2441 : bound);
2442 : }
2443 : else
2444 : {
2445 : /* use the passed argument. */
2446 8305 : gcc_assert (arg2->expr);
2447 8305 : gfc_init_se (&argse, NULL);
2448 8305 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_dim_rank_type);
2449 8305 : gfc_add_block_to_block (&se->pre, &argse.pre);
2450 8305 : bound = argse.expr;
2451 : /* Convert from one based to zero based. */
2452 8305 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2453 : gfc_array_dim_rank_type, bound,
2454 : gfc_rank_cst[1]);
2455 : }
2456 :
2457 : /* TODO: don't re-evaluate the descriptor on each iteration. */
2458 : /* Get a descriptor for the first parameter. */
2459 16297 : gfc_init_se (&argse, NULL);
2460 16297 : gfc_conv_expr_descriptor (&argse, arg->expr);
2461 16297 : gfc_add_block_to_block (&se->pre, &argse.pre);
2462 16297 : gfc_add_block_to_block (&se->post, &argse.post);
2463 :
2464 16297 : desc = argse.expr;
2465 :
2466 16297 : as = gfc_get_full_arrayspec_from_expr (arg->expr);
2467 :
2468 16297 : if (INTEGER_CST_P (bound))
2469 : {
2470 8185 : gcc_assert (op != GFC_ISYM_SHAPE);
2471 7948 : if (((!as || as->type != AS_ASSUMED_RANK)
2472 7277 : && wi::geu_p (wi::to_wide (bound),
2473 7277 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2474 16370 : || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2475 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2476 : "dimension index",
2477 : (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
2478 : &expr->where);
2479 : }
2480 :
2481 16297 : if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2482 : {
2483 9020 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2484 : {
2485 651 : bound = gfc_evaluate_now (bound, &se->pre);
2486 651 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2487 : bound, gfc_rank_cst[0]);
2488 651 : if (as && as->type == AS_ASSUMED_RANK)
2489 546 : tmp = gfc_conv_descriptor_rank (desc);
2490 : else
2491 105 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2492 651 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2493 : bound, tmp);
2494 651 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2495 : logical_type_node, cond, tmp);
2496 651 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2497 : gfc_msg_fault);
2498 : }
2499 : }
2500 :
2501 : /* Take care of the lbound shift for assumed-rank arrays that are
2502 : nonallocatable and nonpointers. Those have a lbound of 1. */
2503 15713 : assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2504 11205 : && ((arg->expr->ts.type != BT_CLASS
2505 1987 : && !arg->expr->symtree->n.sym->attr.allocatable
2506 1644 : && !arg->expr->symtree->n.sym->attr.pointer)
2507 920 : || (arg->expr->ts.type == BT_CLASS
2508 198 : && !CLASS_DATA (arg->expr)->attr.allocatable
2509 162 : && !CLASS_DATA (arg->expr)->attr.class_pointer));
2510 :
2511 16297 : ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2512 16297 : lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2513 16297 : size = fold_build2_loc (input_location, MINUS_EXPR,
2514 : gfc_array_index_type, ubound, lbound);
2515 16297 : size = fold_build2_loc (input_location, PLUS_EXPR,
2516 : gfc_array_index_type, size, gfc_index_one_node);
2517 :
2518 : /* 13.14.53: Result value for LBOUND
2519 :
2520 : Case (i): For an array section or for an array expression other than a
2521 : whole array or array structure component, LBOUND(ARRAY, DIM)
2522 : has the value 1. For a whole array or array structure
2523 : component, LBOUND(ARRAY, DIM) has the value:
2524 : (a) equal to the lower bound for subscript DIM of ARRAY if
2525 : dimension DIM of ARRAY does not have extent zero
2526 : or if ARRAY is an assumed-size array of rank DIM,
2527 : or (b) 1 otherwise.
2528 :
2529 : 13.14.113: Result value for UBOUND
2530 :
2531 : Case (i): For an array section or for an array expression other than a
2532 : whole array or array structure component, UBOUND(ARRAY, DIM)
2533 : has the value equal to the number of elements in the given
2534 : dimension; otherwise, it has a value equal to the upper bound
2535 : for subscript DIM of ARRAY if dimension DIM of ARRAY does
2536 : not have size zero and has value zero if dimension DIM has
2537 : size zero. */
2538 :
2539 16297 : if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
2540 556 : se->expr = gfc_index_one_node;
2541 15741 : else if (as)
2542 : {
2543 15157 : if (op == GFC_ISYM_UBOUND)
2544 : {
2545 5407 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2546 : size, gfc_index_zero_node);
2547 10186 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2548 : gfc_array_index_type, cond,
2549 : (assumed_rank_lb_one ? size : ubound),
2550 : gfc_index_zero_node);
2551 : }
2552 9750 : else if (op == GFC_ISYM_LBOUND)
2553 : {
2554 4903 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2555 : size, gfc_index_zero_node);
2556 4903 : if (as->type == AS_ASSUMED_SIZE)
2557 : {
2558 98 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2559 : logical_type_node, bound,
2560 98 : build_int_cst (TREE_TYPE (bound),
2561 98 : arg->expr->rank - 1));
2562 98 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2563 : logical_type_node, cond, cond1);
2564 : }
2565 4903 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2566 : gfc_array_index_type, cond,
2567 : lbound, gfc_index_one_node);
2568 : }
2569 4847 : else if (op == GFC_ISYM_SHAPE)
2570 4847 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2571 : gfc_array_index_type, size,
2572 : gfc_index_zero_node);
2573 : else
2574 0 : gcc_unreachable ();
2575 :
2576 : /* According to F2018 16.9.172, para 5, an assumed rank object,
2577 : argument associated with and assumed size array, has the ubound
2578 : of the final dimension set to -1 and UBOUND must return this.
2579 : Similarly for the SHAPE intrinsic. */
2580 15157 : if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
2581 : {
2582 835 : tree minus_one = build_int_cst (gfc_array_index_type, -1);
2583 835 : tree rank = gfc_conv_descriptor_rank (desc);
2584 835 : rank = fold_build2_loc (input_location, MINUS_EXPR,
2585 : gfc_array_dim_rank_type, rank,
2586 : gfc_rank_cst[1]);
2587 :
2588 : /* Fix the expression to stop it from becoming even more
2589 : complicated. */
2590 835 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
2591 :
2592 : /* Descriptors for assumed-size arrays have ubound = -1
2593 : in the last dimension. */
2594 835 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2595 : logical_type_node, ubound, minus_one);
2596 835 : cond = fold_build2_loc (input_location, EQ_EXPR,
2597 : logical_type_node, bound, rank);
2598 835 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2599 : logical_type_node, cond, cond1);
2600 835 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2601 : gfc_array_index_type, cond,
2602 : minus_one, se->expr);
2603 : }
2604 : }
2605 : else /* as is null; this is an old-fashioned 1-based array. */
2606 : {
2607 584 : if (op != GFC_ISYM_LBOUND)
2608 : {
2609 482 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2610 : gfc_array_index_type, size,
2611 : gfc_index_zero_node);
2612 : }
2613 : else
2614 102 : se->expr = gfc_index_one_node;
2615 : }
2616 :
2617 :
2618 16297 : type = gfc_typenode_for_spec (&expr->ts);
2619 16297 : se->expr = convert (type, se->expr);
2620 16297 : }
2621 :
2622 :
2623 : static void
2624 666 : conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2625 : {
2626 666 : gfc_actual_arglist *arg;
2627 666 : gfc_actual_arglist *arg2;
2628 666 : gfc_se argse;
2629 666 : tree bound, lbound, resbound, resbound2, desc, cond, tmp;
2630 666 : tree type;
2631 666 : int corank;
2632 :
2633 666 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2634 : || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2635 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE
2636 : || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2637 :
2638 666 : arg = expr->value.function.actual;
2639 666 : arg2 = arg->next;
2640 :
2641 666 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2642 666 : corank = arg->expr->corank;
2643 :
2644 666 : gfc_init_se (&argse, NULL);
2645 666 : argse.want_coarray = 1;
2646 :
2647 666 : gfc_conv_expr_descriptor (&argse, arg->expr);
2648 666 : gfc_add_block_to_block (&se->pre, &argse.pre);
2649 666 : gfc_add_block_to_block (&se->post, &argse.post);
2650 666 : desc = argse.expr;
2651 :
2652 666 : if (se->ss)
2653 : {
2654 : /* Create an implicit second parameter from the loop variable. */
2655 238 : gcc_assert (!arg2->expr
2656 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE);
2657 238 : gcc_assert (corank > 0);
2658 238 : gcc_assert (se->loop->dimen == 1);
2659 238 : gcc_assert (se->ss->info->expr == expr);
2660 :
2661 238 : bound = fold_convert_loc (input_location, gfc_array_dim_rank_type,
2662 : se->loop->loopvar[0]);
2663 238 : tree rank = gfc_rank_cst[arg->expr->rank];
2664 238 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2665 : gfc_array_dim_rank_type, bound, rank);
2666 238 : gfc_advance_se_ss_chain (se);
2667 : }
2668 428 : else if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2669 0 : bound = gfc_rank_cst[1];
2670 : else
2671 : {
2672 428 : gcc_assert (arg2->expr);
2673 428 : gfc_init_se (&argse, NULL);
2674 428 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_dim_rank_type);
2675 428 : gfc_add_block_to_block (&se->pre, &argse.pre);
2676 428 : bound = argse.expr;
2677 :
2678 428 : if (INTEGER_CST_P (bound))
2679 : {
2680 334 : if (wi::ltu_p (wi::to_wide (bound), 1)
2681 668 : || wi::gtu_p (wi::to_wide (bound),
2682 334 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2683 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2684 0 : "dimension index", expr->value.function.isym->name,
2685 : &expr->where);
2686 : }
2687 94 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2688 : {
2689 36 : bound = gfc_evaluate_now (bound, &se->pre);
2690 36 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2691 : bound, gfc_rank_cst[1]);
2692 36 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2693 36 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2694 : bound, rank);
2695 36 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2696 : logical_type_node, cond, tmp);
2697 36 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2698 : gfc_msg_fault);
2699 : }
2700 :
2701 :
2702 : /* Subtract 1 to get to zero based and add dimensions. */
2703 428 : switch (arg->expr->rank)
2704 : {
2705 70 : case 0:
2706 70 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2707 : gfc_array_dim_rank_type, bound,
2708 : gfc_rank_cst[1]);
2709 : case 1:
2710 : break;
2711 38 : default:
2712 38 : {
2713 38 : tree rank = gfc_rank_cst[arg->expr->rank - 1];
2714 38 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2715 : gfc_array_dim_rank_type, bound, rank);
2716 : }
2717 : }
2718 : }
2719 :
2720 666 : resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2721 :
2722 : /* COSHAPE needs the lower cobound and so it is stashed here before resbound
2723 : is overwritten. */
2724 666 : lbound = NULL_TREE;
2725 666 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2726 4 : lbound = resbound;
2727 :
2728 : /* Handle UCOBOUND with special handling of the last codimension. */
2729 666 : if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2730 422 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2731 : {
2732 : /* Last codimension: For -fcoarray=single just return
2733 : the lcobound - otherwise add
2734 : ceiling (real (num_images ()) / real (size)) - 1
2735 : = (num_images () + size - 1) / size - 1
2736 : = (num_images - 1) / size(),
2737 : where size is the product of the extent of all but the last
2738 : codimension. */
2739 :
2740 248 : if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2741 : {
2742 64 : tree cosize;
2743 :
2744 64 : cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2745 64 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2746 : 2, null_pointer_node, null_pointer_node);
2747 64 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2748 : gfc_array_index_type,
2749 : fold_convert (gfc_array_index_type, tmp),
2750 : build_int_cst (gfc_array_index_type, 1));
2751 64 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2752 : gfc_array_index_type, tmp,
2753 : fold_convert (gfc_array_index_type, cosize));
2754 64 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2755 : gfc_array_index_type, resbound, tmp);
2756 64 : }
2757 184 : else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2758 : {
2759 : /* ubound = lbound + num_images() - 1. */
2760 44 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2761 : 2, null_pointer_node, null_pointer_node);
2762 44 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2763 : gfc_array_index_type,
2764 : fold_convert (gfc_array_index_type, tmp),
2765 : build_int_cst (gfc_array_index_type, 1));
2766 44 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2767 : gfc_array_index_type, resbound, tmp);
2768 : }
2769 :
2770 248 : if (corank > 1)
2771 : {
2772 171 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2773 : bound,
2774 171 : build_int_cst (TREE_TYPE (bound),
2775 171 : arg->expr->rank + corank - 1));
2776 :
2777 171 : resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2778 171 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2779 : gfc_array_index_type, cond,
2780 : resbound, resbound2);
2781 : }
2782 : else
2783 77 : se->expr = resbound;
2784 :
2785 : /* Get the coshape for this dimension. */
2786 248 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2787 : {
2788 4 : gcc_assert (lbound != NULL_TREE);
2789 4 : se->expr = fold_build2_loc (input_location, MINUS_EXPR,
2790 : gfc_array_index_type,
2791 : se->expr, lbound);
2792 4 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2793 : gfc_array_index_type,
2794 : se->expr, gfc_index_one_node);
2795 : }
2796 : }
2797 : else
2798 418 : se->expr = resbound;
2799 :
2800 666 : type = gfc_typenode_for_spec (&expr->ts);
2801 666 : se->expr = convert (type, se->expr);
2802 666 : }
2803 :
2804 :
2805 : static void
2806 2357 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2807 : {
2808 2357 : gfc_actual_arglist *array_arg;
2809 2357 : gfc_actual_arglist *dim_arg;
2810 2357 : gfc_se argse;
2811 2357 : tree desc, tmp;
2812 :
2813 2357 : array_arg = expr->value.function.actual;
2814 2357 : dim_arg = array_arg->next;
2815 :
2816 2357 : gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2817 :
2818 2357 : gfc_init_se (&argse, NULL);
2819 2357 : gfc_conv_expr_descriptor (&argse, array_arg->expr);
2820 2357 : gfc_add_block_to_block (&se->pre, &argse.pre);
2821 2357 : gfc_add_block_to_block (&se->post, &argse.post);
2822 2357 : desc = argse.expr;
2823 :
2824 2357 : gcc_assert (dim_arg->expr);
2825 2357 : gfc_init_se (&argse, NULL);
2826 2357 : gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2827 2357 : gfc_add_block_to_block (&se->pre, &argse.pre);
2828 2357 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2829 : argse.expr, gfc_index_one_node);
2830 2357 : se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2831 2357 : }
2832 :
2833 : static void
2834 7980 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2835 : {
2836 7980 : tree arg, cabs;
2837 :
2838 7980 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2839 :
2840 7980 : switch (expr->value.function.actual->expr->ts.type)
2841 : {
2842 6974 : case BT_INTEGER:
2843 6974 : case BT_REAL:
2844 6974 : se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2845 : arg);
2846 6974 : break;
2847 :
2848 1006 : case BT_COMPLEX:
2849 1006 : cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
2850 1006 : se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2851 1006 : break;
2852 :
2853 0 : default:
2854 0 : gcc_unreachable ();
2855 : }
2856 7980 : }
2857 :
2858 :
2859 : /* Create a complex value from one or two real components. */
2860 :
2861 : static void
2862 491 : gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2863 : {
2864 491 : tree real;
2865 491 : tree imag;
2866 491 : tree type;
2867 491 : tree *args;
2868 491 : unsigned int num_args;
2869 :
2870 491 : num_args = gfc_intrinsic_argument_list_length (expr);
2871 491 : args = XALLOCAVEC (tree, num_args);
2872 :
2873 491 : type = gfc_typenode_for_spec (&expr->ts);
2874 491 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2875 491 : real = convert (TREE_TYPE (type), args[0]);
2876 491 : if (both)
2877 447 : imag = convert (TREE_TYPE (type), args[1]);
2878 44 : else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
2879 : {
2880 30 : imag = fold_build1_loc (input_location, IMAGPART_EXPR,
2881 30 : TREE_TYPE (TREE_TYPE (args[0])), args[0]);
2882 30 : imag = convert (TREE_TYPE (type), imag);
2883 : }
2884 : else
2885 14 : imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
2886 :
2887 491 : se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
2888 491 : }
2889 :
2890 :
2891 : /* Remainder function MOD(A, P) = A - INT(A / P) * P
2892 : MODULO(A, P) = A - FLOOR (A / P) * P
2893 :
2894 : The obvious algorithms above are numerically instable for large
2895 : arguments, hence these intrinsics are instead implemented via calls
2896 : to the fmod family of functions. It is the responsibility of the
2897 : user to ensure that the second argument is non-zero. */
2898 :
2899 : static void
2900 3760 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2901 : {
2902 3760 : tree type;
2903 3760 : tree tmp;
2904 3760 : tree test;
2905 3760 : tree test2;
2906 3760 : tree fmod;
2907 3760 : tree zero;
2908 3760 : tree args[2];
2909 :
2910 3760 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
2911 :
2912 3760 : switch (expr->ts.type)
2913 : {
2914 3607 : case BT_INTEGER:
2915 : /* Integer case is easy, we've got a builtin op. */
2916 3607 : type = TREE_TYPE (args[0]);
2917 :
2918 3607 : if (modulo)
2919 411 : se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2920 : args[0], args[1]);
2921 : else
2922 3196 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2923 : args[0], args[1]);
2924 : break;
2925 :
2926 30 : case BT_UNSIGNED:
2927 : /* Even easier, we only need one. */
2928 30 : type = TREE_TYPE (args[0]);
2929 30 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2930 : args[0], args[1]);
2931 30 : break;
2932 :
2933 123 : case BT_REAL:
2934 123 : fmod = NULL_TREE;
2935 : /* Check if we have a builtin fmod. */
2936 123 : fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
2937 :
2938 : /* The builtin should always be available. */
2939 123 : gcc_assert (fmod != NULL_TREE);
2940 :
2941 123 : tmp = build_addr (fmod);
2942 123 : se->expr = build_call_array_loc (input_location,
2943 123 : TREE_TYPE (TREE_TYPE (fmod)),
2944 : tmp, 2, args);
2945 123 : if (modulo == 0)
2946 123 : return;
2947 :
2948 25 : type = TREE_TYPE (args[0]);
2949 :
2950 25 : args[0] = gfc_evaluate_now (args[0], &se->pre);
2951 25 : args[1] = gfc_evaluate_now (args[1], &se->pre);
2952 :
2953 : /* Definition:
2954 : modulo = arg - floor (arg/arg2) * arg2
2955 :
2956 : In order to calculate the result accurately, we use the fmod
2957 : function as follows.
2958 :
2959 : res = fmod (arg, arg2);
2960 : if (res)
2961 : {
2962 : if ((arg < 0) xor (arg2 < 0))
2963 : res += arg2;
2964 : }
2965 : else
2966 : res = copysign (0., arg2);
2967 :
2968 : => As two nested ternary exprs:
2969 :
2970 : res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
2971 : : copysign (0., arg2);
2972 :
2973 : */
2974 :
2975 25 : zero = gfc_build_const (type, integer_zero_node);
2976 25 : tmp = gfc_evaluate_now (se->expr, &se->pre);
2977 25 : if (!flag_signed_zeros)
2978 : {
2979 1 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2980 : args[0], zero);
2981 1 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2982 : args[1], zero);
2983 1 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
2984 : logical_type_node, test, test2);
2985 1 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
2986 : tmp, zero);
2987 1 : test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2988 : logical_type_node, test, test2);
2989 1 : test = gfc_evaluate_now (test, &se->pre);
2990 1 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
2991 : fold_build2_loc (input_location,
2992 : PLUS_EXPR,
2993 : type, tmp, args[1]),
2994 : tmp);
2995 : }
2996 : else
2997 : {
2998 24 : tree expr1, copysign, cscall;
2999 24 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3000 : expr->ts.kind);
3001 24 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3002 : args[0], zero);
3003 24 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3004 : args[1], zero);
3005 24 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3006 : logical_type_node, test, test2);
3007 24 : expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3008 : fold_build2_loc (input_location,
3009 : PLUS_EXPR,
3010 : type, tmp, args[1]),
3011 : tmp);
3012 24 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3013 : tmp, zero);
3014 24 : cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3015 : args[1]);
3016 24 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3017 : expr1, cscall);
3018 : }
3019 : return;
3020 :
3021 0 : default:
3022 0 : gcc_unreachable ();
3023 : }
3024 : }
3025 :
3026 : /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3027 : DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3028 : where the right shifts are logical (i.e. 0's are shifted in).
3029 : Because SHIFT_EXPR's want shifts strictly smaller than the integral
3030 : type width, we have to special-case both S == 0 and S == BITSIZE(J):
3031 : DSHIFTL(I,J,0) = I
3032 : DSHIFTL(I,J,BITSIZE) = J
3033 : DSHIFTR(I,J,0) = J
3034 : DSHIFTR(I,J,BITSIZE) = I. */
3035 :
3036 : static void
3037 132 : gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3038 : {
3039 132 : tree type, utype, stype, arg1, arg2, shift, res, left, right;
3040 132 : tree args[3], cond, tmp;
3041 132 : int bitsize;
3042 :
3043 132 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
3044 :
3045 132 : gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3046 132 : type = TREE_TYPE (args[0]);
3047 132 : bitsize = TYPE_PRECISION (type);
3048 132 : utype = unsigned_type_for (type);
3049 132 : stype = TREE_TYPE (args[2]);
3050 :
3051 132 : arg1 = gfc_evaluate_now (args[0], &se->pre);
3052 132 : arg2 = gfc_evaluate_now (args[1], &se->pre);
3053 132 : shift = gfc_evaluate_now (args[2], &se->pre);
3054 :
3055 : /* The generic case. */
3056 132 : tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3057 132 : build_int_cst (stype, bitsize), shift);
3058 198 : left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3059 : arg1, dshiftl ? shift : tmp);
3060 :
3061 198 : right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3062 : fold_convert (utype, arg2), dshiftl ? tmp : shift);
3063 132 : right = fold_convert (type, right);
3064 :
3065 132 : res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3066 :
3067 : /* Special cases. */
3068 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3069 : build_int_cst (stype, 0));
3070 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3071 : dshiftl ? arg1 : arg2, res);
3072 :
3073 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3074 132 : build_int_cst (stype, bitsize));
3075 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3076 : dshiftl ? arg2 : arg1, res);
3077 :
3078 132 : se->expr = res;
3079 132 : }
3080 :
3081 :
3082 : /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3083 :
3084 : static void
3085 96 : gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3086 : {
3087 96 : tree val;
3088 96 : tree tmp;
3089 96 : tree type;
3090 96 : tree zero;
3091 96 : tree args[2];
3092 :
3093 96 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3094 96 : type = TREE_TYPE (args[0]);
3095 :
3096 96 : val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3097 96 : val = gfc_evaluate_now (val, &se->pre);
3098 :
3099 96 : zero = gfc_build_const (type, integer_zero_node);
3100 96 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3101 96 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3102 96 : }
3103 :
3104 :
3105 : /* SIGN(A, B) is absolute value of A times sign of B.
3106 : The real value versions use library functions to ensure the correct
3107 : handling of negative zero. Integer case implemented as:
3108 : SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3109 : */
3110 :
3111 : static void
3112 423 : gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3113 : {
3114 423 : tree tmp;
3115 423 : tree type;
3116 423 : tree args[2];
3117 :
3118 423 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3119 423 : if (expr->ts.type == BT_REAL)
3120 : {
3121 161 : tree abs;
3122 :
3123 161 : tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3124 161 : abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3125 :
3126 : /* We explicitly have to ignore the minus sign. We do so by using
3127 : result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3128 161 : if (!flag_sign_zero
3129 197 : && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3130 : {
3131 12 : tree cond, zero;
3132 12 : zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3133 12 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3134 : args[1], zero);
3135 24 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3136 12 : TREE_TYPE (args[0]), cond,
3137 : build_call_expr_loc (input_location, abs, 1,
3138 : args[0]),
3139 : build_call_expr_loc (input_location, tmp, 2,
3140 : args[0], args[1]));
3141 : }
3142 : else
3143 149 : se->expr = build_call_expr_loc (input_location, tmp, 2,
3144 : args[0], args[1]);
3145 161 : return;
3146 : }
3147 :
3148 : /* Having excluded floating point types, we know we are now dealing
3149 : with signed integer types. */
3150 262 : type = TREE_TYPE (args[0]);
3151 :
3152 : /* Args[0] is used multiple times below. */
3153 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3154 :
3155 : /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3156 : the signs of A and B are the same, and of all ones if they differ. */
3157 262 : tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3158 262 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3159 262 : build_int_cst (type, TYPE_PRECISION (type) - 1));
3160 262 : tmp = gfc_evaluate_now (tmp, &se->pre);
3161 :
3162 : /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3163 : is all ones (i.e. -1). */
3164 262 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3165 : fold_build2_loc (input_location, PLUS_EXPR,
3166 : type, args[0], tmp), tmp);
3167 : }
3168 :
3169 :
3170 : /* Test for the presence of an optional argument. */
3171 :
3172 : static void
3173 5070 : gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3174 : {
3175 5070 : gfc_expr *arg;
3176 :
3177 5070 : arg = expr->value.function.actual->expr;
3178 5070 : gcc_assert (arg->expr_type == EXPR_VARIABLE);
3179 5070 : se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3180 5070 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3181 5070 : }
3182 :
3183 :
3184 : /* Calculate the double precision product of two single precision values. */
3185 :
3186 : static void
3187 13 : gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3188 : {
3189 13 : tree type;
3190 13 : tree args[2];
3191 :
3192 13 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3193 :
3194 : /* Convert the args to double precision before multiplying. */
3195 13 : type = gfc_typenode_for_spec (&expr->ts);
3196 13 : args[0] = convert (type, args[0]);
3197 13 : args[1] = convert (type, args[1]);
3198 13 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3199 : args[1]);
3200 13 : }
3201 :
3202 :
3203 : /* Return a length one character string containing an ascii character. */
3204 :
3205 : static void
3206 2020 : gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3207 : {
3208 2020 : tree arg[2];
3209 2020 : tree var;
3210 2020 : tree type;
3211 2020 : unsigned int num_args;
3212 :
3213 2020 : num_args = gfc_intrinsic_argument_list_length (expr);
3214 2020 : gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3215 :
3216 2020 : type = gfc_get_char_type (expr->ts.kind);
3217 2020 : var = gfc_create_var (type, "char");
3218 :
3219 2020 : arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3220 2020 : gfc_add_modify (&se->pre, var, arg[0]);
3221 2020 : se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3222 2020 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3223 2020 : }
3224 :
3225 :
3226 : static void
3227 0 : gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3228 : {
3229 0 : tree var;
3230 0 : tree len;
3231 0 : tree tmp;
3232 0 : tree cond;
3233 0 : tree fndecl;
3234 0 : tree *args;
3235 0 : unsigned int num_args;
3236 :
3237 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3238 0 : args = XALLOCAVEC (tree, num_args);
3239 :
3240 0 : var = gfc_create_var (pchar_type_node, "pstr");
3241 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3242 :
3243 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3244 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3245 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3246 :
3247 0 : fndecl = build_addr (gfor_fndecl_ctime);
3248 0 : tmp = build_call_array_loc (input_location,
3249 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3250 : fndecl, num_args, args);
3251 0 : gfc_add_expr_to_block (&se->pre, tmp);
3252 :
3253 : /* Free the temporary afterwards, if necessary. */
3254 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3255 0 : len, build_int_cst (TREE_TYPE (len), 0));
3256 0 : tmp = gfc_call_free (var);
3257 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3258 0 : gfc_add_expr_to_block (&se->post, tmp);
3259 :
3260 0 : se->expr = var;
3261 0 : se->string_length = len;
3262 0 : }
3263 :
3264 :
3265 : static void
3266 0 : gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3267 : {
3268 0 : tree var;
3269 0 : tree len;
3270 0 : tree tmp;
3271 0 : tree cond;
3272 0 : tree fndecl;
3273 0 : tree *args;
3274 0 : unsigned int num_args;
3275 :
3276 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3277 0 : args = XALLOCAVEC (tree, num_args);
3278 :
3279 0 : var = gfc_create_var (pchar_type_node, "pstr");
3280 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3281 :
3282 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3283 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3284 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3285 :
3286 0 : fndecl = build_addr (gfor_fndecl_fdate);
3287 0 : tmp = build_call_array_loc (input_location,
3288 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3289 : fndecl, num_args, args);
3290 0 : gfc_add_expr_to_block (&se->pre, tmp);
3291 :
3292 : /* Free the temporary afterwards, if necessary. */
3293 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3294 0 : len, build_int_cst (TREE_TYPE (len), 0));
3295 0 : tmp = gfc_call_free (var);
3296 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3297 0 : gfc_add_expr_to_block (&se->post, tmp);
3298 :
3299 0 : se->expr = var;
3300 0 : se->string_length = len;
3301 0 : }
3302 :
3303 :
3304 : /* Generate a direct call to free() for the FREE subroutine. */
3305 :
3306 : static tree
3307 10 : conv_intrinsic_free (gfc_code *code)
3308 : {
3309 10 : stmtblock_t block;
3310 10 : gfc_se argse;
3311 10 : tree arg, call;
3312 :
3313 10 : gfc_init_se (&argse, NULL);
3314 10 : gfc_conv_expr (&argse, code->ext.actual->expr);
3315 10 : arg = fold_convert (ptr_type_node, argse.expr);
3316 :
3317 10 : gfc_init_block (&block);
3318 10 : call = build_call_expr_loc (input_location,
3319 : builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3320 10 : gfc_add_expr_to_block (&block, call);
3321 10 : return gfc_finish_block (&block);
3322 : }
3323 :
3324 :
3325 : /* Call the RANDOM_INIT library subroutine with a hidden argument for
3326 : handling seeding on coarray images. */
3327 :
3328 : static tree
3329 90 : conv_intrinsic_random_init (gfc_code *code)
3330 : {
3331 90 : stmtblock_t block;
3332 90 : gfc_se se;
3333 90 : tree arg1, arg2, tmp;
3334 : /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3335 90 : tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3336 90 : ? logical_type_node
3337 90 : : gfc_get_logical_type (4);
3338 :
3339 : /* Make the function call. */
3340 90 : gfc_init_block (&block);
3341 90 : gfc_init_se (&se, NULL);
3342 :
3343 : /* Convert REPEATABLE to the desired LOGICAL entity. */
3344 90 : gfc_conv_expr (&se, code->ext.actual->expr);
3345 90 : gfc_add_block_to_block (&block, &se.pre);
3346 90 : arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3347 90 : gfc_add_block_to_block (&block, &se.post);
3348 :
3349 : /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3350 90 : gfc_conv_expr (&se, code->ext.actual->next->expr);
3351 90 : gfc_add_block_to_block (&block, &se.pre);
3352 90 : arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3353 90 : gfc_add_block_to_block (&block, &se.post);
3354 :
3355 90 : if (flag_coarray == GFC_FCOARRAY_LIB)
3356 : {
3357 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3358 : 2, arg1, arg2);
3359 : }
3360 : else
3361 : {
3362 : /* The ABI for libgfortran needs to be maintained, so a hidden
3363 : argument must be include if code is compiled with -fcoarray=single
3364 : or without the option. Set to 0. */
3365 90 : tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3366 90 : tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3367 : 3, arg1, arg2, arg3);
3368 : }
3369 :
3370 90 : gfc_add_expr_to_block (&block, tmp);
3371 :
3372 90 : return gfc_finish_block (&block);
3373 : }
3374 :
3375 :
3376 : /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3377 : conversions. */
3378 :
3379 : static tree
3380 196 : conv_intrinsic_system_clock (gfc_code *code)
3381 : {
3382 196 : stmtblock_t block;
3383 196 : gfc_se count_se, count_rate_se, count_max_se;
3384 196 : tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3385 196 : tree tmp;
3386 196 : int least;
3387 :
3388 196 : gfc_expr *count = code->ext.actual->expr;
3389 196 : gfc_expr *count_rate = code->ext.actual->next->expr;
3390 196 : gfc_expr *count_max = code->ext.actual->next->next->expr;
3391 :
3392 : /* Evaluate our arguments. */
3393 196 : if (count)
3394 : {
3395 196 : gfc_init_se (&count_se, NULL);
3396 196 : gfc_conv_expr (&count_se, count);
3397 : }
3398 :
3399 196 : if (count_rate)
3400 : {
3401 181 : gfc_init_se (&count_rate_se, NULL);
3402 181 : gfc_conv_expr (&count_rate_se, count_rate);
3403 : }
3404 :
3405 196 : if (count_max)
3406 : {
3407 180 : gfc_init_se (&count_max_se, NULL);
3408 180 : gfc_conv_expr (&count_max_se, count_max);
3409 : }
3410 :
3411 : /* Find the smallest kind found of the arguments. */
3412 196 : least = 16;
3413 196 : least = (count && count->ts.kind < least) ? count->ts.kind : least;
3414 196 : least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3415 : : least;
3416 196 : least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3417 : : least;
3418 :
3419 : /* Prepare temporary variables. */
3420 :
3421 196 : if (count)
3422 : {
3423 196 : if (least >= 8)
3424 18 : arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3425 178 : else if (least == 4)
3426 154 : arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3427 24 : else if (count->ts.kind == 1)
3428 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3429 : count->ts.kind);
3430 : else
3431 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3432 : count->ts.kind);
3433 : }
3434 :
3435 196 : if (count_rate)
3436 : {
3437 181 : if (least >= 8)
3438 18 : arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3439 163 : else if (least == 4)
3440 139 : arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3441 : else
3442 24 : arg2 = integer_zero_node;
3443 : }
3444 :
3445 196 : if (count_max)
3446 : {
3447 180 : if (least >= 8)
3448 18 : arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3449 162 : else if (least == 4)
3450 138 : arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3451 : else
3452 24 : arg3 = integer_zero_node;
3453 : }
3454 :
3455 : /* Make the function call. */
3456 196 : gfc_init_block (&block);
3457 :
3458 196 : if (least <= 2)
3459 : {
3460 24 : if (least == 1)
3461 : {
3462 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3463 : : null_pointer_node;
3464 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3465 : : null_pointer_node;
3466 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3467 : : null_pointer_node;
3468 : }
3469 :
3470 24 : if (least == 2)
3471 : {
3472 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3473 : : null_pointer_node;
3474 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3475 : : null_pointer_node;
3476 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3477 : : null_pointer_node;
3478 : }
3479 : }
3480 : else
3481 : {
3482 172 : if (least == 4)
3483 : {
3484 585 : tmp = build_call_expr_loc (input_location,
3485 : gfor_fndecl_system_clock4, 3,
3486 154 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3487 : : null_pointer_node,
3488 139 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3489 : : null_pointer_node,
3490 138 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3491 : : null_pointer_node);
3492 154 : gfc_add_expr_to_block (&block, tmp);
3493 : }
3494 : /* Handle kind>=8, 10, or 16 arguments */
3495 172 : if (least >= 8)
3496 : {
3497 72 : tmp = build_call_expr_loc (input_location,
3498 : gfor_fndecl_system_clock8, 3,
3499 18 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3500 : : null_pointer_node,
3501 18 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3502 : : null_pointer_node,
3503 18 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3504 : : null_pointer_node);
3505 18 : gfc_add_expr_to_block (&block, tmp);
3506 : }
3507 : }
3508 :
3509 : /* And store values back if needed. */
3510 196 : if (arg1 && arg1 != count_se.expr)
3511 196 : gfc_add_modify (&block, count_se.expr,
3512 196 : fold_convert (TREE_TYPE (count_se.expr), arg1));
3513 196 : if (arg2 && arg2 != count_rate_se.expr)
3514 181 : gfc_add_modify (&block, count_rate_se.expr,
3515 181 : fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3516 196 : if (arg3 && arg3 != count_max_se.expr)
3517 180 : gfc_add_modify (&block, count_max_se.expr,
3518 180 : fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3519 :
3520 196 : return gfc_finish_block (&block);
3521 : }
3522 :
3523 : static tree
3524 102 : conv_intrinsic_split (gfc_code *code)
3525 : {
3526 102 : stmtblock_t block, post_block;
3527 102 : gfc_se se;
3528 102 : gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
3529 102 : tree string, string_len;
3530 102 : tree set, set_len;
3531 102 : tree pos, pos_for_call;
3532 102 : tree back;
3533 102 : tree fndecl, call;
3534 :
3535 102 : string_expr = code->ext.actual->expr;
3536 102 : set_expr = code->ext.actual->next->expr;
3537 102 : pos_expr = code->ext.actual->next->next->expr;
3538 102 : back_expr = code->ext.actual->next->next->next->expr;
3539 :
3540 102 : gfc_start_block (&block);
3541 102 : gfc_init_block (&post_block);
3542 :
3543 102 : gfc_init_se (&se, NULL);
3544 102 : gfc_conv_expr (&se, string_expr);
3545 102 : gfc_conv_string_parameter (&se);
3546 102 : gfc_add_block_to_block (&block, &se.pre);
3547 102 : gfc_add_block_to_block (&post_block, &se.post);
3548 102 : string = se.expr;
3549 102 : string_len = se.string_length;
3550 :
3551 102 : gfc_init_se (&se, NULL);
3552 102 : gfc_conv_expr (&se, set_expr);
3553 102 : gfc_conv_string_parameter (&se);
3554 102 : gfc_add_block_to_block (&block, &se.pre);
3555 102 : gfc_add_block_to_block (&post_block, &se.post);
3556 102 : set = se.expr;
3557 102 : set_len = se.string_length;
3558 :
3559 102 : gfc_init_se (&se, NULL);
3560 102 : gfc_conv_expr (&se, pos_expr);
3561 102 : gfc_add_block_to_block (&block, &se.pre);
3562 102 : gfc_add_block_to_block (&post_block, &se.post);
3563 102 : pos = se.expr;
3564 102 : pos_for_call = fold_convert (gfc_charlen_type_node, pos);
3565 :
3566 102 : if (back_expr)
3567 : {
3568 48 : gfc_init_se (&se, NULL);
3569 48 : gfc_conv_expr (&se, back_expr);
3570 48 : gfc_add_block_to_block (&block, &se.pre);
3571 48 : gfc_add_block_to_block (&post_block, &se.post);
3572 48 : back = se.expr;
3573 : }
3574 : else
3575 54 : back = logical_false_node;
3576 :
3577 102 : if (string_expr->ts.kind == 1)
3578 66 : fndecl = gfor_fndecl_string_split;
3579 36 : else if (string_expr->ts.kind == 4)
3580 36 : fndecl = gfor_fndecl_string_split_char4;
3581 : else
3582 0 : gcc_unreachable ();
3583 :
3584 102 : call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
3585 : set_len, set, pos_for_call, back);
3586 102 : gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
3587 :
3588 102 : gfc_add_block_to_block (&block, &post_block);
3589 102 : return gfc_finish_block (&block);
3590 : }
3591 :
3592 : /* Return a character string containing the tty name. */
3593 :
3594 : static void
3595 0 : gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3596 : {
3597 0 : tree var;
3598 0 : tree len;
3599 0 : tree tmp;
3600 0 : tree cond;
3601 0 : tree fndecl;
3602 0 : tree *args;
3603 0 : unsigned int num_args;
3604 :
3605 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3606 0 : args = XALLOCAVEC (tree, num_args);
3607 :
3608 0 : var = gfc_create_var (pchar_type_node, "pstr");
3609 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3610 :
3611 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3612 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3613 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3614 :
3615 0 : fndecl = build_addr (gfor_fndecl_ttynam);
3616 0 : tmp = build_call_array_loc (input_location,
3617 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3618 : fndecl, num_args, args);
3619 0 : gfc_add_expr_to_block (&se->pre, tmp);
3620 :
3621 : /* Free the temporary afterwards, if necessary. */
3622 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3623 0 : len, build_int_cst (TREE_TYPE (len), 0));
3624 0 : tmp = gfc_call_free (var);
3625 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3626 0 : gfc_add_expr_to_block (&se->post, tmp);
3627 :
3628 0 : se->expr = var;
3629 0 : se->string_length = len;
3630 0 : }
3631 :
3632 :
3633 : /* Get the minimum/maximum value of all the parameters.
3634 : minmax (a1, a2, a3, ...)
3635 : {
3636 : mvar = a1;
3637 : mvar = COMP (mvar, a2)
3638 : mvar = COMP (mvar, a3)
3639 : ...
3640 : return mvar;
3641 : }
3642 : Where COMP is MIN/MAX_EXPR for integral types or when we don't
3643 : care about NaNs, or IFN_FMIN/MAX when the target has support for
3644 : fast NaN-honouring min/max. When neither holds expand a sequence
3645 : of explicit comparisons. */
3646 :
3647 : /* TODO: Mismatching types can occur when specific names are used.
3648 : These should be handled during resolution. */
3649 : static void
3650 1365 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3651 : {
3652 1365 : tree tmp;
3653 1365 : tree mvar;
3654 1365 : tree val;
3655 1365 : tree *args;
3656 1365 : tree type;
3657 1365 : tree argtype;
3658 1365 : gfc_actual_arglist *argexpr;
3659 1365 : unsigned int i, nargs;
3660 :
3661 1365 : nargs = gfc_intrinsic_argument_list_length (expr);
3662 1365 : args = XALLOCAVEC (tree, nargs);
3663 :
3664 1365 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3665 1365 : type = gfc_typenode_for_spec (&expr->ts);
3666 :
3667 : /* Only evaluate the argument once. */
3668 1365 : if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3669 368 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3670 :
3671 : /* Determine suitable type of temporary, as a GNU extension allows
3672 : different argument kinds. */
3673 1365 : argtype = TREE_TYPE (args[0]);
3674 1365 : argexpr = expr->value.function.actual;
3675 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3676 : {
3677 1584 : tree tmptype = TREE_TYPE (args[i]);
3678 1584 : if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
3679 1 : argtype = tmptype;
3680 : }
3681 1365 : mvar = gfc_create_var (argtype, "M");
3682 1365 : gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
3683 :
3684 1365 : argexpr = expr->value.function.actual;
3685 2949 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3686 : {
3687 1584 : tree cond = NULL_TREE;
3688 1584 : val = args[i];
3689 :
3690 : /* Handle absent optional arguments by ignoring the comparison. */
3691 1584 : if (argexpr->expr->expr_type == EXPR_VARIABLE
3692 920 : && argexpr->expr->symtree->n.sym->attr.optional
3693 45 : && INDIRECT_REF_P (val))
3694 : {
3695 84 : cond = fold_build2_loc (input_location,
3696 : NE_EXPR, logical_type_node,
3697 42 : TREE_OPERAND (val, 0),
3698 42 : build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3699 : }
3700 1542 : else if (!VAR_P (val) && !TREE_CONSTANT (val))
3701 : /* Only evaluate the argument once. */
3702 599 : val = gfc_evaluate_now (val, &se->pre);
3703 :
3704 1584 : tree calc;
3705 : /* For floating point types, the question is what MAX(a, NaN) or
3706 : MIN(a, NaN) should return (where "a" is a normal number).
3707 : There are valid use case for returning either one, but the
3708 : Fortran standard doesn't specify which one should be chosen.
3709 : Also, there is no consensus among other tested compilers. In
3710 : short, it's a mess. So lets just do whatever is fastest. */
3711 1584 : tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
3712 1584 : calc = fold_build2_loc (input_location, code, argtype,
3713 : convert (argtype, val), mvar);
3714 1584 : tmp = build2_v (MODIFY_EXPR, mvar, calc);
3715 :
3716 1584 : if (cond != NULL_TREE)
3717 42 : tmp = build3_v (COND_EXPR, cond, tmp,
3718 : build_empty_stmt (input_location));
3719 1584 : gfc_add_expr_to_block (&se->pre, tmp);
3720 : }
3721 1365 : se->expr = convert (type, mvar);
3722 1365 : }
3723 :
3724 :
3725 : /* Generate library calls for MIN and MAX intrinsics for character
3726 : variables. */
3727 : static void
3728 282 : gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3729 : {
3730 282 : tree *args;
3731 282 : tree var, len, fndecl, tmp, cond, function;
3732 282 : unsigned int nargs;
3733 :
3734 282 : nargs = gfc_intrinsic_argument_list_length (expr);
3735 282 : args = XALLOCAVEC (tree, nargs + 4);
3736 282 : gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3737 :
3738 : /* Create the result variables. */
3739 282 : len = gfc_create_var (gfc_charlen_type_node, "len");
3740 282 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
3741 282 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3742 282 : args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3743 282 : args[2] = build_int_cst (integer_type_node, op);
3744 282 : args[3] = build_int_cst (integer_type_node, nargs / 2);
3745 :
3746 282 : if (expr->ts.kind == 1)
3747 210 : function = gfor_fndecl_string_minmax;
3748 72 : else if (expr->ts.kind == 4)
3749 72 : function = gfor_fndecl_string_minmax_char4;
3750 : else
3751 0 : gcc_unreachable ();
3752 :
3753 : /* Make the function call. */
3754 282 : fndecl = build_addr (function);
3755 282 : tmp = build_call_array_loc (input_location,
3756 282 : TREE_TYPE (TREE_TYPE (function)), fndecl,
3757 : nargs + 4, args);
3758 282 : gfc_add_expr_to_block (&se->pre, tmp);
3759 :
3760 : /* Free the temporary afterwards, if necessary. */
3761 282 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3762 282 : len, build_int_cst (TREE_TYPE (len), 0));
3763 282 : tmp = gfc_call_free (var);
3764 282 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3765 282 : gfc_add_expr_to_block (&se->post, tmp);
3766 :
3767 282 : se->expr = var;
3768 282 : se->string_length = len;
3769 282 : }
3770 :
3771 :
3772 : /* Create a symbol node for this intrinsic. The symbol from the frontend
3773 : has the generic name. */
3774 :
3775 : static gfc_symbol *
3776 11285 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3777 : {
3778 11285 : gfc_symbol *sym;
3779 :
3780 : /* TODO: Add symbols for intrinsic function to the global namespace. */
3781 11285 : gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3782 11285 : sym = gfc_new_symbol (expr->value.function.name, NULL);
3783 :
3784 11285 : sym->ts = expr->ts;
3785 11285 : if (sym->ts.type == BT_CHARACTER)
3786 1784 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3787 11285 : sym->attr.external = 1;
3788 11285 : sym->attr.function = 1;
3789 11285 : sym->attr.always_explicit = 1;
3790 11285 : sym->attr.proc = PROC_INTRINSIC;
3791 11285 : sym->attr.flavor = FL_PROCEDURE;
3792 11285 : sym->result = sym;
3793 11285 : if (expr->rank > 0)
3794 : {
3795 9891 : sym->attr.dimension = 1;
3796 9891 : sym->as = gfc_get_array_spec ();
3797 9891 : sym->as->type = AS_ASSUMED_SHAPE;
3798 9891 : sym->as->rank = expr->rank;
3799 : }
3800 :
3801 11285 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3802 : ignore_optional ? expr->value.function.actual
3803 : : NULL);
3804 :
3805 11285 : return sym;
3806 : }
3807 :
3808 : /* Remove empty actual arguments. */
3809 :
3810 : static void
3811 8277 : remove_empty_actual_arguments (gfc_actual_arglist **ap)
3812 : {
3813 44456 : while (*ap)
3814 : {
3815 36179 : if ((*ap)->expr == NULL)
3816 : {
3817 11076 : gfc_actual_arglist *r = *ap;
3818 11076 : *ap = r->next;
3819 11076 : r->next = NULL;
3820 11076 : gfc_free_actual_arglist (r);
3821 : }
3822 : else
3823 25103 : ap = &((*ap)->next);
3824 : }
3825 8277 : }
3826 :
3827 : #define MAX_SPEC_ARG 12
3828 :
3829 : /* Make up an fn spec that's right for intrinsic functions that we
3830 : want to call. */
3831 :
3832 : static char *
3833 1939 : intrinsic_fnspec (gfc_expr *expr)
3834 : {
3835 1939 : static char fnspec_buf[MAX_SPEC_ARG*2+1];
3836 1939 : char *fp;
3837 1939 : int i;
3838 1939 : int num_char_args;
3839 :
3840 : #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
3841 :
3842 : /* Set the fndecl. */
3843 1939 : fp = fnspec_buf;
3844 : /* Function return value. FIXME: Check if the second letter could
3845 : be something other than a space, for further optimization. */
3846 1939 : ADD_CHAR ('.');
3847 1939 : if (expr->rank == 0)
3848 : {
3849 238 : if (expr->ts.type == BT_CHARACTER)
3850 : {
3851 84 : ADD_CHAR ('w'); /* Address of character. */
3852 84 : ADD_CHAR ('.'); /* Length of character. */
3853 : }
3854 : }
3855 : else
3856 1701 : ADD_CHAR ('w'); /* Return value is a descriptor. */
3857 :
3858 1939 : num_char_args = 0;
3859 10224 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
3860 : {
3861 8285 : if (a->expr == NULL)
3862 2565 : continue;
3863 :
3864 5720 : if (a->name && strcmp (a->name,"%VAL") == 0)
3865 1300 : ADD_CHAR ('.');
3866 : else
3867 : {
3868 4420 : if (a->expr->rank > 0)
3869 2575 : ADD_CHAR ('r');
3870 : else
3871 1845 : ADD_CHAR ('R');
3872 : }
3873 5720 : num_char_args += a->expr->ts.type == BT_CHARACTER;
3874 5720 : gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
3875 : }
3876 :
3877 2743 : for (i = 0; i < num_char_args; i++)
3878 804 : ADD_CHAR ('.');
3879 :
3880 1939 : *fp = '\0';
3881 1939 : return fnspec_buf;
3882 : }
3883 :
3884 : #undef MAX_SPEC_ARG
3885 : #undef ADD_CHAR
3886 :
3887 : /* Generate the right symbol for the specific intrinsic function and
3888 : modify the expr accordingly. This assumes that absent optional
3889 : arguments should be removed. */
3890 :
3891 : gfc_symbol *
3892 8277 : specific_intrinsic_symbol (gfc_expr *expr)
3893 : {
3894 8277 : gfc_symbol *sym;
3895 :
3896 8277 : sym = gfc_find_intrinsic_symbol (expr);
3897 8277 : if (sym == NULL)
3898 : {
3899 1939 : sym = gfc_get_intrinsic_function_symbol (expr);
3900 1939 : sym->ts = expr->ts;
3901 1939 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
3902 240 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
3903 :
3904 1939 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3905 : expr->value.function.actual, true);
3906 1939 : sym->backend_decl
3907 1939 : = gfc_get_extern_function_decl (sym, expr->value.function.actual,
3908 1939 : intrinsic_fnspec (expr));
3909 : }
3910 :
3911 8277 : remove_empty_actual_arguments (&(expr->value.function.actual));
3912 :
3913 8277 : return sym;
3914 : }
3915 :
3916 : /* Generate a call to an external intrinsic function. FIXME: So far,
3917 : this only works for functions which are called with well-defined
3918 : types; CSHIFT and friends will come later. */
3919 :
3920 : static void
3921 13719 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3922 : {
3923 13719 : gfc_symbol *sym;
3924 13719 : vec<tree, va_gc> *append_args;
3925 13719 : bool specific_symbol;
3926 :
3927 13719 : gcc_assert (!se->ss || se->ss->info->expr == expr);
3928 :
3929 13719 : if (se->ss)
3930 11763 : gcc_assert (expr->rank > 0);
3931 : else
3932 1956 : gcc_assert (expr->rank == 0);
3933 :
3934 13719 : switch (expr->value.function.isym->id)
3935 : {
3936 : case GFC_ISYM_ANY:
3937 : case GFC_ISYM_ALL:
3938 : case GFC_ISYM_FINDLOC:
3939 : case GFC_ISYM_MAXLOC:
3940 : case GFC_ISYM_MINLOC:
3941 : case GFC_ISYM_MAXVAL:
3942 : case GFC_ISYM_MINVAL:
3943 : case GFC_ISYM_NORM2:
3944 : case GFC_ISYM_PRODUCT:
3945 : case GFC_ISYM_SUM:
3946 : specific_symbol = true;
3947 : break;
3948 5442 : default:
3949 5442 : specific_symbol = false;
3950 : }
3951 :
3952 13719 : if (specific_symbol)
3953 : {
3954 : /* Need to copy here because specific_intrinsic_symbol modifies
3955 : expr to omit the absent optional arguments. */
3956 8277 : expr = gfc_copy_expr (expr);
3957 8277 : sym = specific_intrinsic_symbol (expr);
3958 : }
3959 : else
3960 5442 : sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
3961 :
3962 : /* Calls to libgfortran_matmul need to be appended special arguments,
3963 : to be able to call the BLAS ?gemm functions if required and possible. */
3964 13719 : append_args = NULL;
3965 13719 : if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3966 866 : && !expr->external_blas
3967 828 : && sym->ts.type != BT_LOGICAL)
3968 : {
3969 812 : tree cint = gfc_get_int_type (gfc_c_int_kind);
3970 :
3971 812 : if (flag_external_blas
3972 0 : && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3973 0 : && (sym->ts.kind == 4 || sym->ts.kind == 8))
3974 : {
3975 0 : tree gemm_fndecl;
3976 :
3977 0 : if (sym->ts.type == BT_REAL)
3978 : {
3979 0 : if (sym->ts.kind == 4)
3980 0 : gemm_fndecl = gfor_fndecl_sgemm;
3981 : else
3982 0 : gemm_fndecl = gfor_fndecl_dgemm;
3983 : }
3984 : else
3985 : {
3986 0 : if (sym->ts.kind == 4)
3987 0 : gemm_fndecl = gfor_fndecl_cgemm;
3988 : else
3989 0 : gemm_fndecl = gfor_fndecl_zgemm;
3990 : }
3991 :
3992 0 : vec_alloc (append_args, 3);
3993 0 : append_args->quick_push (build_int_cst (cint, 1));
3994 0 : append_args->quick_push (build_int_cst (cint,
3995 0 : flag_blas_matmul_limit));
3996 0 : append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
3997 : gemm_fndecl));
3998 0 : }
3999 : else
4000 : {
4001 812 : vec_alloc (append_args, 3);
4002 812 : append_args->quick_push (build_int_cst (cint, 0));
4003 812 : append_args->quick_push (build_int_cst (cint, 0));
4004 812 : append_args->quick_push (null_pointer_node);
4005 : }
4006 : }
4007 : /* Non-character scalar reduce returns a pointer to a result of size set by
4008 : the element size of 'array'. Setting 'sym' allocatable ensures that the
4009 : result is deallocated at the appropriate time. */
4010 12907 : else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
4011 102 : && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
4012 96 : sym->attr.allocatable = 1;
4013 :
4014 :
4015 13719 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4016 : append_args);
4017 :
4018 13719 : if (specific_symbol)
4019 8277 : gfc_free_expr (expr);
4020 : else
4021 5442 : gfc_free_symbol (sym);
4022 13719 : }
4023 :
4024 : /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4025 : Implemented as
4026 : any(a)
4027 : {
4028 : forall (i=...)
4029 : if (a[i] != 0)
4030 : return 1
4031 : end forall
4032 : return 0
4033 : }
4034 : all(a)
4035 : {
4036 : forall (i=...)
4037 : if (a[i] == 0)
4038 : return 0
4039 : end forall
4040 : return 1
4041 : }
4042 : */
4043 : static void
4044 38563 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4045 : {
4046 38563 : tree resvar;
4047 38563 : stmtblock_t block;
4048 38563 : stmtblock_t body;
4049 38563 : tree type;
4050 38563 : tree tmp;
4051 38563 : tree found;
4052 38563 : gfc_loopinfo loop;
4053 38563 : gfc_actual_arglist *actual;
4054 38563 : gfc_ss *arrayss;
4055 38563 : gfc_se arrayse;
4056 38563 : tree exit_label;
4057 :
4058 38563 : if (se->ss)
4059 : {
4060 0 : gfc_conv_intrinsic_funcall (se, expr);
4061 0 : return;
4062 : }
4063 :
4064 38563 : actual = expr->value.function.actual;
4065 38563 : type = gfc_typenode_for_spec (&expr->ts);
4066 : /* Initialize the result. */
4067 38563 : resvar = gfc_create_var (type, "test");
4068 38563 : if (op == EQ_EXPR)
4069 420 : tmp = convert (type, boolean_true_node);
4070 : else
4071 38143 : tmp = convert (type, boolean_false_node);
4072 38563 : gfc_add_modify (&se->pre, resvar, tmp);
4073 :
4074 : /* Walk the arguments. */
4075 38563 : arrayss = gfc_walk_expr (actual->expr);
4076 38563 : gcc_assert (arrayss != gfc_ss_terminator);
4077 :
4078 : /* Initialize the scalarizer. */
4079 38563 : gfc_init_loopinfo (&loop);
4080 38563 : exit_label = gfc_build_label_decl (NULL_TREE);
4081 38563 : TREE_USED (exit_label) = 1;
4082 38563 : gfc_add_ss_to_loop (&loop, arrayss);
4083 :
4084 : /* Initialize the loop. */
4085 38563 : gfc_conv_ss_startstride (&loop);
4086 38563 : gfc_conv_loop_setup (&loop, &expr->where);
4087 :
4088 38563 : gfc_mark_ss_chain_used (arrayss, 1);
4089 : /* Generate the loop body. */
4090 38563 : gfc_start_scalarized_body (&loop, &body);
4091 :
4092 : /* If the condition matches then set the return value. */
4093 38563 : gfc_start_block (&block);
4094 38563 : if (op == EQ_EXPR)
4095 420 : tmp = convert (type, boolean_false_node);
4096 : else
4097 38143 : tmp = convert (type, boolean_true_node);
4098 38563 : gfc_add_modify (&block, resvar, tmp);
4099 :
4100 : /* And break out of the loop. */
4101 38563 : tmp = build1_v (GOTO_EXPR, exit_label);
4102 38563 : gfc_add_expr_to_block (&block, tmp);
4103 :
4104 38563 : found = gfc_finish_block (&block);
4105 :
4106 : /* Check this element. */
4107 38563 : gfc_init_se (&arrayse, NULL);
4108 38563 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4109 38563 : arrayse.ss = arrayss;
4110 38563 : gfc_conv_expr_val (&arrayse, actual->expr);
4111 :
4112 38563 : gfc_add_block_to_block (&body, &arrayse.pre);
4113 38563 : tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4114 38563 : build_int_cst (TREE_TYPE (arrayse.expr), 0));
4115 38563 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4116 38563 : gfc_add_expr_to_block (&body, tmp);
4117 38563 : gfc_add_block_to_block (&body, &arrayse.post);
4118 :
4119 38563 : gfc_trans_scalarizing_loops (&loop, &body);
4120 :
4121 : /* Add the exit label. */
4122 38563 : tmp = build1_v (LABEL_EXPR, exit_label);
4123 38563 : gfc_add_expr_to_block (&loop.pre, tmp);
4124 :
4125 38563 : gfc_add_block_to_block (&se->pre, &loop.pre);
4126 38563 : gfc_add_block_to_block (&se->pre, &loop.post);
4127 38563 : gfc_cleanup_loop (&loop);
4128 :
4129 38563 : se->expr = resvar;
4130 : }
4131 :
4132 :
4133 : /* Generate the constant 180 / pi, which is used in the conversion
4134 : of acosd(), asind(), atand(), atan2d(). */
4135 :
4136 : static tree
4137 408 : rad2deg (int kind)
4138 : {
4139 408 : tree retval;
4140 408 : mpfr_t pi, t0;
4141 :
4142 408 : gfc_set_model_kind (kind);
4143 408 : mpfr_init (pi);
4144 408 : mpfr_init (t0);
4145 408 : mpfr_set_si (t0, 180, GFC_RND_MODE);
4146 408 : mpfr_const_pi (pi, GFC_RND_MODE);
4147 408 : mpfr_div (t0, t0, pi, GFC_RND_MODE);
4148 408 : retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4149 408 : mpfr_clear (t0);
4150 408 : mpfr_clear (pi);
4151 408 : return retval;
4152 : }
4153 :
4154 :
4155 : static gfc_intrinsic_map_t *
4156 618 : gfc_lookup_intrinsic (gfc_isym_id id)
4157 : {
4158 618 : gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4159 11514 : for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4160 11514 : if (id == m->id)
4161 : break;
4162 618 : gcc_assert (id == m->id);
4163 618 : return m;
4164 : }
4165 :
4166 :
4167 : /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4168 : ASIND(x) is translated into ASIN(x) * 180 / pi.
4169 : ATAND(x) is translated into ATAN(x) * 180 / pi. */
4170 :
4171 : static void
4172 270 : gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4173 : {
4174 270 : tree arg;
4175 270 : tree atrigd;
4176 270 : tree type;
4177 270 : gfc_intrinsic_map_t *m;
4178 :
4179 270 : type = gfc_typenode_for_spec (&expr->ts);
4180 :
4181 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4182 :
4183 270 : switch (id)
4184 : {
4185 90 : case GFC_ISYM_ACOSD:
4186 90 : m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
4187 90 : break;
4188 90 : case GFC_ISYM_ASIND:
4189 90 : m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
4190 90 : break;
4191 90 : case GFC_ISYM_ATAND:
4192 90 : m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
4193 90 : break;
4194 0 : default:
4195 0 : gcc_unreachable ();
4196 : }
4197 270 : atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4198 270 : atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4199 :
4200 270 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4201 : fold_convert (type, rad2deg (expr->ts.kind)));
4202 270 : }
4203 :
4204 :
4205 : /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4206 : COS(X) / SIN(X) for COMPLEX argument. */
4207 :
4208 : static void
4209 102 : gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4210 : {
4211 102 : gfc_intrinsic_map_t *m;
4212 102 : tree arg;
4213 102 : tree type;
4214 :
4215 102 : type = gfc_typenode_for_spec (&expr->ts);
4216 102 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4217 :
4218 102 : if (expr->ts.type == BT_REAL)
4219 : {
4220 102 : tree tan;
4221 102 : tree tmp;
4222 102 : mpfr_t pio2;
4223 :
4224 : /* Create pi/2. */
4225 102 : gfc_set_model_kind (expr->ts.kind);
4226 102 : mpfr_init (pio2);
4227 102 : mpfr_const_pi (pio2, GFC_RND_MODE);
4228 102 : mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4229 102 : tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4230 102 : mpfr_clear (pio2);
4231 :
4232 : /* Find tan builtin function. */
4233 102 : m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
4234 102 : tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4235 102 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4236 102 : tan = build_call_expr_loc (input_location, tan, 1, tmp);
4237 102 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4238 : }
4239 : else
4240 : {
4241 0 : tree sin;
4242 0 : tree cos;
4243 :
4244 : /* Find cos builtin function. */
4245 0 : m = gfc_lookup_intrinsic (GFC_ISYM_COS);
4246 0 : cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4247 0 : cos = build_call_expr_loc (input_location, cos, 1, arg);
4248 :
4249 : /* Find sin builtin function. */
4250 0 : m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
4251 0 : sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4252 0 : sin = build_call_expr_loc (input_location, sin, 1, arg);
4253 :
4254 : /* Divide cos by sin. */
4255 0 : se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4256 : }
4257 102 : }
4258 :
4259 :
4260 : /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4261 :
4262 : static void
4263 108 : gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4264 : {
4265 108 : tree arg;
4266 108 : tree type;
4267 108 : tree ninety_tree;
4268 108 : mpfr_t ninety;
4269 :
4270 108 : type = gfc_typenode_for_spec (&expr->ts);
4271 108 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4272 :
4273 108 : gfc_set_model_kind (expr->ts.kind);
4274 :
4275 : /* Build the tree for x + 90. */
4276 108 : mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4277 108 : ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4278 108 : arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4279 108 : mpfr_clear (ninety);
4280 :
4281 : /* Find tand. */
4282 108 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
4283 108 : tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4284 108 : tand = build_call_expr_loc (input_location, tand, 1, arg);
4285 :
4286 108 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4287 108 : }
4288 :
4289 :
4290 : /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4291 :
4292 : static void
4293 138 : gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4294 : {
4295 138 : tree args[2];
4296 138 : tree atan2d;
4297 138 : tree type;
4298 :
4299 138 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
4300 138 : type = TREE_TYPE (args[0]);
4301 :
4302 138 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
4303 138 : atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4304 138 : atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4305 :
4306 138 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4307 : rad2deg (expr->ts.kind));
4308 138 : }
4309 :
4310 :
4311 : /* COUNT(A) = Number of true elements in A. */
4312 : static void
4313 143 : gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4314 : {
4315 143 : tree resvar;
4316 143 : tree type;
4317 143 : stmtblock_t body;
4318 143 : tree tmp;
4319 143 : gfc_loopinfo loop;
4320 143 : gfc_actual_arglist *actual;
4321 143 : gfc_ss *arrayss;
4322 143 : gfc_se arrayse;
4323 :
4324 143 : if (se->ss)
4325 : {
4326 0 : gfc_conv_intrinsic_funcall (se, expr);
4327 0 : return;
4328 : }
4329 :
4330 143 : actual = expr->value.function.actual;
4331 :
4332 143 : type = gfc_typenode_for_spec (&expr->ts);
4333 : /* Initialize the result. */
4334 143 : resvar = gfc_create_var (type, "count");
4335 143 : gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4336 :
4337 : /* Walk the arguments. */
4338 143 : arrayss = gfc_walk_expr (actual->expr);
4339 143 : gcc_assert (arrayss != gfc_ss_terminator);
4340 :
4341 : /* Initialize the scalarizer. */
4342 143 : gfc_init_loopinfo (&loop);
4343 143 : gfc_add_ss_to_loop (&loop, arrayss);
4344 :
4345 : /* Initialize the loop. */
4346 143 : gfc_conv_ss_startstride (&loop);
4347 143 : gfc_conv_loop_setup (&loop, &expr->where);
4348 :
4349 143 : gfc_mark_ss_chain_used (arrayss, 1);
4350 : /* Generate the loop body. */
4351 143 : gfc_start_scalarized_body (&loop, &body);
4352 :
4353 143 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4354 143 : resvar, build_int_cst (TREE_TYPE (resvar), 1));
4355 143 : tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4356 :
4357 143 : gfc_init_se (&arrayse, NULL);
4358 143 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4359 143 : arrayse.ss = arrayss;
4360 143 : gfc_conv_expr_val (&arrayse, actual->expr);
4361 143 : tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4362 : build_empty_stmt (input_location));
4363 :
4364 143 : gfc_add_block_to_block (&body, &arrayse.pre);
4365 143 : gfc_add_expr_to_block (&body, tmp);
4366 143 : gfc_add_block_to_block (&body, &arrayse.post);
4367 :
4368 143 : gfc_trans_scalarizing_loops (&loop, &body);
4369 :
4370 143 : gfc_add_block_to_block (&se->pre, &loop.pre);
4371 143 : gfc_add_block_to_block (&se->pre, &loop.post);
4372 143 : gfc_cleanup_loop (&loop);
4373 :
4374 143 : se->expr = resvar;
4375 : }
4376 :
4377 :
4378 : /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4379 : struct and return the corresponding loopinfo. */
4380 :
4381 : static gfc_loopinfo *
4382 3374 : enter_nested_loop (gfc_se *se)
4383 : {
4384 3374 : se->ss = se->ss->nested_ss;
4385 3374 : gcc_assert (se->ss == se->ss->loop->ss);
4386 :
4387 3374 : return se->ss->loop;
4388 : }
4389 :
4390 : /* Build the condition for a mask, which may be optional. */
4391 :
4392 : static tree
4393 12763 : conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4394 : bool optional_mask)
4395 : {
4396 12763 : tree present;
4397 12763 : tree type;
4398 :
4399 12763 : if (optional_mask)
4400 : {
4401 206 : type = TREE_TYPE (maskse->expr);
4402 206 : present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4403 206 : present = convert (type, present);
4404 206 : present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4405 : present);
4406 206 : return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4407 206 : type, present, maskse->expr);
4408 : }
4409 : else
4410 12557 : return maskse->expr;
4411 : }
4412 :
4413 : /* Inline implementation of the sum and product intrinsics. */
4414 : static void
4415 2515 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4416 : bool norm2)
4417 : {
4418 2515 : tree resvar;
4419 2515 : tree scale = NULL_TREE;
4420 2515 : tree type;
4421 2515 : stmtblock_t body;
4422 2515 : stmtblock_t block;
4423 2515 : tree tmp;
4424 2515 : gfc_loopinfo loop, *ploop;
4425 2515 : gfc_actual_arglist *arg_array, *arg_mask;
4426 2515 : gfc_ss *arrayss = NULL;
4427 2515 : gfc_ss *maskss = NULL;
4428 2515 : gfc_se arrayse;
4429 2515 : gfc_se maskse;
4430 2515 : gfc_se *parent_se;
4431 2515 : gfc_expr *arrayexpr;
4432 2515 : gfc_expr *maskexpr;
4433 2515 : bool optional_mask;
4434 :
4435 2515 : if (expr->rank > 0)
4436 : {
4437 578 : gcc_assert (gfc_inline_intrinsic_function_p (expr));
4438 : parent_se = se;
4439 : }
4440 : else
4441 : parent_se = NULL;
4442 :
4443 2515 : type = gfc_typenode_for_spec (&expr->ts);
4444 : /* Initialize the result. */
4445 2515 : resvar = gfc_create_var (type, "val");
4446 2515 : if (norm2)
4447 : {
4448 : /* result = 0.0;
4449 : scale = 1.0. */
4450 68 : scale = gfc_create_var (type, "scale");
4451 68 : gfc_add_modify (&se->pre, scale,
4452 : gfc_build_const (type, integer_one_node));
4453 68 : tmp = gfc_build_const (type, integer_zero_node);
4454 : }
4455 2447 : else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4456 2029 : tmp = gfc_build_const (type, integer_zero_node);
4457 418 : else if (op == NE_EXPR)
4458 : /* PARITY. */
4459 36 : tmp = convert (type, boolean_false_node);
4460 382 : else if (op == BIT_AND_EXPR)
4461 24 : tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4462 : type, integer_one_node));
4463 : else
4464 358 : tmp = gfc_build_const (type, integer_one_node);
4465 :
4466 2515 : gfc_add_modify (&se->pre, resvar, tmp);
4467 :
4468 2515 : arg_array = expr->value.function.actual;
4469 :
4470 2515 : arrayexpr = arg_array->expr;
4471 :
4472 2515 : if (op == NE_EXPR || norm2)
4473 : {
4474 : /* PARITY and NORM2. */
4475 : maskexpr = NULL;
4476 : optional_mask = false;
4477 : }
4478 : else
4479 : {
4480 2411 : arg_mask = arg_array->next->next;
4481 2411 : gcc_assert (arg_mask != NULL);
4482 2411 : maskexpr = arg_mask->expr;
4483 371 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4484 266 : && maskexpr->symtree->n.sym->attr.dummy
4485 2429 : && maskexpr->symtree->n.sym->attr.optional;
4486 : }
4487 :
4488 2515 : if (expr->rank == 0)
4489 : {
4490 : /* Walk the arguments. */
4491 1937 : arrayss = gfc_walk_expr (arrayexpr);
4492 1937 : gcc_assert (arrayss != gfc_ss_terminator);
4493 :
4494 1937 : if (maskexpr && maskexpr->rank > 0)
4495 : {
4496 223 : maskss = gfc_walk_expr (maskexpr);
4497 223 : gcc_assert (maskss != gfc_ss_terminator);
4498 : }
4499 : else
4500 : maskss = NULL;
4501 :
4502 : /* Initialize the scalarizer. */
4503 1937 : gfc_init_loopinfo (&loop);
4504 :
4505 : /* We add the mask first because the number of iterations is
4506 : taken from the last ss, and this breaks if an absent
4507 : optional argument is used for mask. */
4508 :
4509 1937 : if (maskexpr && maskexpr->rank > 0)
4510 223 : gfc_add_ss_to_loop (&loop, maskss);
4511 1937 : gfc_add_ss_to_loop (&loop, arrayss);
4512 :
4513 : /* Initialize the loop. */
4514 1937 : gfc_conv_ss_startstride (&loop);
4515 1937 : gfc_conv_loop_setup (&loop, &expr->where);
4516 :
4517 1937 : if (maskexpr && maskexpr->rank > 0)
4518 223 : gfc_mark_ss_chain_used (maskss, 1);
4519 1937 : gfc_mark_ss_chain_used (arrayss, 1);
4520 :
4521 1937 : ploop = &loop;
4522 : }
4523 : else
4524 : /* All the work has been done in the parent loops. */
4525 578 : ploop = enter_nested_loop (se);
4526 :
4527 2515 : gcc_assert (ploop);
4528 :
4529 : /* Generate the loop body. */
4530 2515 : gfc_start_scalarized_body (ploop, &body);
4531 :
4532 : /* If we have a mask, only add this element if the mask is set. */
4533 2515 : if (maskexpr && maskexpr->rank > 0)
4534 : {
4535 307 : gfc_init_se (&maskse, parent_se);
4536 307 : gfc_copy_loopinfo_to_se (&maskse, ploop);
4537 307 : if (expr->rank == 0)
4538 223 : maskse.ss = maskss;
4539 307 : gfc_conv_expr_val (&maskse, maskexpr);
4540 307 : gfc_add_block_to_block (&body, &maskse.pre);
4541 :
4542 307 : gfc_start_block (&block);
4543 : }
4544 : else
4545 2208 : gfc_init_block (&block);
4546 :
4547 : /* Do the actual summation/product. */
4548 2515 : gfc_init_se (&arrayse, parent_se);
4549 2515 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
4550 2515 : if (expr->rank == 0)
4551 1937 : arrayse.ss = arrayss;
4552 2515 : gfc_conv_expr_val (&arrayse, arrayexpr);
4553 2515 : gfc_add_block_to_block (&block, &arrayse.pre);
4554 :
4555 2515 : if (norm2)
4556 : {
4557 : /* if (x (i) != 0.0)
4558 : {
4559 : absX = abs(x(i))
4560 : if (absX > scale)
4561 : {
4562 : val = scale/absX;
4563 : result = 1.0 + result * val * val;
4564 : scale = absX;
4565 : }
4566 : else
4567 : {
4568 : val = absX/scale;
4569 : result += val * val;
4570 : }
4571 : } */
4572 68 : tree res1, res2, cond, absX, val;
4573 68 : stmtblock_t ifblock1, ifblock2, ifblock3;
4574 :
4575 68 : gfc_init_block (&ifblock1);
4576 :
4577 68 : absX = gfc_create_var (type, "absX");
4578 68 : gfc_add_modify (&ifblock1, absX,
4579 : fold_build1_loc (input_location, ABS_EXPR, type,
4580 : arrayse.expr));
4581 68 : val = gfc_create_var (type, "val");
4582 68 : gfc_add_expr_to_block (&ifblock1, val);
4583 :
4584 68 : gfc_init_block (&ifblock2);
4585 68 : gfc_add_modify (&ifblock2, val,
4586 : fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4587 : absX));
4588 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4589 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4590 68 : res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4591 : gfc_build_const (type, integer_one_node));
4592 68 : gfc_add_modify (&ifblock2, resvar, res1);
4593 68 : gfc_add_modify (&ifblock2, scale, absX);
4594 68 : res1 = gfc_finish_block (&ifblock2);
4595 :
4596 68 : gfc_init_block (&ifblock3);
4597 68 : gfc_add_modify (&ifblock3, val,
4598 : fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4599 : scale));
4600 68 : res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4601 68 : res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4602 68 : gfc_add_modify (&ifblock3, resvar, res2);
4603 68 : res2 = gfc_finish_block (&ifblock3);
4604 :
4605 68 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4606 : absX, scale);
4607 68 : tmp = build3_v (COND_EXPR, cond, res1, res2);
4608 68 : gfc_add_expr_to_block (&ifblock1, tmp);
4609 68 : tmp = gfc_finish_block (&ifblock1);
4610 :
4611 68 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4612 : arrayse.expr,
4613 : gfc_build_const (type, integer_zero_node));
4614 :
4615 68 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4616 68 : gfc_add_expr_to_block (&block, tmp);
4617 : }
4618 : else
4619 : {
4620 2447 : tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4621 2447 : gfc_add_modify (&block, resvar, tmp);
4622 : }
4623 :
4624 2515 : gfc_add_block_to_block (&block, &arrayse.post);
4625 :
4626 2515 : if (maskexpr && maskexpr->rank > 0)
4627 : {
4628 : /* We enclose the above in if (mask) {...} . If the mask is an
4629 : optional argument, generate
4630 : IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4631 307 : tree ifmask;
4632 307 : tmp = gfc_finish_block (&block);
4633 307 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4634 307 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4635 : build_empty_stmt (input_location));
4636 307 : }
4637 : else
4638 2208 : tmp = gfc_finish_block (&block);
4639 2515 : gfc_add_expr_to_block (&body, tmp);
4640 :
4641 2515 : gfc_trans_scalarizing_loops (ploop, &body);
4642 :
4643 : /* For a scalar mask, enclose the loop in an if statement. */
4644 2515 : if (maskexpr && maskexpr->rank == 0)
4645 : {
4646 64 : gfc_init_block (&block);
4647 64 : gfc_add_block_to_block (&block, &ploop->pre);
4648 64 : gfc_add_block_to_block (&block, &ploop->post);
4649 64 : tmp = gfc_finish_block (&block);
4650 :
4651 64 : if (expr->rank > 0)
4652 : {
4653 34 : tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4654 : build_empty_stmt (input_location));
4655 34 : gfc_advance_se_ss_chain (se);
4656 : }
4657 : else
4658 : {
4659 30 : tree ifmask;
4660 :
4661 30 : gcc_assert (expr->rank == 0);
4662 30 : gfc_init_se (&maskse, NULL);
4663 30 : gfc_conv_expr_val (&maskse, maskexpr);
4664 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4665 30 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4666 : build_empty_stmt (input_location));
4667 : }
4668 :
4669 64 : gfc_add_expr_to_block (&block, tmp);
4670 64 : gfc_add_block_to_block (&se->pre, &block);
4671 64 : gcc_assert (se->post.head == NULL);
4672 : }
4673 : else
4674 : {
4675 2451 : gfc_add_block_to_block (&se->pre, &ploop->pre);
4676 2451 : gfc_add_block_to_block (&se->pre, &ploop->post);
4677 : }
4678 :
4679 2515 : if (expr->rank == 0)
4680 1937 : gfc_cleanup_loop (ploop);
4681 :
4682 2515 : if (norm2)
4683 : {
4684 : /* result = scale * sqrt(result). */
4685 68 : tree sqrt;
4686 68 : sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4687 68 : resvar = build_call_expr_loc (input_location,
4688 : sqrt, 1, resvar);
4689 68 : resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4690 : }
4691 :
4692 2515 : se->expr = resvar;
4693 2515 : }
4694 :
4695 :
4696 : /* Inline implementation of the dot_product intrinsic. This function
4697 : is based on gfc_conv_intrinsic_arith (the previous function). */
4698 : static void
4699 113 : gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4700 : {
4701 113 : tree resvar;
4702 113 : tree type;
4703 113 : stmtblock_t body;
4704 113 : stmtblock_t block;
4705 113 : tree tmp;
4706 113 : gfc_loopinfo loop;
4707 113 : gfc_actual_arglist *actual;
4708 113 : gfc_ss *arrayss1, *arrayss2;
4709 113 : gfc_se arrayse1, arrayse2;
4710 113 : gfc_expr *arrayexpr1, *arrayexpr2;
4711 :
4712 113 : type = gfc_typenode_for_spec (&expr->ts);
4713 :
4714 : /* Initialize the result. */
4715 113 : resvar = gfc_create_var (type, "val");
4716 113 : if (expr->ts.type == BT_LOGICAL)
4717 30 : tmp = build_int_cst (type, 0);
4718 : else
4719 83 : tmp = gfc_build_const (type, integer_zero_node);
4720 :
4721 113 : gfc_add_modify (&se->pre, resvar, tmp);
4722 :
4723 : /* Walk argument #1. */
4724 113 : actual = expr->value.function.actual;
4725 113 : arrayexpr1 = actual->expr;
4726 113 : arrayss1 = gfc_walk_expr (arrayexpr1);
4727 113 : gcc_assert (arrayss1 != gfc_ss_terminator);
4728 :
4729 : /* Walk argument #2. */
4730 113 : actual = actual->next;
4731 113 : arrayexpr2 = actual->expr;
4732 113 : arrayss2 = gfc_walk_expr (arrayexpr2);
4733 113 : gcc_assert (arrayss2 != gfc_ss_terminator);
4734 :
4735 : /* Initialize the scalarizer. */
4736 113 : gfc_init_loopinfo (&loop);
4737 113 : gfc_add_ss_to_loop (&loop, arrayss1);
4738 113 : gfc_add_ss_to_loop (&loop, arrayss2);
4739 :
4740 : /* Initialize the loop. */
4741 113 : gfc_conv_ss_startstride (&loop);
4742 113 : gfc_conv_loop_setup (&loop, &expr->where);
4743 :
4744 113 : gfc_mark_ss_chain_used (arrayss1, 1);
4745 113 : gfc_mark_ss_chain_used (arrayss2, 1);
4746 :
4747 : /* Generate the loop body. */
4748 113 : gfc_start_scalarized_body (&loop, &body);
4749 113 : gfc_init_block (&block);
4750 :
4751 : /* Make the tree expression for [conjg(]array1[)]. */
4752 113 : gfc_init_se (&arrayse1, NULL);
4753 113 : gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4754 113 : arrayse1.ss = arrayss1;
4755 113 : gfc_conv_expr_val (&arrayse1, arrayexpr1);
4756 113 : if (expr->ts.type == BT_COMPLEX)
4757 9 : arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4758 : arrayse1.expr);
4759 113 : gfc_add_block_to_block (&block, &arrayse1.pre);
4760 :
4761 : /* Make the tree expression for array2. */
4762 113 : gfc_init_se (&arrayse2, NULL);
4763 113 : gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4764 113 : arrayse2.ss = arrayss2;
4765 113 : gfc_conv_expr_val (&arrayse2, arrayexpr2);
4766 113 : gfc_add_block_to_block (&block, &arrayse2.pre);
4767 :
4768 : /* Do the actual product and sum. */
4769 113 : if (expr->ts.type == BT_LOGICAL)
4770 : {
4771 30 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4772 : arrayse1.expr, arrayse2.expr);
4773 30 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4774 : }
4775 : else
4776 : {
4777 83 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4778 : arrayse2.expr);
4779 83 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4780 : }
4781 113 : gfc_add_modify (&block, resvar, tmp);
4782 :
4783 : /* Finish up the loop block and the loop. */
4784 113 : tmp = gfc_finish_block (&block);
4785 113 : gfc_add_expr_to_block (&body, tmp);
4786 :
4787 113 : gfc_trans_scalarizing_loops (&loop, &body);
4788 113 : gfc_add_block_to_block (&se->pre, &loop.pre);
4789 113 : gfc_add_block_to_block (&se->pre, &loop.post);
4790 113 : gfc_cleanup_loop (&loop);
4791 :
4792 113 : se->expr = resvar;
4793 113 : }
4794 :
4795 :
4796 : /* Tells whether the expression E is a reference to an optional variable whose
4797 : presence is not known at compile time. Those are variable references without
4798 : subreference; if there is a subreference, we can assume the variable is
4799 : present. We have to special case full arrays, which we represent with a fake
4800 : "full" reference, and class descriptors for which a reference to data is not
4801 : really a subreference. */
4802 :
4803 : bool
4804 14613 : maybe_absent_optional_variable (gfc_expr *e)
4805 : {
4806 14613 : if (!(e && e->expr_type == EXPR_VARIABLE))
4807 : return false;
4808 :
4809 1716 : gfc_symbol *sym = e->symtree->n.sym;
4810 1716 : if (!sym->attr.optional)
4811 : return false;
4812 :
4813 224 : gfc_ref *ref = e->ref;
4814 224 : if (ref == nullptr)
4815 : return true;
4816 :
4817 20 : if (ref->type == REF_ARRAY
4818 20 : && ref->u.ar.type == AR_FULL
4819 20 : && ref->next == nullptr)
4820 : return true;
4821 :
4822 0 : if (!(sym->ts.type == BT_CLASS
4823 0 : && ref->type == REF_COMPONENT
4824 0 : && ref->u.c.component == CLASS_DATA (sym)))
4825 : return false;
4826 :
4827 0 : gfc_ref *next_ref = ref->next;
4828 0 : if (next_ref == nullptr)
4829 : return true;
4830 :
4831 0 : if (next_ref->type == REF_ARRAY
4832 0 : && next_ref->u.ar.type == AR_FULL
4833 0 : && next_ref->next == nullptr)
4834 0 : return true;
4835 :
4836 : return false;
4837 : }
4838 :
4839 :
4840 : /* Emit code for minloc or maxloc intrinsic. There are many different cases
4841 : we need to handle. For performance reasons we sometimes create two
4842 : loops instead of one, where the second one is much simpler.
4843 : Examples for minloc intrinsic:
4844 : A: Result is scalar.
4845 : 1) Array mask is used and NaNs need to be supported:
4846 : limit = Infinity;
4847 : pos = 0;
4848 : S = from;
4849 : while (S <= to) {
4850 : if (mask[S]) {
4851 : if (pos == 0) pos = S + (1 - from);
4852 : if (a[S] <= limit) {
4853 : limit = a[S];
4854 : pos = S + (1 - from);
4855 : goto lab1;
4856 : }
4857 : }
4858 : S++;
4859 : }
4860 : goto lab2;
4861 : lab1:;
4862 : while (S <= to) {
4863 : if (mask[S])
4864 : if (a[S] < limit) {
4865 : limit = a[S];
4866 : pos = S + (1 - from);
4867 : }
4868 : S++;
4869 : }
4870 : lab2:;
4871 : 2) NaNs need to be supported, but it is known at compile time or cheaply
4872 : at runtime whether array is nonempty or not:
4873 : limit = Infinity;
4874 : pos = 0;
4875 : S = from;
4876 : while (S <= to) {
4877 : if (a[S] <= limit) {
4878 : limit = a[S];
4879 : pos = S + (1 - from);
4880 : goto lab1;
4881 : }
4882 : S++;
4883 : }
4884 : if (from <= to) pos = 1;
4885 : goto lab2;
4886 : lab1:;
4887 : while (S <= to) {
4888 : if (a[S] < limit) {
4889 : limit = a[S];
4890 : pos = S + (1 - from);
4891 : }
4892 : S++;
4893 : }
4894 : lab2:;
4895 : 3) NaNs aren't supported, array mask is used:
4896 : limit = infinities_supported ? Infinity : huge (limit);
4897 : pos = 0;
4898 : S = from;
4899 : while (S <= to) {
4900 : if (mask[S]) {
4901 : limit = a[S];
4902 : pos = S + (1 - from);
4903 : goto lab1;
4904 : }
4905 : S++;
4906 : }
4907 : goto lab2;
4908 : lab1:;
4909 : while (S <= to) {
4910 : if (mask[S])
4911 : if (a[S] < limit) {
4912 : limit = a[S];
4913 : pos = S + (1 - from);
4914 : }
4915 : S++;
4916 : }
4917 : lab2:;
4918 : 4) Same without array mask:
4919 : limit = infinities_supported ? Infinity : huge (limit);
4920 : pos = (from <= to) ? 1 : 0;
4921 : S = from;
4922 : while (S <= to) {
4923 : if (a[S] < limit) {
4924 : limit = a[S];
4925 : pos = S + (1 - from);
4926 : }
4927 : S++;
4928 : }
4929 : B: Array result, non-CHARACTER type, DIM absent
4930 : Generate similar code as in the scalar case, using a collection of
4931 : variables (one per dimension) instead of a single variable as result.
4932 : Picking only cases 1) and 4) with ARRAY of rank 2, the generated code
4933 : becomes:
4934 : 1) Array mask is used and NaNs need to be supported:
4935 : limit = Infinity;
4936 : pos0 = 0;
4937 : pos1 = 0;
4938 : S1 = from1;
4939 : second_loop_entry = false;
4940 : while (S1 <= to1) {
4941 : S0 = from0;
4942 : while (s0 <= to0 {
4943 : if (mask[S1][S0]) {
4944 : if (pos0 == 0) {
4945 : pos0 = S0 + (1 - from0);
4946 : pos1 = S1 + (1 - from1);
4947 : }
4948 : if (a[S1][S0] <= limit) {
4949 : limit = a[S1][S0];
4950 : pos0 = S0 + (1 - from0);
4951 : pos1 = S1 + (1 - from1);
4952 : second_loop_entry = true;
4953 : goto lab1;
4954 : }
4955 : }
4956 : S0++;
4957 : }
4958 : S1++;
4959 : }
4960 : goto lab2;
4961 : lab1:;
4962 : S1 = second_loop_entry ? S1 : from1;
4963 : while (S1 <= to1) {
4964 : S0 = second_loop_entry ? S0 : from0;
4965 : while (S0 <= to0) {
4966 : if (mask[S1][S0])
4967 : if (a[S1][S0] < limit) {
4968 : limit = a[S1][S0];
4969 : pos0 = S + (1 - from0);
4970 : pos1 = S + (1 - from1);
4971 : }
4972 : second_loop_entry = false;
4973 : S0++;
4974 : }
4975 : S1++;
4976 : }
4977 : lab2:;
4978 : result = { pos0, pos1 };
4979 : ...
4980 : 4) NANs aren't supported, no array mask.
4981 : limit = infinities_supported ? Infinity : huge (limit);
4982 : pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4983 : pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
4984 : S1 = from1;
4985 : while (S1 <= to1) {
4986 : S0 = from0;
4987 : while (S0 <= to0) {
4988 : if (a[S1][S0] < limit) {
4989 : limit = a[S1][S0];
4990 : pos0 = S + (1 - from0);
4991 : pos1 = S + (1 - from1);
4992 : }
4993 : S0++;
4994 : }
4995 : S1++;
4996 : }
4997 : result = { pos0, pos1 };
4998 : C: Otherwise, a call is generated.
4999 : For 2) and 4), if mask is scalar, this all goes into a conditional,
5000 : setting pos = 0; in the else branch.
5001 :
5002 : Since we now also support the BACK argument, instead of using
5003 : if (a[S] < limit), we now use
5004 :
5005 : if (back)
5006 : cond = a[S] <= limit;
5007 : else
5008 : cond = a[S] < limit;
5009 : if (cond) {
5010 : ....
5011 :
5012 : The optimizer is smart enough to move the condition out of the loop.
5013 : They are now marked as unlikely too for further speedup. */
5014 :
5015 : static void
5016 18898 : gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5017 : {
5018 18898 : stmtblock_t body;
5019 18898 : stmtblock_t block;
5020 18898 : stmtblock_t ifblock;
5021 18898 : stmtblock_t elseblock;
5022 18898 : tree limit;
5023 18898 : tree type;
5024 18898 : tree tmp;
5025 18898 : tree cond;
5026 18898 : tree elsetmp;
5027 18898 : tree ifbody;
5028 18898 : tree offset[GFC_MAX_DIMENSIONS];
5029 18898 : tree nonempty;
5030 18898 : tree lab1, lab2;
5031 18898 : tree b_if, b_else;
5032 18898 : tree back;
5033 18898 : gfc_loopinfo loop, *ploop;
5034 18898 : gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg;
5035 18898 : gfc_actual_arglist *back_arg;
5036 18898 : gfc_ss *arrayss = nullptr;
5037 18898 : gfc_ss *maskss = nullptr;
5038 18898 : gfc_ss *orig_ss = nullptr;
5039 18898 : gfc_se arrayse;
5040 18898 : gfc_se maskse;
5041 18898 : gfc_se nested_se;
5042 18898 : gfc_se *base_se;
5043 18898 : gfc_expr *arrayexpr;
5044 18898 : gfc_expr *maskexpr;
5045 18898 : gfc_expr *backexpr;
5046 18898 : gfc_se backse;
5047 18898 : tree pos[GFC_MAX_DIMENSIONS];
5048 18898 : tree idx[GFC_MAX_DIMENSIONS];
5049 18898 : tree result_var = NULL_TREE;
5050 18898 : int n;
5051 18898 : bool optional_mask;
5052 :
5053 18898 : array_arg = expr->value.function.actual;
5054 18898 : dim_arg = array_arg->next;
5055 18898 : mask_arg = dim_arg->next;
5056 18898 : kind_arg = mask_arg->next;
5057 18898 : back_arg = kind_arg->next;
5058 :
5059 18898 : bool dim_present = dim_arg->expr != nullptr;
5060 18898 : bool nested_loop = dim_present && expr->rank > 0;
5061 :
5062 : /* Remove kind. */
5063 18898 : if (kind_arg->expr)
5064 : {
5065 2240 : gfc_free_expr (kind_arg->expr);
5066 2240 : kind_arg->expr = NULL;
5067 : }
5068 :
5069 : /* Pass BACK argument by value. */
5070 18898 : back_arg->name = "%VAL";
5071 :
5072 18898 : if (se->ss)
5073 : {
5074 14732 : if (se->ss->info->useflags)
5075 : {
5076 7671 : if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
5077 : {
5078 : /* The code generating and initializing the result array has been
5079 : generated already before the scalarization loop, either with a
5080 : library function call or with inline code; now we can just use
5081 : the result. */
5082 4875 : gfc_conv_tmp_array_ref (se);
5083 13822 : return;
5084 : }
5085 : }
5086 7061 : else if (!gfc_inline_intrinsic_function_p (expr))
5087 : {
5088 3780 : gfc_conv_intrinsic_funcall (se, expr);
5089 3780 : return;
5090 : }
5091 : }
5092 :
5093 10243 : arrayexpr = array_arg->expr;
5094 :
5095 : /* Special case for character maxloc. Remove unneeded "dim" actual
5096 : argument, then call a library function. */
5097 :
5098 10243 : if (arrayexpr->ts.type == BT_CHARACTER)
5099 : {
5100 292 : gcc_assert (expr->rank == 0);
5101 :
5102 292 : if (dim_arg->expr)
5103 : {
5104 292 : gfc_free_expr (dim_arg->expr);
5105 292 : dim_arg->expr = NULL;
5106 : }
5107 292 : gfc_conv_intrinsic_funcall (se, expr);
5108 292 : return;
5109 : }
5110 :
5111 9951 : type = gfc_typenode_for_spec (&expr->ts);
5112 :
5113 9951 : if (expr->rank > 0 && !dim_present)
5114 : {
5115 3281 : gfc_array_spec as;
5116 3281 : memset (&as, 0, sizeof (as));
5117 :
5118 3281 : as.rank = 1;
5119 3281 : as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5120 : &arrayexpr->where,
5121 : HOST_WIDE_INT_1);
5122 6562 : as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind,
5123 : &arrayexpr->where,
5124 3281 : arrayexpr->rank);
5125 :
5126 3281 : tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
5127 :
5128 3281 : result_var = gfc_create_var (array, "loc_result");
5129 : }
5130 :
5131 7155 : const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
5132 :
5133 : /* Initialize the result. */
5134 22177 : for (int i = 0; i < reduction_dimensions; i++)
5135 : {
5136 12226 : pos[i] = gfc_create_var (gfc_array_index_type,
5137 : gfc_get_string ("pos%d", i));
5138 12226 : offset[i] = gfc_create_var (gfc_array_index_type,
5139 : gfc_get_string ("offset%d", i));
5140 12226 : idx[i] = gfc_create_var (gfc_array_index_type,
5141 : gfc_get_string ("idx%d", i));
5142 : }
5143 :
5144 9951 : maskexpr = mask_arg->expr;
5145 6518 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5146 5329 : && maskexpr->symtree->n.sym->attr.dummy
5147 10116 : && maskexpr->symtree->n.sym->attr.optional;
5148 9951 : backexpr = back_arg->expr;
5149 :
5150 17106 : gfc_init_se (&backse, nested_loop ? se : nullptr);
5151 9951 : if (backexpr == nullptr)
5152 0 : back = logical_false_node;
5153 9951 : else if (maybe_absent_optional_variable (backexpr))
5154 : {
5155 : /* This should have been checked already by
5156 : maybe_absent_optional_variable. */
5157 184 : gcc_checking_assert (backexpr->expr_type == EXPR_VARIABLE);
5158 :
5159 184 : gfc_conv_expr (&backse, backexpr);
5160 184 : tree present = gfc_conv_expr_present (backexpr->symtree->n.sym, false);
5161 184 : back = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5162 : logical_type_node, present, backse.expr);
5163 : }
5164 : else
5165 : {
5166 9767 : gfc_conv_expr (&backse, backexpr);
5167 9767 : back = backse.expr;
5168 : }
5169 9951 : gfc_add_block_to_block (&se->pre, &backse.pre);
5170 9951 : back = gfc_evaluate_now_loc (input_location, back, &se->pre);
5171 9951 : gfc_add_block_to_block (&se->pre, &backse.post);
5172 :
5173 9951 : if (nested_loop)
5174 : {
5175 2796 : gfc_init_se (&nested_se, se);
5176 2796 : base_se = &nested_se;
5177 : }
5178 : else
5179 : {
5180 : /* Walk the arguments. */
5181 7155 : arrayss = gfc_walk_expr (arrayexpr);
5182 7155 : gcc_assert (arrayss != gfc_ss_terminator);
5183 :
5184 7155 : if (maskexpr && maskexpr->rank != 0)
5185 : {
5186 2700 : maskss = gfc_walk_expr (maskexpr);
5187 2700 : gcc_assert (maskss != gfc_ss_terminator);
5188 : }
5189 :
5190 : base_se = nullptr;
5191 : }
5192 :
5193 18091 : nonempty = nullptr;
5194 7448 : if (!(maskexpr && maskexpr->rank > 0))
5195 : {
5196 6077 : mpz_t asize;
5197 6077 : bool reduction_size_known;
5198 :
5199 6077 : if (dim_present)
5200 : {
5201 4032 : int reduction_dim;
5202 4032 : if (dim_arg->expr->expr_type == EXPR_CONSTANT)
5203 4030 : reduction_dim = mpz_get_si (dim_arg->expr->value.integer) - 1;
5204 2 : else if (arrayexpr->rank == 1)
5205 : reduction_dim = 0;
5206 : else
5207 0 : gcc_unreachable ();
5208 4032 : reduction_size_known = gfc_array_dimen_size (arrayexpr, reduction_dim,
5209 : &asize);
5210 : }
5211 : else
5212 2045 : reduction_size_known = gfc_array_size (arrayexpr, &asize);
5213 :
5214 6077 : if (reduction_size_known)
5215 : {
5216 4482 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5217 4482 : mpz_clear (asize);
5218 4482 : nonempty = fold_build2_loc (input_location, GT_EXPR,
5219 : logical_type_node, nonempty,
5220 : gfc_index_zero_node);
5221 : }
5222 6077 : maskss = NULL;
5223 : }
5224 :
5225 9951 : limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5226 9951 : switch (arrayexpr->ts.type)
5227 : {
5228 3898 : case BT_REAL:
5229 3898 : tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5230 3898 : break;
5231 :
5232 6029 : case BT_INTEGER:
5233 6029 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5234 6029 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5235 : arrayexpr->ts.kind);
5236 6029 : break;
5237 :
5238 24 : case BT_UNSIGNED:
5239 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
5240 24 : if (op == GT_EXPR)
5241 : {
5242 12 : tmp = gfc_get_unsigned_type (arrayexpr->ts.kind);
5243 12 : tmp = build_int_cst (tmp, 0);
5244 : }
5245 : else
5246 : {
5247 12 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5248 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
5249 : expr->ts.kind);
5250 : }
5251 : break;
5252 :
5253 0 : default:
5254 0 : gcc_unreachable ();
5255 : }
5256 :
5257 : /* We start with the most negative possible value for MAXLOC, and the most
5258 : positive possible value for MINLOC. The most negative possible value is
5259 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5260 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
5261 : with above. */
5262 9951 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
5263 4724 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5264 4724 : if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5265 2914 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5266 2914 : build_int_cst (TREE_TYPE (tmp), 1));
5267 :
5268 9951 : gfc_add_modify (&se->pre, limit, tmp);
5269 :
5270 : /* If we are in a case where we generate two sets of loops, the second one
5271 : should continue where the first stopped instead of restarting from the
5272 : beginning. So nested loops in the second set should have a partial range
5273 : on the first iteration, but they should start from the beginning and span
5274 : their full range on the following iterations. So we use conditionals in
5275 : the loops lower bounds, and use the following variable in those
5276 : conditionals to decide whether to use the original loop bound or to use
5277 : the index at which the loop from the first set stopped. */
5278 9951 : tree second_loop_entry = gfc_create_var (logical_type_node,
5279 : "second_loop_entry");
5280 9951 : gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
5281 :
5282 9951 : if (nested_loop)
5283 : {
5284 2796 : ploop = enter_nested_loop (&nested_se);
5285 2796 : orig_ss = nested_se.ss;
5286 2796 : ploop->temp_dim = 1;
5287 : }
5288 : else
5289 : {
5290 : /* Initialize the scalarizer. */
5291 7155 : gfc_init_loopinfo (&loop);
5292 :
5293 : /* We add the mask first because the number of iterations is taken
5294 : from the last ss, and this breaks if an absent optional argument
5295 : is used for mask. */
5296 :
5297 7155 : if (maskss)
5298 2700 : gfc_add_ss_to_loop (&loop, maskss);
5299 :
5300 7155 : gfc_add_ss_to_loop (&loop, arrayss);
5301 :
5302 : /* Initialize the loop. */
5303 7155 : gfc_conv_ss_startstride (&loop);
5304 :
5305 : /* The code generated can have more than one loop in sequence (see the
5306 : comment at the function header). This doesn't work well with the
5307 : scalarizer, which changes arrays' offset when the scalarization loops
5308 : are generated (see gfc_trans_preloop_setup). Fortunately, we can use
5309 : the scalarizer temporary code to handle multiple loops. Thus, we set
5310 : temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
5311 : we use gfc_trans_scalarized_loop_boundary even later to restore
5312 : offset. */
5313 7155 : loop.temp_dim = loop.dimen;
5314 7155 : gfc_conv_loop_setup (&loop, &expr->where);
5315 :
5316 7155 : ploop = &loop;
5317 : }
5318 :
5319 9951 : gcc_assert (reduction_dimensions == ploop->dimen);
5320 :
5321 9951 : if (nonempty == NULL && !(maskexpr && maskexpr->rank > 0))
5322 : {
5323 1595 : nonempty = logical_true_node;
5324 :
5325 3697 : for (int i = 0; i < ploop->dimen; i++)
5326 : {
5327 2102 : if (!(ploop->from[i] && ploop->to[i]))
5328 : {
5329 : nonempty = NULL;
5330 : break;
5331 : }
5332 :
5333 2102 : tree tmp = fold_build2_loc (input_location, LE_EXPR,
5334 : logical_type_node, ploop->from[i],
5335 : ploop->to[i]);
5336 :
5337 2102 : nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5338 : logical_type_node, nonempty, tmp);
5339 : }
5340 : }
5341 :
5342 11546 : lab1 = NULL;
5343 11546 : lab2 = NULL;
5344 : /* Initialize the position to zero, following Fortran 2003. We are free
5345 : to do this because Fortran 95 allows the result of an entirely false
5346 : mask to be processor dependent. If we know at compile time the array
5347 : is non-empty and no MASK is used, we can initialize to 1 to simplify
5348 : the inner loop. */
5349 9951 : if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5350 : {
5351 3748 : tree init = fold_build3_loc (input_location, COND_EXPR,
5352 : gfc_array_index_type, nonempty,
5353 : gfc_index_one_node,
5354 : gfc_index_zero_node);
5355 8430 : for (int i = 0; i < ploop->dimen; i++)
5356 4682 : gfc_add_modify (&ploop->pre, pos[i], init);
5357 : }
5358 : else
5359 : {
5360 13747 : for (int i = 0; i < ploop->dimen; i++)
5361 7544 : gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node);
5362 6203 : lab1 = gfc_build_label_decl (NULL_TREE);
5363 6203 : TREE_USED (lab1) = 1;
5364 6203 : lab2 = gfc_build_label_decl (NULL_TREE);
5365 6203 : TREE_USED (lab2) = 1;
5366 : }
5367 :
5368 : /* An offset must be added to the loop
5369 : counter to obtain the required position. */
5370 22177 : for (int i = 0; i < ploop->dimen; i++)
5371 : {
5372 12226 : gcc_assert (ploop->from[i]);
5373 :
5374 12226 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5375 : gfc_index_one_node, ploop->from[i]);
5376 12226 : gfc_add_modify (&ploop->pre, offset[i], tmp);
5377 : }
5378 :
5379 9951 : if (!nested_loop)
5380 : {
5381 9965 : gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5382 7155 : if (maskss)
5383 2700 : gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5384 : }
5385 :
5386 : /* Generate the loop body. */
5387 9951 : gfc_start_scalarized_body (ploop, &body);
5388 :
5389 : /* If we have a mask, only check this element if the mask is set. */
5390 9951 : if (maskexpr && maskexpr->rank > 0)
5391 : {
5392 3874 : gfc_init_se (&maskse, base_se);
5393 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5394 3874 : if (!nested_loop)
5395 2700 : maskse.ss = maskss;
5396 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5397 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5398 :
5399 3874 : gfc_start_block (&block);
5400 : }
5401 : else
5402 6077 : gfc_init_block (&block);
5403 :
5404 : /* Compare with the current limit. */
5405 9951 : gfc_init_se (&arrayse, base_se);
5406 9951 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5407 9951 : if (!nested_loop)
5408 7155 : arrayse.ss = arrayss;
5409 9951 : gfc_conv_expr_val (&arrayse, arrayexpr);
5410 9951 : gfc_add_block_to_block (&block, &arrayse.pre);
5411 :
5412 : /* We do the following if this is a more extreme value. */
5413 9951 : gfc_start_block (&ifblock);
5414 :
5415 : /* Assign the value to the limit... */
5416 9951 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5417 :
5418 9951 : if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5419 : {
5420 1569 : stmtblock_t ifblock2;
5421 1569 : tree ifbody2;
5422 :
5423 1569 : gfc_start_block (&ifblock2);
5424 3439 : for (int i = 0; i < ploop->dimen; i++)
5425 : {
5426 1870 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5427 : ploop->loopvar[i], offset[i]);
5428 1870 : gfc_add_modify (&ifblock2, pos[i], tmp);
5429 : }
5430 1569 : ifbody2 = gfc_finish_block (&ifblock2);
5431 :
5432 1569 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5433 : pos[0], gfc_index_zero_node);
5434 1569 : tmp = build3_v (COND_EXPR, cond, ifbody2,
5435 : build_empty_stmt (input_location));
5436 1569 : gfc_add_expr_to_block (&block, tmp);
5437 : }
5438 :
5439 22177 : for (int i = 0; i < ploop->dimen; i++)
5440 : {
5441 12226 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5442 : ploop->loopvar[i], offset[i]);
5443 12226 : gfc_add_modify (&ifblock, pos[i], tmp);
5444 12226 : gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
5445 : }
5446 :
5447 9951 : gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
5448 :
5449 9951 : if (lab1)
5450 6203 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5451 :
5452 9951 : ifbody = gfc_finish_block (&ifblock);
5453 :
5454 9951 : if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5455 : {
5456 7646 : if (lab1)
5457 5998 : cond = fold_build2_loc (input_location,
5458 : op == GT_EXPR ? GE_EXPR : LE_EXPR,
5459 : logical_type_node, arrayse.expr, limit);
5460 : else
5461 : {
5462 3748 : tree ifbody2, elsebody2;
5463 :
5464 : /* We switch to > or >= depending on the value of the BACK argument. */
5465 3748 : cond = gfc_create_var (logical_type_node, "cond");
5466 :
5467 3748 : gfc_start_block (&ifblock);
5468 5641 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5469 : logical_type_node, arrayse.expr, limit);
5470 :
5471 3748 : gfc_add_modify (&ifblock, cond, b_if);
5472 3748 : ifbody2 = gfc_finish_block (&ifblock);
5473 :
5474 3748 : gfc_start_block (&elseblock);
5475 3748 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5476 : arrayse.expr, limit);
5477 :
5478 3748 : gfc_add_modify (&elseblock, cond, b_else);
5479 3748 : elsebody2 = gfc_finish_block (&elseblock);
5480 :
5481 3748 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5482 : back, ifbody2, elsebody2);
5483 :
5484 3748 : gfc_add_expr_to_block (&block, tmp);
5485 : }
5486 :
5487 7646 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5488 7646 : ifbody = build3_v (COND_EXPR, cond, ifbody,
5489 : build_empty_stmt (input_location));
5490 : }
5491 9951 : gfc_add_expr_to_block (&block, ifbody);
5492 :
5493 9951 : if (maskexpr && maskexpr->rank > 0)
5494 : {
5495 : /* We enclose the above in if (mask) {...}. If the mask is an
5496 : optional argument, generate IF (.NOT. PRESENT(MASK)
5497 : .OR. MASK(I)). */
5498 :
5499 3874 : tree ifmask;
5500 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5501 3874 : tmp = gfc_finish_block (&block);
5502 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5503 : build_empty_stmt (input_location));
5504 3874 : }
5505 : else
5506 6077 : tmp = gfc_finish_block (&block);
5507 9951 : gfc_add_expr_to_block (&body, tmp);
5508 :
5509 9951 : if (lab1)
5510 : {
5511 13747 : for (int i = 0; i < ploop->dimen; i++)
5512 7544 : ploop->from[i] = fold_build3_loc (input_location, COND_EXPR,
5513 7544 : TREE_TYPE (ploop->from[i]),
5514 : second_loop_entry, idx[i],
5515 : ploop->from[i]);
5516 :
5517 6203 : gfc_trans_scalarized_loop_boundary (ploop, &body);
5518 :
5519 6203 : if (nested_loop)
5520 : {
5521 : /* The first loop already advanced the parent se'ss chain, so clear
5522 : the parent now to avoid doing it a second time, making the chain
5523 : out of sync. */
5524 1858 : nested_se.parent = nullptr;
5525 1858 : nested_se.ss = orig_ss;
5526 : }
5527 :
5528 6203 : stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1];
5529 :
5530 6203 : if (HONOR_NANS (DECL_MODE (limit)))
5531 : {
5532 3898 : if (nonempty != NULL)
5533 : {
5534 2329 : stmtblock_t init_block;
5535 2329 : gfc_init_block (&init_block);
5536 :
5537 5229 : for (int i = 0; i < ploop->dimen; i++)
5538 2900 : gfc_add_modify (&init_block, pos[i], gfc_index_one_node);
5539 :
5540 2329 : tree ifbody = gfc_finish_block (&init_block);
5541 2329 : tmp = build3_v (COND_EXPR, nonempty, ifbody,
5542 : build_empty_stmt (input_location));
5543 2329 : gfc_add_expr_to_block (outer_block, tmp);
5544 : }
5545 : }
5546 :
5547 6203 : gfc_add_expr_to_block (outer_block, build1_v (GOTO_EXPR, lab2));
5548 6203 : gfc_add_expr_to_block (outer_block, build1_v (LABEL_EXPR, lab1));
5549 :
5550 : /* If we have a mask, only check this element if the mask is set. */
5551 6203 : if (maskexpr && maskexpr->rank > 0)
5552 : {
5553 3874 : gfc_init_se (&maskse, base_se);
5554 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5555 3874 : if (!nested_loop)
5556 2700 : maskse.ss = maskss;
5557 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5558 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5559 :
5560 3874 : gfc_start_block (&block);
5561 : }
5562 : else
5563 2329 : gfc_init_block (&block);
5564 :
5565 : /* Compare with the current limit. */
5566 6203 : gfc_init_se (&arrayse, base_se);
5567 6203 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5568 6203 : if (!nested_loop)
5569 4345 : arrayse.ss = arrayss;
5570 6203 : gfc_conv_expr_val (&arrayse, arrayexpr);
5571 6203 : gfc_add_block_to_block (&block, &arrayse.pre);
5572 :
5573 : /* We do the following if this is a more extreme value. */
5574 6203 : gfc_start_block (&ifblock);
5575 :
5576 : /* Assign the value to the limit... */
5577 6203 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5578 :
5579 13747 : for (int i = 0; i < ploop->dimen; i++)
5580 : {
5581 7544 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5582 : ploop->loopvar[i], offset[i]);
5583 7544 : gfc_add_modify (&ifblock, pos[i], tmp);
5584 : }
5585 :
5586 6203 : ifbody = gfc_finish_block (&ifblock);
5587 :
5588 : /* We switch to > or >= depending on the value of the BACK argument. */
5589 6203 : {
5590 6203 : tree ifbody2, elsebody2;
5591 :
5592 6203 : cond = gfc_create_var (logical_type_node, "cond");
5593 :
5594 6203 : gfc_start_block (&ifblock);
5595 9537 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5596 : logical_type_node, arrayse.expr, limit);
5597 :
5598 6203 : gfc_add_modify (&ifblock, cond, b_if);
5599 6203 : ifbody2 = gfc_finish_block (&ifblock);
5600 :
5601 6203 : gfc_start_block (&elseblock);
5602 6203 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5603 : arrayse.expr, limit);
5604 :
5605 6203 : gfc_add_modify (&elseblock, cond, b_else);
5606 6203 : elsebody2 = gfc_finish_block (&elseblock);
5607 :
5608 6203 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5609 : back, ifbody2, elsebody2);
5610 : }
5611 :
5612 6203 : gfc_add_expr_to_block (&block, tmp);
5613 6203 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5614 6203 : tmp = build3_v (COND_EXPR, cond, ifbody,
5615 : build_empty_stmt (input_location));
5616 :
5617 6203 : gfc_add_expr_to_block (&block, tmp);
5618 :
5619 6203 : if (maskexpr && maskexpr->rank > 0)
5620 : {
5621 : /* We enclose the above in if (mask) {...}. If the mask is
5622 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5623 : .OR. MASK(I)).*/
5624 :
5625 3874 : tree ifmask;
5626 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5627 3874 : tmp = gfc_finish_block (&block);
5628 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5629 : build_empty_stmt (input_location));
5630 3874 : }
5631 : else
5632 2329 : tmp = gfc_finish_block (&block);
5633 :
5634 6203 : gfc_add_expr_to_block (&body, tmp);
5635 6203 : gfc_add_modify (&body, second_loop_entry, logical_false_node);
5636 : }
5637 :
5638 9951 : gfc_trans_scalarizing_loops (ploop, &body);
5639 :
5640 9951 : if (lab2)
5641 6203 : gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2));
5642 :
5643 : /* For a scalar mask, enclose the loop in an if statement. */
5644 9951 : if (maskexpr && maskexpr->rank == 0)
5645 : {
5646 2644 : tree ifmask;
5647 :
5648 2644 : gfc_init_se (&maskse, nested_loop ? se : nullptr);
5649 2644 : gfc_conv_expr_val (&maskse, maskexpr);
5650 2644 : gfc_add_block_to_block (&se->pre, &maskse.pre);
5651 2644 : gfc_init_block (&block);
5652 2644 : gfc_add_block_to_block (&block, &ploop->pre);
5653 2644 : gfc_add_block_to_block (&block, &ploop->post);
5654 2644 : tmp = gfc_finish_block (&block);
5655 :
5656 : /* For the else part of the scalar mask, just initialize
5657 : the pos variable the same way as above. */
5658 :
5659 2644 : gfc_init_block (&elseblock);
5660 5580 : for (int i = 0; i < ploop->dimen; i++)
5661 2936 : gfc_add_modify (&elseblock, pos[i], gfc_index_zero_node);
5662 2644 : elsetmp = gfc_finish_block (&elseblock);
5663 2644 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5664 2644 : tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5665 2644 : gfc_add_expr_to_block (&block, tmp);
5666 2644 : gfc_add_block_to_block (&se->pre, &block);
5667 2644 : }
5668 : else
5669 : {
5670 7307 : gfc_add_block_to_block (&se->pre, &ploop->pre);
5671 7307 : gfc_add_block_to_block (&se->pre, &ploop->post);
5672 : }
5673 :
5674 9951 : if (!nested_loop)
5675 7155 : gfc_cleanup_loop (&loop);
5676 :
5677 9951 : if (!dim_present)
5678 : {
5679 8837 : for (int i = 0; i < arrayexpr->rank; i++)
5680 : {
5681 5556 : tree res_idx = build_int_cst (gfc_array_index_type, i);
5682 5556 : tree res_arr_ref = gfc_build_array_ref (result_var, res_idx,
5683 : NULL_TREE, true);
5684 :
5685 5556 : tree value = convert (type, pos[i]);
5686 5556 : gfc_add_modify (&se->pre, res_arr_ref, value);
5687 : }
5688 :
5689 3281 : se->expr = result_var;
5690 : }
5691 : else
5692 6670 : se->expr = convert (type, pos[0]);
5693 : }
5694 :
5695 : /* Emit code for findloc. */
5696 :
5697 : static void
5698 1332 : gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5699 : {
5700 1332 : gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5701 : *kind_arg, *back_arg;
5702 1332 : gfc_expr *value_expr;
5703 1332 : int ikind;
5704 1332 : tree resvar;
5705 1332 : stmtblock_t block;
5706 1332 : stmtblock_t body;
5707 1332 : stmtblock_t loopblock;
5708 1332 : tree type;
5709 1332 : tree tmp;
5710 1332 : tree found;
5711 1332 : tree forward_branch = NULL_TREE;
5712 1332 : tree back_branch;
5713 1332 : gfc_loopinfo loop;
5714 1332 : gfc_ss *arrayss;
5715 1332 : gfc_ss *maskss;
5716 1332 : gfc_se arrayse;
5717 1332 : gfc_se valuese;
5718 1332 : gfc_se maskse;
5719 1332 : gfc_se backse;
5720 1332 : tree exit_label;
5721 1332 : gfc_expr *maskexpr;
5722 1332 : tree offset;
5723 1332 : int i;
5724 1332 : bool optional_mask;
5725 :
5726 1332 : array_arg = expr->value.function.actual;
5727 1332 : value_arg = array_arg->next;
5728 1332 : dim_arg = value_arg->next;
5729 1332 : mask_arg = dim_arg->next;
5730 1332 : kind_arg = mask_arg->next;
5731 1332 : back_arg = kind_arg->next;
5732 :
5733 : /* Remove kind and set ikind. */
5734 1332 : if (kind_arg->expr)
5735 : {
5736 0 : ikind = mpz_get_si (kind_arg->expr->value.integer);
5737 0 : gfc_free_expr (kind_arg->expr);
5738 0 : kind_arg->expr = NULL;
5739 : }
5740 : else
5741 1332 : ikind = gfc_default_integer_kind;
5742 :
5743 1332 : value_expr = value_arg->expr;
5744 :
5745 : /* Unless it's a string, pass VALUE by value. */
5746 1332 : if (value_expr->ts.type != BT_CHARACTER)
5747 732 : value_arg->name = "%VAL";
5748 :
5749 : /* Pass BACK argument by value. */
5750 1332 : back_arg->name = "%VAL";
5751 :
5752 : /* Call the library if we have a character function or if
5753 : rank > 0. */
5754 1332 : if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5755 : {
5756 1200 : se->ignore_optional = 1;
5757 1200 : if (expr->rank == 0)
5758 : {
5759 : /* Remove dim argument. */
5760 84 : gfc_free_expr (dim_arg->expr);
5761 84 : dim_arg->expr = NULL;
5762 : }
5763 1200 : gfc_conv_intrinsic_funcall (se, expr);
5764 1200 : return;
5765 : }
5766 :
5767 132 : type = gfc_get_int_type (ikind);
5768 :
5769 : /* Initialize the result. */
5770 132 : resvar = gfc_create_var (gfc_array_index_type, "pos");
5771 132 : gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5772 132 : offset = gfc_create_var (gfc_array_index_type, "offset");
5773 :
5774 132 : maskexpr = mask_arg->expr;
5775 72 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5776 60 : && maskexpr->symtree->n.sym->attr.dummy
5777 144 : && maskexpr->symtree->n.sym->attr.optional;
5778 :
5779 : /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5780 :
5781 396 : for (i = 0 ; i < 2; i++)
5782 : {
5783 : /* Walk the arguments. */
5784 264 : arrayss = gfc_walk_expr (array_arg->expr);
5785 264 : gcc_assert (arrayss != gfc_ss_terminator);
5786 :
5787 264 : if (maskexpr && maskexpr->rank != 0)
5788 : {
5789 84 : maskss = gfc_walk_expr (maskexpr);
5790 84 : gcc_assert (maskss != gfc_ss_terminator);
5791 : }
5792 : else
5793 : maskss = NULL;
5794 :
5795 : /* Initialize the scalarizer. */
5796 264 : gfc_init_loopinfo (&loop);
5797 264 : exit_label = gfc_build_label_decl (NULL_TREE);
5798 264 : TREE_USED (exit_label) = 1;
5799 :
5800 : /* We add the mask first because the number of iterations is
5801 : taken from the last ss, and this breaks if an absent
5802 : optional argument is used for mask. */
5803 :
5804 264 : if (maskss)
5805 84 : gfc_add_ss_to_loop (&loop, maskss);
5806 264 : gfc_add_ss_to_loop (&loop, arrayss);
5807 :
5808 : /* Initialize the loop. */
5809 264 : gfc_conv_ss_startstride (&loop);
5810 264 : gfc_conv_loop_setup (&loop, &expr->where);
5811 :
5812 : /* Calculate the offset. */
5813 264 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5814 : gfc_index_one_node, loop.from[0]);
5815 264 : gfc_add_modify (&loop.pre, offset, tmp);
5816 :
5817 264 : gfc_mark_ss_chain_used (arrayss, 1);
5818 264 : if (maskss)
5819 84 : gfc_mark_ss_chain_used (maskss, 1);
5820 :
5821 : /* The first loop is for BACK=.true. */
5822 264 : if (i == 0)
5823 132 : loop.reverse[0] = GFC_REVERSE_SET;
5824 :
5825 : /* Generate the loop body. */
5826 264 : gfc_start_scalarized_body (&loop, &body);
5827 :
5828 : /* If we have an array mask, only add the element if it is
5829 : set. */
5830 264 : if (maskss)
5831 : {
5832 84 : gfc_init_se (&maskse, NULL);
5833 84 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5834 84 : maskse.ss = maskss;
5835 84 : gfc_conv_expr_val (&maskse, maskexpr);
5836 84 : gfc_add_block_to_block (&body, &maskse.pre);
5837 : }
5838 :
5839 : /* If the condition matches then set the return value. */
5840 264 : gfc_start_block (&block);
5841 :
5842 : /* Add the offset. */
5843 264 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5844 264 : TREE_TYPE (resvar),
5845 : loop.loopvar[0], offset);
5846 264 : gfc_add_modify (&block, resvar, tmp);
5847 : /* And break out of the loop. */
5848 264 : tmp = build1_v (GOTO_EXPR, exit_label);
5849 264 : gfc_add_expr_to_block (&block, tmp);
5850 :
5851 264 : found = gfc_finish_block (&block);
5852 :
5853 : /* Check this element. */
5854 264 : gfc_init_se (&arrayse, NULL);
5855 264 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5856 264 : arrayse.ss = arrayss;
5857 264 : gfc_conv_expr_val (&arrayse, array_arg->expr);
5858 264 : gfc_add_block_to_block (&body, &arrayse.pre);
5859 :
5860 264 : gfc_init_se (&valuese, NULL);
5861 264 : gfc_conv_expr_val (&valuese, value_arg->expr);
5862 264 : gfc_add_block_to_block (&body, &valuese.pre);
5863 :
5864 264 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5865 : arrayse.expr, valuese.expr);
5866 :
5867 264 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5868 264 : if (maskss)
5869 : {
5870 : /* We enclose the above in if (mask) {...}. If the mask is
5871 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5872 : .OR. MASK(I)). */
5873 :
5874 84 : tree ifmask;
5875 84 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5876 84 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5877 : build_empty_stmt (input_location));
5878 : }
5879 :
5880 264 : gfc_add_expr_to_block (&body, tmp);
5881 264 : gfc_add_block_to_block (&body, &arrayse.post);
5882 :
5883 264 : gfc_trans_scalarizing_loops (&loop, &body);
5884 :
5885 : /* Add the exit label. */
5886 264 : tmp = build1_v (LABEL_EXPR, exit_label);
5887 264 : gfc_add_expr_to_block (&loop.pre, tmp);
5888 264 : gfc_start_block (&loopblock);
5889 264 : gfc_add_block_to_block (&loopblock, &loop.pre);
5890 264 : gfc_add_block_to_block (&loopblock, &loop.post);
5891 264 : if (i == 0)
5892 132 : forward_branch = gfc_finish_block (&loopblock);
5893 : else
5894 132 : back_branch = gfc_finish_block (&loopblock);
5895 :
5896 264 : gfc_cleanup_loop (&loop);
5897 : }
5898 :
5899 : /* Enclose the two loops in an IF statement. */
5900 :
5901 132 : gfc_init_se (&backse, NULL);
5902 132 : gfc_conv_expr_val (&backse, back_arg->expr);
5903 132 : gfc_add_block_to_block (&se->pre, &backse.pre);
5904 132 : tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5905 :
5906 : /* For a scalar mask, enclose the loop in an if statement. */
5907 132 : if (maskexpr && maskss == NULL)
5908 : {
5909 30 : tree ifmask;
5910 30 : tree if_stmt;
5911 :
5912 30 : gfc_init_se (&maskse, NULL);
5913 30 : gfc_conv_expr_val (&maskse, maskexpr);
5914 30 : gfc_init_block (&block);
5915 30 : gfc_add_expr_to_block (&block, maskse.expr);
5916 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5917 30 : if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5918 : build_empty_stmt (input_location));
5919 30 : gfc_add_expr_to_block (&block, if_stmt);
5920 30 : tmp = gfc_finish_block (&block);
5921 : }
5922 :
5923 132 : gfc_add_expr_to_block (&se->pre, tmp);
5924 132 : se->expr = convert (type, resvar);
5925 :
5926 : }
5927 :
5928 : /* Emit code for fstat, lstat and stat intrinsic subroutines. */
5929 :
5930 : static tree
5931 55 : conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code)
5932 : {
5933 55 : stmtblock_t block;
5934 55 : gfc_se se, se_stat;
5935 55 : tree unit = NULL_TREE;
5936 55 : tree name = NULL_TREE;
5937 55 : tree slen = NULL_TREE;
5938 55 : tree vals;
5939 55 : tree arg3 = NULL_TREE;
5940 55 : tree stat = NULL_TREE ;
5941 55 : tree present = NULL_TREE;
5942 55 : tree tmp;
5943 55 : int kind;
5944 :
5945 55 : gfc_init_block (&block);
5946 55 : gfc_init_se (&se, NULL);
5947 :
5948 55 : switch (code->resolved_isym->id)
5949 : {
5950 21 : case GFC_ISYM_FSTAT:
5951 : /* Deal with the UNIT argument. */
5952 21 : gfc_conv_expr (&se, code->ext.actual->expr);
5953 21 : gfc_add_block_to_block (&block, &se.pre);
5954 21 : unit = gfc_evaluate_now (se.expr, &block);
5955 21 : unit = gfc_build_addr_expr (NULL_TREE, unit);
5956 21 : gfc_add_block_to_block (&block, &se.post);
5957 21 : break;
5958 :
5959 34 : case GFC_ISYM_LSTAT:
5960 34 : case GFC_ISYM_STAT:
5961 : /* Deal with the NAME argument. */
5962 34 : gfc_conv_expr (&se, code->ext.actual->expr);
5963 34 : gfc_conv_string_parameter (&se);
5964 34 : gfc_add_block_to_block (&block, &se.pre);
5965 34 : name = se.expr;
5966 34 : slen = se.string_length;
5967 34 : gfc_add_block_to_block (&block, &se.post);
5968 34 : break;
5969 :
5970 0 : default:
5971 0 : gcc_unreachable ();
5972 : }
5973 :
5974 : /* Deal with the VALUES argument. */
5975 55 : gfc_init_se (&se, NULL);
5976 55 : gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr);
5977 55 : vals = gfc_build_addr_expr (NULL_TREE, se.expr);
5978 55 : gfc_add_block_to_block (&block, &se.pre);
5979 55 : gfc_add_block_to_block (&block, &se.post);
5980 55 : kind = code->ext.actual->next->expr->ts.kind;
5981 :
5982 : /* Deal with an optional STATUS. */
5983 55 : if (code->ext.actual->next->next->expr)
5984 : {
5985 45 : gfc_init_se (&se_stat, NULL);
5986 45 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
5987 45 : stat = gfc_create_var (gfc_get_int_type (kind), "_stat");
5988 45 : arg3 = gfc_build_addr_expr (NULL_TREE, stat);
5989 :
5990 : /* Handle case of status being an optional dummy. */
5991 45 : gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym;
5992 45 : if (sym->attr.dummy && sym->attr.optional)
5993 : {
5994 6 : present = gfc_conv_expr_present (sym);
5995 12 : arg3 = fold_build3_loc (input_location, COND_EXPR,
5996 6 : TREE_TYPE (arg3), present, arg3,
5997 6 : fold_convert (TREE_TYPE (arg3),
5998 : null_pointer_node));
5999 : }
6000 : }
6001 :
6002 : /* Call library function depending on KIND of VALUES argument. */
6003 55 : switch (code->resolved_isym->id)
6004 : {
6005 21 : case GFC_ISYM_FSTAT:
6006 21 : tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub);
6007 : break;
6008 14 : case GFC_ISYM_LSTAT:
6009 14 : tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub);
6010 : break;
6011 20 : case GFC_ISYM_STAT:
6012 20 : tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub);
6013 : break;
6014 0 : default:
6015 0 : gcc_unreachable ();
6016 : }
6017 :
6018 55 : if (code->resolved_isym->id == GFC_ISYM_FSTAT)
6019 21 : tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals,
6020 : stat ? arg3 : null_pointer_node);
6021 : else
6022 34 : tmp = build_call_expr_loc (input_location, tmp, 4, name, vals,
6023 : stat ? arg3 : null_pointer_node, slen);
6024 55 : gfc_add_expr_to_block (&block, tmp);
6025 :
6026 : /* Handle kind conversion of status. */
6027 55 : if (stat && stat != se_stat.expr)
6028 : {
6029 45 : stmtblock_t block2;
6030 :
6031 45 : gfc_init_block (&block2);
6032 45 : gfc_add_modify (&block2, se_stat.expr,
6033 45 : fold_convert (TREE_TYPE (se_stat.expr), stat));
6034 :
6035 45 : if (present)
6036 : {
6037 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2),
6038 : build_empty_stmt (input_location));
6039 6 : gfc_add_expr_to_block (&block, tmp);
6040 : }
6041 : else
6042 39 : gfc_add_block_to_block (&block, &block2);
6043 : }
6044 :
6045 55 : return gfc_finish_block (&block);
6046 : }
6047 :
6048 : /* Emit code for minval or maxval intrinsic. There are many different cases
6049 : we need to handle. For performance reasons we sometimes create two
6050 : loops instead of one, where the second one is much simpler.
6051 : Examples for minval intrinsic:
6052 : 1) Result is an array, a call is generated
6053 : 2) Array mask is used and NaNs need to be supported, rank 1:
6054 : limit = Infinity;
6055 : nonempty = false;
6056 : S = from;
6057 : while (S <= to) {
6058 : if (mask[S]) {
6059 : nonempty = true;
6060 : if (a[S] <= limit) {
6061 : limit = a[S];
6062 : S++;
6063 : goto lab;
6064 : }
6065 : else
6066 : S++;
6067 : }
6068 : }
6069 : limit = nonempty ? NaN : huge (limit);
6070 : lab:
6071 : while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6072 : 3) NaNs need to be supported, but it is known at compile time or cheaply
6073 : at runtime whether array is nonempty or not, rank 1:
6074 : limit = Infinity;
6075 : S = from;
6076 : while (S <= to) {
6077 : if (a[S] <= limit) {
6078 : limit = a[S];
6079 : S++;
6080 : goto lab;
6081 : }
6082 : else
6083 : S++;
6084 : }
6085 : limit = (from <= to) ? NaN : huge (limit);
6086 : lab:
6087 : while (S <= to) { limit = min (a[S], limit); S++; }
6088 : 4) Array mask is used and NaNs need to be supported, rank > 1:
6089 : limit = Infinity;
6090 : nonempty = false;
6091 : fast = false;
6092 : S1 = from1;
6093 : while (S1 <= to1) {
6094 : S2 = from2;
6095 : while (S2 <= to2) {
6096 : if (mask[S1][S2]) {
6097 : if (fast) limit = min (a[S1][S2], limit);
6098 : else {
6099 : nonempty = true;
6100 : if (a[S1][S2] <= limit) {
6101 : limit = a[S1][S2];
6102 : fast = true;
6103 : }
6104 : }
6105 : }
6106 : S2++;
6107 : }
6108 : S1++;
6109 : }
6110 : if (!fast)
6111 : limit = nonempty ? NaN : huge (limit);
6112 : 5) NaNs need to be supported, but it is known at compile time or cheaply
6113 : at runtime whether array is nonempty or not, rank > 1:
6114 : limit = Infinity;
6115 : fast = false;
6116 : S1 = from1;
6117 : while (S1 <= to1) {
6118 : S2 = from2;
6119 : while (S2 <= to2) {
6120 : if (fast) limit = min (a[S1][S2], limit);
6121 : else {
6122 : if (a[S1][S2] <= limit) {
6123 : limit = a[S1][S2];
6124 : fast = true;
6125 : }
6126 : }
6127 : S2++;
6128 : }
6129 : S1++;
6130 : }
6131 : if (!fast)
6132 : limit = (nonempty_array) ? NaN : huge (limit);
6133 : 6) NaNs aren't supported, but infinities are. Array mask is used:
6134 : limit = Infinity;
6135 : nonempty = false;
6136 : S = from;
6137 : while (S <= to) {
6138 : if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6139 : S++;
6140 : }
6141 : limit = nonempty ? limit : huge (limit);
6142 : 7) Same without array mask:
6143 : limit = Infinity;
6144 : S = from;
6145 : while (S <= to) { limit = min (a[S], limit); S++; }
6146 : limit = (from <= to) ? limit : huge (limit);
6147 : 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6148 : limit = huge (limit);
6149 : S = from;
6150 : while (S <= to) { limit = min (a[S], limit); S++); }
6151 : (or
6152 : while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6153 : with array mask instead).
6154 : For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6155 : setting limit = huge (limit); in the else branch. */
6156 :
6157 : static void
6158 2417 : gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6159 : {
6160 2417 : tree limit;
6161 2417 : tree type;
6162 2417 : tree tmp;
6163 2417 : tree ifbody;
6164 2417 : tree nonempty;
6165 2417 : tree nonempty_var;
6166 2417 : tree lab;
6167 2417 : tree fast;
6168 2417 : tree huge_cst = NULL, nan_cst = NULL;
6169 2417 : stmtblock_t body;
6170 2417 : stmtblock_t block, block2;
6171 2417 : gfc_loopinfo loop;
6172 2417 : gfc_actual_arglist *actual;
6173 2417 : gfc_ss *arrayss;
6174 2417 : gfc_ss *maskss;
6175 2417 : gfc_se arrayse;
6176 2417 : gfc_se maskse;
6177 2417 : gfc_expr *arrayexpr;
6178 2417 : gfc_expr *maskexpr;
6179 2417 : int n;
6180 2417 : bool optional_mask;
6181 :
6182 2417 : if (se->ss)
6183 : {
6184 0 : gfc_conv_intrinsic_funcall (se, expr);
6185 186 : return;
6186 : }
6187 :
6188 2417 : actual = expr->value.function.actual;
6189 2417 : arrayexpr = actual->expr;
6190 :
6191 2417 : if (arrayexpr->ts.type == BT_CHARACTER)
6192 : {
6193 186 : gfc_actual_arglist *dim = actual->next;
6194 186 : if (expr->rank == 0 && dim->expr != 0)
6195 : {
6196 6 : gfc_free_expr (dim->expr);
6197 6 : dim->expr = NULL;
6198 : }
6199 186 : gfc_conv_intrinsic_funcall (se, expr);
6200 186 : return;
6201 : }
6202 :
6203 2231 : type = gfc_typenode_for_spec (&expr->ts);
6204 : /* Initialize the result. */
6205 2231 : limit = gfc_create_var (type, "limit");
6206 2231 : n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6207 2231 : switch (expr->ts.type)
6208 : {
6209 1245 : case BT_REAL:
6210 1245 : huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6211 : expr->ts.kind, 0);
6212 1245 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6213 : {
6214 1241 : REAL_VALUE_TYPE real;
6215 1241 : real_inf (&real);
6216 1241 : tmp = build_real (type, real);
6217 : }
6218 : else
6219 : tmp = huge_cst;
6220 1245 : if (HONOR_NANS (DECL_MODE (limit)))
6221 1241 : nan_cst = gfc_build_nan (type, "");
6222 : break;
6223 :
6224 956 : case BT_INTEGER:
6225 956 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6226 956 : break;
6227 :
6228 30 : case BT_UNSIGNED:
6229 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
6230 30 : if (op == GT_EXPR)
6231 18 : tmp = build_int_cst (type, 0);
6232 : else
6233 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
6234 : expr->ts.kind);
6235 : break;
6236 :
6237 0 : default:
6238 0 : gcc_unreachable ();
6239 : }
6240 :
6241 : /* We start with the most negative possible value for MAXVAL, and the most
6242 : positive possible value for MINVAL. The most negative possible value is
6243 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6244 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
6245 : with above. */
6246 2231 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
6247 : {
6248 987 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6249 987 : if (huge_cst)
6250 560 : huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6251 560 : TREE_TYPE (huge_cst), huge_cst);
6252 : }
6253 :
6254 1005 : if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6255 427 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6256 : tmp, build_int_cst (type, 1));
6257 :
6258 2231 : gfc_add_modify (&se->pre, limit, tmp);
6259 :
6260 : /* Walk the arguments. */
6261 2231 : arrayss = gfc_walk_expr (arrayexpr);
6262 2231 : gcc_assert (arrayss != gfc_ss_terminator);
6263 :
6264 2231 : actual = actual->next->next;
6265 2231 : gcc_assert (actual);
6266 2231 : maskexpr = actual->expr;
6267 1572 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6268 1560 : && maskexpr->symtree->n.sym->attr.dummy
6269 2243 : && maskexpr->symtree->n.sym->attr.optional;
6270 1560 : nonempty = NULL;
6271 1572 : if (maskexpr && maskexpr->rank != 0)
6272 : {
6273 1026 : maskss = gfc_walk_expr (maskexpr);
6274 1026 : gcc_assert (maskss != gfc_ss_terminator);
6275 : }
6276 : else
6277 : {
6278 1205 : mpz_t asize;
6279 1205 : if (gfc_array_size (arrayexpr, &asize))
6280 : {
6281 678 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6282 678 : mpz_clear (asize);
6283 678 : nonempty = fold_build2_loc (input_location, GT_EXPR,
6284 : logical_type_node, nonempty,
6285 : gfc_index_zero_node);
6286 : }
6287 1205 : maskss = NULL;
6288 : }
6289 :
6290 : /* Initialize the scalarizer. */
6291 2231 : gfc_init_loopinfo (&loop);
6292 :
6293 : /* We add the mask first because the number of iterations is taken
6294 : from the last ss, and this breaks if an absent optional argument
6295 : is used for mask. */
6296 :
6297 2231 : if (maskss)
6298 1026 : gfc_add_ss_to_loop (&loop, maskss);
6299 2231 : gfc_add_ss_to_loop (&loop, arrayss);
6300 :
6301 : /* Initialize the loop. */
6302 2231 : gfc_conv_ss_startstride (&loop);
6303 :
6304 : /* The code generated can have more than one loop in sequence (see the
6305 : comment at the function header). This doesn't work well with the
6306 : scalarizer, which changes arrays' offset when the scalarization loops
6307 : are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6308 : are currently inlined in the scalar case only. As there is no dependency
6309 : to care about in that case, there is no temporary, so that we can use the
6310 : scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6311 : here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6312 : gfc_trans_scalarized_loop_boundary even later to restore offset.
6313 : TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6314 : should eventually go away. We could either create two loops properly,
6315 : or find another way to save/restore the array offsets between the two
6316 : loops (without conflicting with temporary management), or use a single
6317 : loop minmaxval implementation. See PR 31067. */
6318 2231 : loop.temp_dim = loop.dimen;
6319 2231 : gfc_conv_loop_setup (&loop, &expr->where);
6320 :
6321 2231 : if (nonempty == NULL && maskss == NULL
6322 527 : && loop.dimen == 1 && loop.from[0] && loop.to[0])
6323 491 : nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6324 : loop.from[0], loop.to[0]);
6325 2231 : nonempty_var = NULL;
6326 2231 : if (nonempty == NULL
6327 2231 : && (HONOR_INFINITIES (DECL_MODE (limit))
6328 480 : || HONOR_NANS (DECL_MODE (limit))))
6329 : {
6330 582 : nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6331 582 : gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6332 582 : nonempty = nonempty_var;
6333 : }
6334 2231 : lab = NULL;
6335 2231 : fast = NULL;
6336 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6337 : {
6338 1241 : if (loop.dimen == 1)
6339 : {
6340 821 : lab = gfc_build_label_decl (NULL_TREE);
6341 821 : TREE_USED (lab) = 1;
6342 : }
6343 : else
6344 : {
6345 420 : fast = gfc_create_var (logical_type_node, "fast");
6346 420 : gfc_add_modify (&se->pre, fast, logical_false_node);
6347 : }
6348 : }
6349 :
6350 2231 : gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6351 2231 : if (maskss)
6352 1704 : gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6353 : /* Generate the loop body. */
6354 2231 : gfc_start_scalarized_body (&loop, &body);
6355 :
6356 : /* If we have a mask, only add this element if the mask is set. */
6357 2231 : if (maskss)
6358 : {
6359 1026 : gfc_init_se (&maskse, NULL);
6360 1026 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6361 1026 : maskse.ss = maskss;
6362 1026 : gfc_conv_expr_val (&maskse, maskexpr);
6363 1026 : gfc_add_block_to_block (&body, &maskse.pre);
6364 :
6365 1026 : gfc_start_block (&block);
6366 : }
6367 : else
6368 1205 : gfc_init_block (&block);
6369 :
6370 : /* Compare with the current limit. */
6371 2231 : gfc_init_se (&arrayse, NULL);
6372 2231 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6373 2231 : arrayse.ss = arrayss;
6374 2231 : gfc_conv_expr_val (&arrayse, arrayexpr);
6375 2231 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6376 2231 : gfc_add_block_to_block (&block, &arrayse.pre);
6377 :
6378 2231 : gfc_init_block (&block2);
6379 :
6380 2231 : if (nonempty_var)
6381 582 : gfc_add_modify (&block2, nonempty_var, logical_true_node);
6382 :
6383 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6384 : {
6385 1922 : tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6386 : logical_type_node, arrayse.expr, limit);
6387 1241 : if (lab)
6388 : {
6389 821 : stmtblock_t ifblock;
6390 821 : tree inc_loop;
6391 821 : inc_loop = fold_build2_loc (input_location, PLUS_EXPR,
6392 821 : TREE_TYPE (loop.loopvar[0]),
6393 : loop.loopvar[0], gfc_index_one_node);
6394 821 : gfc_init_block (&ifblock);
6395 821 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6396 821 : gfc_add_modify (&ifblock, loop.loopvar[0], inc_loop);
6397 821 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab));
6398 821 : ifbody = gfc_finish_block (&ifblock);
6399 : }
6400 : else
6401 : {
6402 420 : stmtblock_t ifblock;
6403 :
6404 420 : gfc_init_block (&ifblock);
6405 420 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6406 420 : gfc_add_modify (&ifblock, fast, logical_true_node);
6407 420 : ifbody = gfc_finish_block (&ifblock);
6408 : }
6409 1241 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6410 : build_empty_stmt (input_location));
6411 1241 : gfc_add_expr_to_block (&block2, tmp);
6412 : }
6413 : else
6414 : {
6415 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6416 : signed zeros. */
6417 1535 : tmp = fold_build2_loc (input_location,
6418 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6419 : type, arrayse.expr, limit);
6420 990 : gfc_add_modify (&block2, limit, tmp);
6421 : }
6422 :
6423 2231 : if (fast)
6424 : {
6425 420 : tree elsebody = gfc_finish_block (&block2);
6426 :
6427 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6428 : signed zeros. */
6429 420 : if (HONOR_NANS (DECL_MODE (limit)))
6430 : {
6431 420 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6432 : arrayse.expr, limit);
6433 420 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6434 420 : ifbody = build3_v (COND_EXPR, tmp, ifbody,
6435 : build_empty_stmt (input_location));
6436 : }
6437 : else
6438 : {
6439 0 : tmp = fold_build2_loc (input_location,
6440 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6441 : type, arrayse.expr, limit);
6442 0 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6443 : }
6444 420 : tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6445 420 : gfc_add_expr_to_block (&block, tmp);
6446 : }
6447 : else
6448 1811 : gfc_add_block_to_block (&block, &block2);
6449 :
6450 2231 : gfc_add_block_to_block (&block, &arrayse.post);
6451 :
6452 2231 : tmp = gfc_finish_block (&block);
6453 2231 : if (maskss)
6454 : {
6455 : /* We enclose the above in if (mask) {...}. If the mask is an
6456 : optional argument, generate IF (.NOT. PRESENT(MASK)
6457 : .OR. MASK(I)). */
6458 1026 : tree ifmask;
6459 1026 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6460 1026 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6461 : build_empty_stmt (input_location));
6462 : }
6463 2231 : gfc_add_expr_to_block (&body, tmp);
6464 :
6465 2231 : if (lab)
6466 : {
6467 821 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6468 :
6469 821 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6470 : nan_cst, huge_cst);
6471 821 : gfc_add_modify (&loop.code[0], limit, tmp);
6472 821 : gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6473 :
6474 : /* If we have a mask, only add this element if the mask is set. */
6475 821 : if (maskss)
6476 : {
6477 348 : gfc_init_se (&maskse, NULL);
6478 348 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6479 348 : maskse.ss = maskss;
6480 348 : gfc_conv_expr_val (&maskse, maskexpr);
6481 348 : gfc_add_block_to_block (&body, &maskse.pre);
6482 :
6483 348 : gfc_start_block (&block);
6484 : }
6485 : else
6486 473 : gfc_init_block (&block);
6487 :
6488 : /* Compare with the current limit. */
6489 821 : gfc_init_se (&arrayse, NULL);
6490 821 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6491 821 : arrayse.ss = arrayss;
6492 821 : gfc_conv_expr_val (&arrayse, arrayexpr);
6493 821 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6494 821 : gfc_add_block_to_block (&block, &arrayse.pre);
6495 :
6496 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6497 : signed zeros. */
6498 821 : if (HONOR_NANS (DECL_MODE (limit)))
6499 : {
6500 821 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6501 : arrayse.expr, limit);
6502 821 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6503 821 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6504 : build_empty_stmt (input_location));
6505 821 : gfc_add_expr_to_block (&block, tmp);
6506 : }
6507 : else
6508 : {
6509 0 : tmp = fold_build2_loc (input_location,
6510 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6511 : type, arrayse.expr, limit);
6512 0 : gfc_add_modify (&block, limit, tmp);
6513 : }
6514 :
6515 821 : gfc_add_block_to_block (&block, &arrayse.post);
6516 :
6517 821 : tmp = gfc_finish_block (&block);
6518 821 : if (maskss)
6519 : /* We enclose the above in if (mask) {...}. */
6520 : {
6521 348 : tree ifmask;
6522 348 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6523 348 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6524 : build_empty_stmt (input_location));
6525 : }
6526 :
6527 821 : gfc_add_expr_to_block (&body, tmp);
6528 : /* Avoid initializing loopvar[0] again, it should be left where
6529 : it finished by the first loop. */
6530 821 : loop.from[0] = loop.loopvar[0];
6531 : }
6532 2231 : gfc_trans_scalarizing_loops (&loop, &body);
6533 :
6534 2231 : if (fast)
6535 : {
6536 420 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6537 : nan_cst, huge_cst);
6538 420 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6539 420 : tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6540 : ifbody);
6541 420 : gfc_add_expr_to_block (&loop.pre, tmp);
6542 : }
6543 1811 : else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6544 : {
6545 0 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6546 : huge_cst);
6547 0 : gfc_add_modify (&loop.pre, limit, tmp);
6548 : }
6549 :
6550 : /* For a scalar mask, enclose the loop in an if statement. */
6551 2231 : if (maskexpr && maskss == NULL)
6552 : {
6553 546 : tree else_stmt;
6554 546 : tree ifmask;
6555 :
6556 546 : gfc_init_se (&maskse, NULL);
6557 546 : gfc_conv_expr_val (&maskse, maskexpr);
6558 546 : gfc_init_block (&block);
6559 546 : gfc_add_block_to_block (&block, &loop.pre);
6560 546 : gfc_add_block_to_block (&block, &loop.post);
6561 546 : tmp = gfc_finish_block (&block);
6562 :
6563 546 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6564 354 : else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6565 : else
6566 192 : else_stmt = build_empty_stmt (input_location);
6567 :
6568 546 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6569 546 : tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6570 546 : gfc_add_expr_to_block (&block, tmp);
6571 546 : gfc_add_block_to_block (&se->pre, &block);
6572 : }
6573 : else
6574 : {
6575 1685 : gfc_add_block_to_block (&se->pre, &loop.pre);
6576 1685 : gfc_add_block_to_block (&se->pre, &loop.post);
6577 : }
6578 :
6579 2231 : gfc_cleanup_loop (&loop);
6580 :
6581 2231 : se->expr = limit;
6582 : }
6583 :
6584 : /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6585 : static void
6586 145 : gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6587 : {
6588 145 : tree args[2];
6589 145 : tree type;
6590 145 : tree tmp;
6591 :
6592 145 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6593 145 : type = TREE_TYPE (args[0]);
6594 :
6595 : /* Optionally generate code for runtime argument check. */
6596 145 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6597 : {
6598 6 : tree below = fold_build2_loc (input_location, LT_EXPR,
6599 : logical_type_node, args[1],
6600 6 : build_int_cst (TREE_TYPE (args[1]), 0));
6601 6 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6602 6 : tree above = fold_build2_loc (input_location, GE_EXPR,
6603 : logical_type_node, args[1], nbits);
6604 6 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6605 : logical_type_node, below, above);
6606 6 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6607 : "POS argument (%ld) out of range 0:%ld "
6608 : "in intrinsic BTEST",
6609 : fold_convert (long_integer_type_node, args[1]),
6610 : fold_convert (long_integer_type_node, nbits));
6611 : }
6612 :
6613 145 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6614 : build_int_cst (type, 1), args[1]);
6615 145 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6616 145 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6617 : build_int_cst (type, 0));
6618 145 : type = gfc_typenode_for_spec (&expr->ts);
6619 145 : se->expr = convert (type, tmp);
6620 145 : }
6621 :
6622 :
6623 : /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6624 : static void
6625 216 : gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6626 : {
6627 216 : tree args[2];
6628 :
6629 216 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6630 :
6631 : /* Convert both arguments to the unsigned type of the same size. */
6632 216 : args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6633 216 : args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6634 :
6635 : /* If they have unequal type size, convert to the larger one. */
6636 216 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
6637 216 : > TYPE_PRECISION (TREE_TYPE (args[1])))
6638 0 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6639 216 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6640 216 : > TYPE_PRECISION (TREE_TYPE (args[0])))
6641 0 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6642 :
6643 : /* Now, we compare them. */
6644 216 : se->expr = fold_build2_loc (input_location, op, logical_type_node,
6645 : args[0], args[1]);
6646 216 : }
6647 :
6648 :
6649 : /* Generate code to perform the specified operation. */
6650 : static void
6651 1837 : gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6652 : {
6653 1837 : tree args[2];
6654 :
6655 1837 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6656 1837 : se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6657 : args[0], args[1]);
6658 1837 : }
6659 :
6660 : /* Bitwise not. */
6661 : static void
6662 230 : gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6663 : {
6664 230 : tree arg;
6665 :
6666 230 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6667 230 : se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6668 230 : TREE_TYPE (arg), arg);
6669 230 : }
6670 :
6671 :
6672 : /* Generate code for OUT_OF_RANGE. */
6673 : static void
6674 468 : gfc_conv_intrinsic_out_of_range (gfc_se * se, gfc_expr * expr)
6675 : {
6676 468 : tree *args;
6677 468 : tree type;
6678 468 : tree tmp = NULL_TREE, tmp1, tmp2;
6679 468 : unsigned int num_args;
6680 468 : int k;
6681 468 : gfc_se rnd_se;
6682 468 : gfc_actual_arglist *arg = expr->value.function.actual;
6683 468 : gfc_expr *x = arg->expr;
6684 468 : gfc_expr *mold = arg->next->expr;
6685 :
6686 468 : num_args = gfc_intrinsic_argument_list_length (expr);
6687 468 : args = XALLOCAVEC (tree, num_args);
6688 :
6689 468 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6690 :
6691 468 : gfc_init_se (&rnd_se, NULL);
6692 :
6693 468 : if (num_args == 3)
6694 : {
6695 : /* The ROUND argument is optional and shall appear only if X is
6696 : of type real and MOLD is of type integer (see edit F23/004). */
6697 270 : gfc_expr *round = arg->next->next->expr;
6698 270 : gfc_conv_expr (&rnd_se, round);
6699 :
6700 270 : if (round->expr_type == EXPR_VARIABLE
6701 198 : && round->symtree->n.sym->attr.dummy
6702 30 : && round->symtree->n.sym->attr.optional)
6703 : {
6704 30 : tree present = gfc_conv_expr_present (round->symtree->n.sym);
6705 30 : rnd_se.expr = build3_loc (input_location, COND_EXPR,
6706 : logical_type_node, present,
6707 : rnd_se.expr, logical_false_node);
6708 30 : gfc_add_block_to_block (&se->pre, &rnd_se.pre);
6709 : }
6710 : }
6711 : else
6712 : {
6713 : /* If ROUND is absent, it is equivalent to having the value false. */
6714 198 : rnd_se.expr = logical_false_node;
6715 : }
6716 :
6717 468 : type = TREE_TYPE (args[0]);
6718 468 : k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
6719 :
6720 468 : switch (x->ts.type)
6721 : {
6722 378 : case BT_REAL:
6723 : /* X may be IEEE infinity or NaN, but the representation of MOLD may not
6724 : support infinity or NaN. */
6725 378 : tree finite;
6726 378 : finite = build_call_expr_loc (input_location,
6727 : builtin_decl_explicit (BUILT_IN_ISFINITE),
6728 : 1, args[0]);
6729 378 : finite = convert (logical_type_node, finite);
6730 :
6731 378 : if (mold->ts.type == BT_REAL)
6732 : {
6733 24 : tmp1 = build1 (ABS_EXPR, type, args[0]);
6734 24 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6735 : mold->ts.kind, 0);
6736 24 : tmp = build2 (GT_EXPR, logical_type_node, tmp1,
6737 : convert (type, tmp2));
6738 :
6739 : /* Check if MOLD representation supports infinity or NaN. */
6740 24 : bool infnan = (HONOR_INFINITIES (TREE_TYPE (args[1]))
6741 24 : || HONOR_NANS (TREE_TYPE (args[1])));
6742 24 : tmp = build3 (COND_EXPR, logical_type_node, finite, tmp,
6743 : infnan ? logical_false_node : logical_true_node);
6744 : }
6745 : else
6746 : {
6747 354 : tree rounded;
6748 354 : tree decl;
6749 :
6750 354 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, x->ts.kind);
6751 354 : gcc_assert (decl != NULL_TREE);
6752 :
6753 : /* Round or truncate argument X, depending on the optional argument
6754 : ROUND (default: .false.). */
6755 354 : tmp1 = build_round_expr (args[0], type);
6756 354 : tmp2 = build_call_expr_loc (input_location, decl, 1, args[0]);
6757 354 : rounded = build3 (COND_EXPR, type, rnd_se.expr, tmp1, tmp2);
6758 :
6759 354 : if (mold->ts.type == BT_INTEGER)
6760 : {
6761 180 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6762 : x->ts.kind);
6763 180 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6764 : x->ts.kind);
6765 : }
6766 174 : else if (mold->ts.type == BT_UNSIGNED)
6767 : {
6768 174 : tmp1 = build_real_from_int_cst (type, integer_zero_node);
6769 174 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6770 : x->ts.kind);
6771 : }
6772 : else
6773 0 : gcc_unreachable ();
6774 :
6775 354 : tmp1 = build2 (LT_EXPR, logical_type_node, rounded,
6776 : convert (type, tmp1));
6777 354 : tmp2 = build2 (GT_EXPR, logical_type_node, rounded,
6778 : convert (type, tmp2));
6779 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6780 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node,
6781 : build1 (TRUTH_NOT_EXPR, logical_type_node, finite),
6782 : tmp);
6783 : }
6784 : break;
6785 :
6786 48 : case BT_INTEGER:
6787 48 : if (mold->ts.type == BT_INTEGER)
6788 : {
6789 12 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6790 : x->ts.kind);
6791 12 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6792 : x->ts.kind);
6793 12 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6794 : convert (type, tmp1));
6795 12 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6796 : convert (type, tmp2));
6797 12 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6798 : }
6799 36 : else if (mold->ts.type == BT_UNSIGNED)
6800 : {
6801 36 : int i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6802 36 : tmp = build_int_cst (type, 0);
6803 36 : tmp = build2 (LT_EXPR, logical_type_node, args[0], tmp);
6804 36 : if (mpz_cmp (gfc_integer_kinds[i].huge,
6805 36 : gfc_unsigned_kinds[k].huge) > 0)
6806 : {
6807 0 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6808 : x->ts.kind);
6809 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6810 : convert (type, tmp2));
6811 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp, tmp2);
6812 : }
6813 : }
6814 0 : else if (mold->ts.type == BT_REAL)
6815 : {
6816 0 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6817 : mold->ts.kind, 0);
6818 0 : tmp1 = build1 (NEGATE_EXPR, TREE_TYPE (tmp2), tmp2);
6819 0 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6820 : convert (type, tmp1));
6821 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6822 : convert (type, tmp2));
6823 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6824 : }
6825 : else
6826 0 : gcc_unreachable ();
6827 : break;
6828 :
6829 42 : case BT_UNSIGNED:
6830 42 : if (mold->ts.type == BT_UNSIGNED)
6831 : {
6832 12 : tmp = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6833 : x->ts.kind);
6834 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6835 : convert (type, tmp));
6836 : }
6837 30 : else if (mold->ts.type == BT_INTEGER)
6838 : {
6839 18 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6840 : x->ts.kind);
6841 18 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6842 : convert (type, tmp));
6843 : }
6844 12 : else if (mold->ts.type == BT_REAL)
6845 : {
6846 12 : tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6847 : mold->ts.kind, 0);
6848 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6849 : convert (type, tmp));
6850 : }
6851 : else
6852 0 : gcc_unreachable ();
6853 : break;
6854 :
6855 0 : default:
6856 0 : gcc_unreachable ();
6857 : }
6858 :
6859 468 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6860 468 : }
6861 :
6862 :
6863 : /* Set or clear a single bit. */
6864 : static void
6865 306 : gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6866 : {
6867 306 : tree args[2];
6868 306 : tree type;
6869 306 : tree tmp;
6870 306 : enum tree_code op;
6871 :
6872 306 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6873 306 : type = TREE_TYPE (args[0]);
6874 :
6875 : /* Optionally generate code for runtime argument check. */
6876 306 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6877 : {
6878 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6879 : logical_type_node, args[1],
6880 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6881 12 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6882 12 : tree above = fold_build2_loc (input_location, GE_EXPR,
6883 : logical_type_node, args[1], nbits);
6884 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6885 : logical_type_node, below, above);
6886 12 : size_t len_name = strlen (expr->value.function.isym->name);
6887 12 : char *name = XALLOCAVEC (char, len_name + 1);
6888 72 : for (size_t i = 0; i < len_name; i++)
6889 60 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
6890 12 : name[len_name] = '\0';
6891 12 : tree iname = gfc_build_addr_expr (pchar_type_node,
6892 : gfc_build_cstring_const (name));
6893 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6894 : "POS argument (%ld) out of range 0:%ld "
6895 : "in intrinsic %s",
6896 : fold_convert (long_integer_type_node, args[1]),
6897 : fold_convert (long_integer_type_node, nbits),
6898 : iname);
6899 : }
6900 :
6901 306 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6902 : build_int_cst (type, 1), args[1]);
6903 306 : if (set)
6904 : op = BIT_IOR_EXPR;
6905 : else
6906 : {
6907 168 : op = BIT_AND_EXPR;
6908 168 : tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6909 : }
6910 306 : se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6911 306 : }
6912 :
6913 : /* Extract a sequence of bits.
6914 : IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6915 : static void
6916 27 : gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6917 : {
6918 27 : tree args[3];
6919 27 : tree type;
6920 27 : tree tmp;
6921 27 : tree mask;
6922 27 : tree num_bits, cond;
6923 :
6924 27 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
6925 27 : type = TREE_TYPE (args[0]);
6926 :
6927 : /* Optionally generate code for runtime argument check. */
6928 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6929 : {
6930 12 : tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6931 12 : tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6932 12 : tree nbits = build_int_cst (long_integer_type_node,
6933 12 : TYPE_PRECISION (type));
6934 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6935 : logical_type_node, args[1],
6936 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6937 12 : tree above = fold_build2_loc (input_location, GT_EXPR,
6938 : logical_type_node, tmp1, nbits);
6939 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6940 : logical_type_node, below, above);
6941 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6942 : "POS argument (%ld) out of range 0:%ld "
6943 : "in intrinsic IBITS", tmp1, nbits);
6944 12 : below = fold_build2_loc (input_location, LT_EXPR,
6945 : logical_type_node, args[2],
6946 12 : build_int_cst (TREE_TYPE (args[2]), 0));
6947 12 : above = fold_build2_loc (input_location, GT_EXPR,
6948 : logical_type_node, tmp2, nbits);
6949 12 : scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6950 : logical_type_node, below, above);
6951 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6952 : "LEN argument (%ld) out of range 0:%ld "
6953 : "in intrinsic IBITS", tmp2, nbits);
6954 12 : above = fold_build2_loc (input_location, PLUS_EXPR,
6955 : long_integer_type_node, tmp1, tmp2);
6956 12 : scond = fold_build2_loc (input_location, GT_EXPR,
6957 : logical_type_node, above, nbits);
6958 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6959 : "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6960 : "in intrinsic IBITS", tmp1, tmp2, nbits);
6961 : }
6962 :
6963 : /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6964 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6965 : special case. See also gfc_conv_intrinsic_ishft (). */
6966 27 : num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
6967 :
6968 27 : mask = build_int_cst (type, -1);
6969 27 : mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6970 27 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
6971 : num_bits);
6972 27 : mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
6973 : build_int_cst (type, 0), mask);
6974 27 : mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6975 :
6976 27 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6977 :
6978 27 : se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6979 27 : }
6980 :
6981 : static void
6982 492 : gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6983 : bool arithmetic)
6984 : {
6985 492 : tree args[2], type, num_bits, cond;
6986 492 : tree bigshift;
6987 492 : bool do_convert = false;
6988 :
6989 492 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6990 :
6991 492 : args[0] = gfc_evaluate_now (args[0], &se->pre);
6992 492 : args[1] = gfc_evaluate_now (args[1], &se->pre);
6993 492 : type = TREE_TYPE (args[0]);
6994 :
6995 492 : if (!arithmetic)
6996 : {
6997 390 : args[0] = fold_convert (unsigned_type_for (type), args[0]);
6998 390 : do_convert = true;
6999 : }
7000 : else
7001 102 : gcc_assert (right_shift);
7002 :
7003 492 : if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED)
7004 : {
7005 30 : do_convert = true;
7006 30 : args[0] = fold_convert (signed_type_for (type), args[0]);
7007 : }
7008 :
7009 816 : se->expr = fold_build2_loc (input_location,
7010 : right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
7011 492 : TREE_TYPE (args[0]), args[0], args[1]);
7012 :
7013 492 : if (do_convert)
7014 420 : se->expr = fold_convert (type, se->expr);
7015 :
7016 492 : if (!arithmetic)
7017 390 : bigshift = build_int_cst (type, 0);
7018 : else
7019 : {
7020 102 : tree nonneg = fold_build2_loc (input_location, GE_EXPR,
7021 : logical_type_node, args[0],
7022 102 : build_int_cst (TREE_TYPE (args[0]), 0));
7023 102 : bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
7024 : build_int_cst (type, 0),
7025 : build_int_cst (type, -1));
7026 : }
7027 :
7028 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7029 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7030 : special case. */
7031 492 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7032 :
7033 : /* Optionally generate code for runtime argument check. */
7034 492 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7035 : {
7036 30 : tree below = fold_build2_loc (input_location, LT_EXPR,
7037 : logical_type_node, args[1],
7038 30 : build_int_cst (TREE_TYPE (args[1]), 0));
7039 30 : tree above = fold_build2_loc (input_location, GT_EXPR,
7040 : logical_type_node, args[1], num_bits);
7041 30 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7042 : logical_type_node, below, above);
7043 30 : size_t len_name = strlen (expr->value.function.isym->name);
7044 30 : char *name = XALLOCAVEC (char, len_name + 1);
7045 210 : for (size_t i = 0; i < len_name; i++)
7046 180 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
7047 30 : name[len_name] = '\0';
7048 30 : tree iname = gfc_build_addr_expr (pchar_type_node,
7049 : gfc_build_cstring_const (name));
7050 30 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7051 : "SHIFT argument (%ld) out of range 0:%ld "
7052 : "in intrinsic %s",
7053 : fold_convert (long_integer_type_node, args[1]),
7054 : fold_convert (long_integer_type_node, num_bits),
7055 : iname);
7056 : }
7057 :
7058 492 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7059 : args[1], num_bits);
7060 :
7061 492 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7062 : bigshift, se->expr);
7063 492 : }
7064 :
7065 : /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
7066 : ? 0
7067 : : ((shift >= 0) ? i << shift : i >> -shift)
7068 : where all shifts are logical shifts. */
7069 : static void
7070 318 : gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
7071 : {
7072 318 : tree args[2];
7073 318 : tree type;
7074 318 : tree utype;
7075 318 : tree tmp;
7076 318 : tree width;
7077 318 : tree num_bits;
7078 318 : tree cond;
7079 318 : tree lshift;
7080 318 : tree rshift;
7081 :
7082 318 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7083 :
7084 318 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7085 318 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7086 :
7087 318 : type = TREE_TYPE (args[0]);
7088 318 : utype = unsigned_type_for (type);
7089 :
7090 318 : width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
7091 : args[1]);
7092 :
7093 : /* Left shift if positive. */
7094 318 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
7095 :
7096 : /* Right shift if negative.
7097 : We convert to an unsigned type because we want a logical shift.
7098 : The standard doesn't define the case of shifting negative
7099 : numbers, and we try to be compatible with other compilers, most
7100 : notably g77, here. */
7101 318 : rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
7102 : utype, convert (utype, args[0]), width));
7103 :
7104 318 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
7105 318 : build_int_cst (TREE_TYPE (args[1]), 0));
7106 318 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
7107 :
7108 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7109 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7110 : special case. */
7111 318 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7112 :
7113 : /* Optionally generate code for runtime argument check. */
7114 318 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7115 : {
7116 24 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7117 : logical_type_node, width, num_bits);
7118 24 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7119 : "SHIFT argument (%ld) out of range -%ld:%ld "
7120 : "in intrinsic ISHFT",
7121 : fold_convert (long_integer_type_node, args[1]),
7122 : fold_convert (long_integer_type_node, num_bits),
7123 : fold_convert (long_integer_type_node, num_bits));
7124 : }
7125 :
7126 318 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
7127 : num_bits);
7128 318 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7129 : build_int_cst (type, 0), tmp);
7130 318 : }
7131 :
7132 :
7133 : /* Circular shift. AKA rotate or barrel shift. */
7134 :
7135 : static void
7136 658 : gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
7137 : {
7138 658 : tree *args;
7139 658 : tree type;
7140 658 : tree tmp;
7141 658 : tree lrot;
7142 658 : tree rrot;
7143 658 : tree zero;
7144 658 : tree nbits;
7145 658 : unsigned int num_args;
7146 :
7147 658 : num_args = gfc_intrinsic_argument_list_length (expr);
7148 658 : args = XALLOCAVEC (tree, num_args);
7149 :
7150 658 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7151 :
7152 658 : type = TREE_TYPE (args[0]);
7153 658 : nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
7154 :
7155 658 : if (num_args == 3)
7156 : {
7157 550 : gfc_expr *size = expr->value.function.actual->next->next->expr;
7158 :
7159 : /* Use a library function for the 3 parameter version. */
7160 550 : tree int4type = gfc_get_int_type (4);
7161 :
7162 : /* Treat optional SIZE argument when it is passed as an optional
7163 : dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
7164 550 : if (size->expr_type == EXPR_VARIABLE
7165 438 : && size->symtree->n.sym->attr.dummy
7166 36 : && size->symtree->n.sym->attr.optional)
7167 : {
7168 36 : tree type_of_size = TREE_TYPE (args[2]);
7169 72 : args[2] = build3_loc (input_location, COND_EXPR, type_of_size,
7170 36 : gfc_conv_expr_present (size->symtree->n.sym),
7171 : args[2], fold_convert (type_of_size, nbits));
7172 : }
7173 :
7174 : /* We convert the first argument to at least 4 bytes, and
7175 : convert back afterwards. This removes the need for library
7176 : functions for all argument sizes, and function will be
7177 : aligned to at least 32 bits, so there's no loss. */
7178 550 : if (expr->ts.kind < 4)
7179 242 : args[0] = convert (int4type, args[0]);
7180 :
7181 : /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
7182 : need loads of library functions. They cannot have values >
7183 : BIT_SIZE (I) so the conversion is safe. */
7184 550 : args[1] = convert (int4type, args[1]);
7185 550 : args[2] = convert (int4type, args[2]);
7186 :
7187 : /* Optionally generate code for runtime argument check. */
7188 550 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7189 : {
7190 18 : tree size = fold_convert (long_integer_type_node, args[2]);
7191 18 : tree below = fold_build2_loc (input_location, LE_EXPR,
7192 : logical_type_node, size,
7193 18 : build_int_cst (TREE_TYPE (args[1]), 0));
7194 18 : tree above = fold_build2_loc (input_location, GT_EXPR,
7195 : logical_type_node, size, nbits);
7196 18 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7197 : logical_type_node, below, above);
7198 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7199 : "SIZE argument (%ld) out of range 1:%ld "
7200 : "in intrinsic ISHFTC", size, nbits);
7201 18 : tree width = fold_convert (long_integer_type_node, args[1]);
7202 18 : width = fold_build1_loc (input_location, ABS_EXPR,
7203 : long_integer_type_node, width);
7204 18 : scond = fold_build2_loc (input_location, GT_EXPR,
7205 : logical_type_node, width, size);
7206 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7207 : "SHIFT argument (%ld) out of range -%ld:%ld "
7208 : "in intrinsic ISHFTC",
7209 : fold_convert (long_integer_type_node, args[1]),
7210 : size, size);
7211 : }
7212 :
7213 550 : switch (expr->ts.kind)
7214 : {
7215 426 : case 1:
7216 426 : case 2:
7217 426 : case 4:
7218 426 : tmp = gfor_fndecl_math_ishftc4;
7219 426 : break;
7220 124 : case 8:
7221 124 : tmp = gfor_fndecl_math_ishftc8;
7222 124 : break;
7223 0 : case 16:
7224 0 : tmp = gfor_fndecl_math_ishftc16;
7225 0 : break;
7226 0 : default:
7227 0 : gcc_unreachable ();
7228 : }
7229 550 : se->expr = build_call_expr_loc (input_location,
7230 : tmp, 3, args[0], args[1], args[2]);
7231 : /* Convert the result back to the original type, if we extended
7232 : the first argument's width above. */
7233 550 : if (expr->ts.kind < 4)
7234 242 : se->expr = convert (type, se->expr);
7235 :
7236 550 : return;
7237 : }
7238 :
7239 : /* Evaluate arguments only once. */
7240 108 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7241 108 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7242 :
7243 : /* Optionally generate code for runtime argument check. */
7244 108 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7245 : {
7246 12 : tree width = fold_convert (long_integer_type_node, args[1]);
7247 12 : width = fold_build1_loc (input_location, ABS_EXPR,
7248 : long_integer_type_node, width);
7249 12 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7250 : logical_type_node, width, nbits);
7251 12 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7252 : "SHIFT argument (%ld) out of range -%ld:%ld "
7253 : "in intrinsic ISHFTC",
7254 : fold_convert (long_integer_type_node, args[1]),
7255 : nbits, nbits);
7256 : }
7257 :
7258 : /* Rotate left if positive. */
7259 108 : lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
7260 :
7261 : /* Rotate right if negative. */
7262 108 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
7263 : args[1]);
7264 108 : rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
7265 :
7266 108 : zero = build_int_cst (TREE_TYPE (args[1]), 0);
7267 108 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
7268 : zero);
7269 108 : rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
7270 :
7271 : /* Do nothing if shift == 0. */
7272 108 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
7273 : zero);
7274 108 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
7275 : rrot);
7276 : }
7277 :
7278 :
7279 : /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7280 : : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7281 :
7282 : The conditional expression is necessary because the result of LEADZ(0)
7283 : is defined, but the result of __builtin_clz(0) is undefined for most
7284 : targets.
7285 :
7286 : For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7287 : difference in bit size between the argument of LEADZ and the C int. */
7288 :
7289 : static void
7290 270 : gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7291 : {
7292 270 : tree arg;
7293 270 : tree arg_type;
7294 270 : tree cond;
7295 270 : tree result_type;
7296 270 : tree leadz;
7297 270 : tree bit_size;
7298 270 : tree tmp;
7299 270 : tree func;
7300 270 : int s, argsize;
7301 :
7302 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7303 270 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7304 :
7305 : /* Which variant of __builtin_clz* should we call? */
7306 270 : if (argsize <= INT_TYPE_SIZE)
7307 : {
7308 183 : arg_type = unsigned_type_node;
7309 183 : func = builtin_decl_explicit (BUILT_IN_CLZ);
7310 : }
7311 87 : else if (argsize <= LONG_TYPE_SIZE)
7312 : {
7313 57 : arg_type = long_unsigned_type_node;
7314 57 : func = builtin_decl_explicit (BUILT_IN_CLZL);
7315 : }
7316 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7317 : {
7318 0 : arg_type = long_long_unsigned_type_node;
7319 0 : func = builtin_decl_explicit (BUILT_IN_CLZLL);
7320 : }
7321 : else
7322 : {
7323 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7324 30 : arg_type = gfc_build_uint_type (argsize);
7325 30 : func = NULL_TREE;
7326 : }
7327 :
7328 : /* Convert the actual argument twice: first, to the unsigned type of the
7329 : same size; then, to the proper argument type for the built-in
7330 : function. But the return type is of the default INTEGER kind. */
7331 270 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7332 270 : arg = fold_convert (arg_type, arg);
7333 270 : arg = gfc_evaluate_now (arg, &se->pre);
7334 270 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7335 :
7336 : /* Compute LEADZ for the case i .ne. 0. */
7337 270 : if (func)
7338 : {
7339 240 : s = TYPE_PRECISION (arg_type) - argsize;
7340 240 : tmp = fold_convert (result_type,
7341 : build_call_expr_loc (input_location, func,
7342 : 1, arg));
7343 240 : leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7344 240 : tmp, build_int_cst (result_type, s));
7345 : }
7346 : else
7347 : {
7348 : /* We end up here if the argument type is larger than 'long long'.
7349 : We generate this code:
7350 :
7351 : if (x & (ULL_MAX << ULL_SIZE) != 0)
7352 : return clzll ((unsigned long long) (x >> ULLSIZE));
7353 : else
7354 : return ULL_SIZE + clzll ((unsigned long long) x);
7355 : where ULL_MAX is the largest value that a ULL_MAX can hold
7356 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7357 : is the bit-size of the long long type (64 in this example). */
7358 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7359 :
7360 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7361 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7362 : long_long_unsigned_type_node,
7363 : build_int_cst (long_long_unsigned_type_node,
7364 : 0));
7365 :
7366 30 : cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7367 : fold_convert (arg_type, ullmax), ullsize);
7368 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7369 : arg, cond);
7370 30 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7371 : cond, build_int_cst (arg_type, 0));
7372 :
7373 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7374 : arg, ullsize);
7375 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7376 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7377 30 : tmp1 = fold_convert (result_type,
7378 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7379 :
7380 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7381 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7382 30 : tmp2 = fold_convert (result_type,
7383 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7384 30 : tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7385 : tmp2, ullsize);
7386 :
7387 30 : leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7388 : cond, tmp1, tmp2);
7389 : }
7390 :
7391 : /* Build BIT_SIZE. */
7392 270 : bit_size = build_int_cst (result_type, argsize);
7393 :
7394 270 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7395 : arg, build_int_cst (arg_type, 0));
7396 270 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7397 : bit_size, leadz);
7398 270 : }
7399 :
7400 :
7401 : /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7402 :
7403 : The conditional expression is necessary because the result of TRAILZ(0)
7404 : is defined, but the result of __builtin_ctz(0) is undefined for most
7405 : targets. */
7406 :
7407 : static void
7408 282 : gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7409 : {
7410 282 : tree arg;
7411 282 : tree arg_type;
7412 282 : tree cond;
7413 282 : tree result_type;
7414 282 : tree trailz;
7415 282 : tree bit_size;
7416 282 : tree func;
7417 282 : int argsize;
7418 :
7419 282 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7420 282 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7421 :
7422 : /* Which variant of __builtin_ctz* should we call? */
7423 282 : if (argsize <= INT_TYPE_SIZE)
7424 : {
7425 195 : arg_type = unsigned_type_node;
7426 195 : func = builtin_decl_explicit (BUILT_IN_CTZ);
7427 : }
7428 87 : else if (argsize <= LONG_TYPE_SIZE)
7429 : {
7430 57 : arg_type = long_unsigned_type_node;
7431 57 : func = builtin_decl_explicit (BUILT_IN_CTZL);
7432 : }
7433 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7434 : {
7435 0 : arg_type = long_long_unsigned_type_node;
7436 0 : func = builtin_decl_explicit (BUILT_IN_CTZLL);
7437 : }
7438 : else
7439 : {
7440 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7441 30 : arg_type = gfc_build_uint_type (argsize);
7442 30 : func = NULL_TREE;
7443 : }
7444 :
7445 : /* Convert the actual argument twice: first, to the unsigned type of the
7446 : same size; then, to the proper argument type for the built-in
7447 : function. But the return type is of the default INTEGER kind. */
7448 282 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7449 282 : arg = fold_convert (arg_type, arg);
7450 282 : arg = gfc_evaluate_now (arg, &se->pre);
7451 282 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7452 :
7453 : /* Compute TRAILZ for the case i .ne. 0. */
7454 282 : if (func)
7455 252 : trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7456 : func, 1, arg));
7457 : else
7458 : {
7459 : /* We end up here if the argument type is larger than 'long long'.
7460 : We generate this code:
7461 :
7462 : if ((x & ULL_MAX) == 0)
7463 : return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7464 : else
7465 : return ctzll ((unsigned long long) x);
7466 :
7467 : where ULL_MAX is the largest value that a ULL_MAX can hold
7468 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7469 : is the bit-size of the long long type (64 in this example). */
7470 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7471 :
7472 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7473 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7474 : long_long_unsigned_type_node,
7475 : build_int_cst (long_long_unsigned_type_node, 0));
7476 :
7477 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7478 : fold_convert (arg_type, ullmax));
7479 30 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7480 : build_int_cst (arg_type, 0));
7481 :
7482 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7483 : arg, ullsize);
7484 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7485 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7486 30 : tmp1 = fold_convert (result_type,
7487 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7488 30 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7489 : tmp1, ullsize);
7490 :
7491 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7492 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7493 30 : tmp2 = fold_convert (result_type,
7494 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7495 :
7496 30 : trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7497 : cond, tmp1, tmp2);
7498 : }
7499 :
7500 : /* Build BIT_SIZE. */
7501 282 : bit_size = build_int_cst (result_type, argsize);
7502 :
7503 282 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7504 : arg, build_int_cst (arg_type, 0));
7505 282 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7506 : bit_size, trailz);
7507 282 : }
7508 :
7509 : /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7510 : for types larger than "long long", we call the long long built-in for
7511 : the lower and higher bits and combine the result. */
7512 :
7513 : static void
7514 134 : gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7515 : {
7516 134 : tree arg;
7517 134 : tree arg_type;
7518 134 : tree result_type;
7519 134 : tree func;
7520 134 : int argsize;
7521 :
7522 134 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7523 134 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7524 134 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7525 :
7526 : /* Which variant of the builtin should we call? */
7527 134 : if (argsize <= INT_TYPE_SIZE)
7528 : {
7529 108 : arg_type = unsigned_type_node;
7530 198 : func = builtin_decl_explicit (parity
7531 : ? BUILT_IN_PARITY
7532 : : BUILT_IN_POPCOUNT);
7533 : }
7534 26 : else if (argsize <= LONG_TYPE_SIZE)
7535 : {
7536 12 : arg_type = long_unsigned_type_node;
7537 18 : func = builtin_decl_explicit (parity
7538 : ? BUILT_IN_PARITYL
7539 : : BUILT_IN_POPCOUNTL);
7540 : }
7541 14 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7542 : {
7543 0 : arg_type = long_long_unsigned_type_node;
7544 0 : func = builtin_decl_explicit (parity
7545 : ? BUILT_IN_PARITYLL
7546 : : BUILT_IN_POPCOUNTLL);
7547 : }
7548 : else
7549 : {
7550 : /* Our argument type is larger than 'long long', which mean none
7551 : of the POPCOUNT builtins covers it. We thus call the 'long long'
7552 : variant multiple times, and add the results. */
7553 14 : tree utype, arg2, call1, call2;
7554 :
7555 : /* For now, we only cover the case where argsize is twice as large
7556 : as 'long long'. */
7557 14 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7558 :
7559 21 : func = builtin_decl_explicit (parity
7560 : ? BUILT_IN_PARITYLL
7561 : : BUILT_IN_POPCOUNTLL);
7562 :
7563 : /* Convert it to an integer, and store into a variable. */
7564 14 : utype = gfc_build_uint_type (argsize);
7565 14 : arg = fold_convert (utype, arg);
7566 14 : arg = gfc_evaluate_now (arg, &se->pre);
7567 :
7568 : /* Call the builtin twice. */
7569 14 : call1 = build_call_expr_loc (input_location, func, 1,
7570 : fold_convert (long_long_unsigned_type_node,
7571 : arg));
7572 :
7573 14 : arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7574 : build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7575 14 : call2 = build_call_expr_loc (input_location, func, 1,
7576 : fold_convert (long_long_unsigned_type_node,
7577 : arg2));
7578 :
7579 : /* Combine the results. */
7580 14 : if (parity)
7581 7 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7582 : integer_type_node, call1, call2);
7583 : else
7584 7 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7585 : integer_type_node, call1, call2);
7586 :
7587 14 : se->expr = convert (result_type, se->expr);
7588 14 : return;
7589 : }
7590 :
7591 : /* Convert the actual argument twice: first, to the unsigned type of the
7592 : same size; then, to the proper argument type for the built-in
7593 : function. */
7594 120 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7595 120 : arg = fold_convert (arg_type, arg);
7596 :
7597 120 : se->expr = fold_convert (result_type,
7598 : build_call_expr_loc (input_location, func, 1, arg));
7599 : }
7600 :
7601 :
7602 : /* Process an intrinsic with unspecified argument-types that has an optional
7603 : argument (which could be of type character), e.g. EOSHIFT. For those, we
7604 : need to append the string length of the optional argument if it is not
7605 : present and the type is really character.
7606 : primary specifies the position (starting at 1) of the non-optional argument
7607 : specifying the type and optional gives the position of the optional
7608 : argument in the arglist. */
7609 :
7610 : static void
7611 5843 : conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7612 : unsigned primary, unsigned optional)
7613 : {
7614 5843 : gfc_actual_arglist* prim_arg;
7615 5843 : gfc_actual_arglist* opt_arg;
7616 5843 : unsigned cur_pos;
7617 5843 : gfc_actual_arglist* arg;
7618 5843 : gfc_symbol* sym;
7619 5843 : vec<tree, va_gc> *append_args;
7620 :
7621 : /* Find the two arguments given as position. */
7622 5843 : cur_pos = 0;
7623 5843 : prim_arg = NULL;
7624 5843 : opt_arg = NULL;
7625 17529 : for (arg = expr->value.function.actual; arg; arg = arg->next)
7626 : {
7627 17529 : ++cur_pos;
7628 :
7629 17529 : if (cur_pos == primary)
7630 5843 : prim_arg = arg;
7631 17529 : if (cur_pos == optional)
7632 5843 : opt_arg = arg;
7633 :
7634 17529 : if (cur_pos >= primary && cur_pos >= optional)
7635 : break;
7636 : }
7637 5843 : gcc_assert (prim_arg);
7638 5843 : gcc_assert (prim_arg->expr);
7639 5843 : gcc_assert (opt_arg);
7640 :
7641 : /* If we do have type CHARACTER and the optional argument is really absent,
7642 : append a dummy 0 as string length. */
7643 5843 : append_args = NULL;
7644 5843 : if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7645 : {
7646 608 : tree dummy;
7647 :
7648 608 : dummy = build_int_cst (gfc_charlen_type_node, 0);
7649 608 : vec_alloc (append_args, 1);
7650 608 : append_args->quick_push (dummy);
7651 : }
7652 :
7653 : /* Build the call itself. */
7654 5843 : gcc_assert (!se->ignore_optional);
7655 5843 : sym = gfc_get_symbol_for_expr (expr, false);
7656 5843 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7657 : append_args);
7658 5843 : gfc_free_symbol (sym);
7659 5843 : }
7660 :
7661 : /* The length of a character string. */
7662 : static void
7663 5873 : gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7664 : {
7665 5873 : tree len;
7666 5873 : tree type;
7667 5873 : tree decl;
7668 5873 : gfc_symbol *sym;
7669 5873 : gfc_se argse;
7670 5873 : gfc_expr *arg;
7671 :
7672 5873 : gcc_assert (!se->ss);
7673 :
7674 5873 : arg = expr->value.function.actual->expr;
7675 :
7676 5873 : type = gfc_typenode_for_spec (&expr->ts);
7677 5873 : switch (arg->expr_type)
7678 : {
7679 0 : case EXPR_CONSTANT:
7680 0 : len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7681 0 : break;
7682 :
7683 2 : case EXPR_ARRAY:
7684 : /* If there is an explicit type-spec, use it. */
7685 2 : if (arg->ts.u.cl->length && arg->ts.u.cl->length_from_typespec)
7686 : {
7687 0 : gfc_conv_string_length (arg->ts.u.cl, arg, &se->pre);
7688 0 : len = arg->ts.u.cl->backend_decl;
7689 0 : break;
7690 : }
7691 :
7692 : /* Obtain the string length from the function used by
7693 : trans-array.cc(gfc_trans_array_constructor). */
7694 2 : len = NULL_TREE;
7695 2 : get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7696 2 : break;
7697 :
7698 5286 : case EXPR_VARIABLE:
7699 5286 : if (arg->ref == NULL
7700 2397 : || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7701 : {
7702 : /* This doesn't catch all cases.
7703 : See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7704 : and the surrounding thread. */
7705 4754 : sym = arg->symtree->n.sym;
7706 4754 : decl = gfc_get_symbol_decl (sym);
7707 4754 : if (decl == current_function_decl && sym->attr.function
7708 55 : && (sym->result == sym))
7709 55 : decl = gfc_get_fake_result_decl (sym, 0);
7710 :
7711 4754 : len = sym->ts.u.cl->backend_decl;
7712 4754 : gcc_assert (len);
7713 : break;
7714 : }
7715 :
7716 : /* Fall through. */
7717 :
7718 1117 : default:
7719 1117 : gfc_init_se (&argse, se);
7720 1117 : if (arg->rank == 0)
7721 995 : gfc_conv_expr (&argse, arg);
7722 : else
7723 122 : gfc_conv_expr_descriptor (&argse, arg);
7724 1117 : gfc_add_block_to_block (&se->pre, &argse.pre);
7725 1117 : gfc_add_block_to_block (&se->post, &argse.post);
7726 1117 : len = argse.string_length;
7727 1117 : break;
7728 : }
7729 5873 : se->expr = convert (type, len);
7730 5873 : }
7731 :
7732 : /* The length of a character string not including trailing blanks. */
7733 : static void
7734 2340 : gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7735 : {
7736 2340 : int kind = expr->value.function.actual->expr->ts.kind;
7737 2340 : tree args[2], type, fndecl;
7738 :
7739 2340 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7740 2340 : type = gfc_typenode_for_spec (&expr->ts);
7741 :
7742 2340 : if (kind == 1)
7743 1938 : fndecl = gfor_fndecl_string_len_trim;
7744 402 : else if (kind == 4)
7745 402 : fndecl = gfor_fndecl_string_len_trim_char4;
7746 : else
7747 0 : gcc_unreachable ();
7748 :
7749 2340 : se->expr = build_call_expr_loc (input_location,
7750 : fndecl, 2, args[0], args[1]);
7751 2340 : se->expr = convert (type, se->expr);
7752 2340 : }
7753 :
7754 :
7755 : /* Returns the starting position of a substring within a string. */
7756 :
7757 : static void
7758 751 : gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7759 : tree function)
7760 : {
7761 751 : tree logical4_type_node = gfc_get_logical_type (4);
7762 751 : tree type;
7763 751 : tree fndecl;
7764 751 : tree *args;
7765 751 : unsigned int num_args;
7766 :
7767 751 : args = XALLOCAVEC (tree, 5);
7768 :
7769 : /* Get number of arguments; characters count double due to the
7770 : string length argument. Kind= is not passed to the library
7771 : and thus ignored. */
7772 751 : if (expr->value.function.actual->next->next->expr == NULL)
7773 : num_args = 4;
7774 : else
7775 304 : num_args = 5;
7776 :
7777 751 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7778 751 : type = gfc_typenode_for_spec (&expr->ts);
7779 :
7780 751 : if (num_args == 4)
7781 447 : args[4] = build_int_cst (logical4_type_node, 0);
7782 : else
7783 304 : args[4] = convert (logical4_type_node, args[4]);
7784 :
7785 751 : fndecl = build_addr (function);
7786 751 : se->expr = build_call_array_loc (input_location,
7787 751 : TREE_TYPE (TREE_TYPE (function)), fndecl,
7788 : 5, args);
7789 751 : se->expr = convert (type, se->expr);
7790 :
7791 751 : }
7792 :
7793 : /* The ascii value for a single character. */
7794 : static void
7795 2033 : gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7796 : {
7797 2033 : tree args[3], type, pchartype;
7798 2033 : int nargs;
7799 :
7800 2033 : nargs = gfc_intrinsic_argument_list_length (expr);
7801 2033 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7802 2033 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7803 2033 : pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7804 2033 : args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7805 2033 : type = gfc_typenode_for_spec (&expr->ts);
7806 :
7807 2033 : se->expr = build_fold_indirect_ref_loc (input_location,
7808 : args[1]);
7809 2033 : se->expr = convert (type, se->expr);
7810 2033 : }
7811 :
7812 :
7813 : /* Intrinsic ISNAN calls __builtin_isnan. */
7814 :
7815 : static void
7816 432 : gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7817 : {
7818 432 : tree arg;
7819 :
7820 432 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7821 432 : se->expr = build_call_expr_loc (input_location,
7822 : builtin_decl_explicit (BUILT_IN_ISNAN),
7823 : 1, arg);
7824 864 : STRIP_TYPE_NOPS (se->expr);
7825 432 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7826 432 : }
7827 :
7828 :
7829 : /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7830 : their argument against a constant integer value. */
7831 :
7832 : static void
7833 24 : gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7834 : {
7835 24 : tree arg;
7836 :
7837 24 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7838 24 : se->expr = fold_build2_loc (input_location, EQ_EXPR,
7839 : gfc_typenode_for_spec (&expr->ts),
7840 24 : arg, build_int_cst (TREE_TYPE (arg), value));
7841 24 : }
7842 :
7843 :
7844 :
7845 : /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7846 :
7847 : static void
7848 949 : gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7849 : {
7850 949 : tree tsource;
7851 949 : tree fsource;
7852 949 : tree mask;
7853 949 : tree type;
7854 949 : tree len, len2;
7855 949 : tree *args;
7856 949 : unsigned int num_args;
7857 :
7858 949 : num_args = gfc_intrinsic_argument_list_length (expr);
7859 949 : args = XALLOCAVEC (tree, num_args);
7860 :
7861 949 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7862 949 : if (expr->ts.type != BT_CHARACTER)
7863 : {
7864 422 : tsource = args[0];
7865 422 : fsource = args[1];
7866 422 : mask = args[2];
7867 : }
7868 : else
7869 : {
7870 : /* We do the same as in the non-character case, but the argument
7871 : list is different because of the string length arguments. We
7872 : also have to set the string length for the result. */
7873 527 : len = args[0];
7874 527 : tsource = args[1];
7875 527 : len2 = args[2];
7876 527 : fsource = args[3];
7877 527 : mask = args[4];
7878 :
7879 527 : gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7880 : &se->pre);
7881 527 : se->string_length = len;
7882 : }
7883 949 : tsource = gfc_evaluate_now (tsource, &se->pre);
7884 949 : fsource = gfc_evaluate_now (fsource, &se->pre);
7885 949 : mask = gfc_evaluate_now (mask, &se->pre);
7886 949 : type = TREE_TYPE (tsource);
7887 949 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7888 : fold_convert (type, fsource));
7889 949 : }
7890 :
7891 :
7892 : /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7893 :
7894 : static void
7895 42 : gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7896 : {
7897 42 : tree args[3], mask, type;
7898 :
7899 42 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
7900 42 : mask = gfc_evaluate_now (args[2], &se->pre);
7901 :
7902 42 : type = TREE_TYPE (args[0]);
7903 42 : gcc_assert (TREE_TYPE (args[1]) == type);
7904 42 : gcc_assert (TREE_TYPE (mask) == type);
7905 :
7906 42 : args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7907 42 : args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7908 : fold_build1_loc (input_location, BIT_NOT_EXPR,
7909 : type, mask));
7910 42 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7911 : args[0], args[1]);
7912 42 : }
7913 :
7914 :
7915 : /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7916 : MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7917 :
7918 : static void
7919 64 : gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7920 : {
7921 64 : tree arg, allones, type, utype, res, cond, bitsize;
7922 64 : int i;
7923 :
7924 64 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7925 64 : arg = gfc_evaluate_now (arg, &se->pre);
7926 :
7927 64 : type = gfc_get_int_type (expr->ts.kind);
7928 64 : utype = unsigned_type_for (type);
7929 :
7930 64 : i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7931 64 : bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7932 :
7933 64 : allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7934 : build_int_cst (utype, 0));
7935 :
7936 64 : if (left)
7937 : {
7938 : /* Left-justified mask. */
7939 32 : res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7940 : bitsize, arg);
7941 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7942 : fold_convert (utype, res));
7943 :
7944 : /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7945 : smaller than type width. */
7946 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7947 32 : build_int_cst (TREE_TYPE (arg), 0));
7948 32 : res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7949 : build_int_cst (utype, 0), res);
7950 : }
7951 : else
7952 : {
7953 : /* Right-justified mask. */
7954 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7955 : fold_convert (utype, arg));
7956 32 : res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7957 :
7958 : /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7959 : strictly smaller than type width. */
7960 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7961 : arg, bitsize);
7962 32 : res = fold_build3_loc (input_location, COND_EXPR, utype,
7963 : cond, allones, res);
7964 : }
7965 :
7966 64 : se->expr = fold_convert (type, res);
7967 64 : }
7968 :
7969 :
7970 : /* FRACTION (s) is translated into:
7971 : isfinite (s) ? frexp (s, &dummy_int) : NaN */
7972 : static void
7973 60 : gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7974 : {
7975 60 : tree arg, type, tmp, res, frexp, cond;
7976 :
7977 60 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7978 :
7979 60 : type = gfc_typenode_for_spec (&expr->ts);
7980 60 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7981 60 : arg = gfc_evaluate_now (arg, &se->pre);
7982 :
7983 60 : cond = build_call_expr_loc (input_location,
7984 : builtin_decl_explicit (BUILT_IN_ISFINITE),
7985 : 1, arg);
7986 :
7987 60 : tmp = gfc_create_var (integer_type_node, NULL);
7988 60 : res = build_call_expr_loc (input_location, frexp, 2,
7989 : fold_convert (type, arg),
7990 : gfc_build_addr_expr (NULL_TREE, tmp));
7991 60 : res = fold_convert (type, res);
7992 :
7993 60 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7994 : cond, res, gfc_build_nan (type, ""));
7995 60 : }
7996 :
7997 :
7998 : /* NEAREST (s, dir) is translated into
7999 : tmp = copysign (HUGE_VAL, dir);
8000 : return nextafter (s, tmp);
8001 : */
8002 : static void
8003 1595 : gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
8004 : {
8005 1595 : tree args[2], type, tmp, nextafter, copysign, huge_val;
8006 :
8007 1595 : nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
8008 1595 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
8009 :
8010 1595 : type = gfc_typenode_for_spec (&expr->ts);
8011 1595 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8012 :
8013 1595 : huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
8014 1595 : tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
8015 : fold_convert (type, args[1]));
8016 1595 : se->expr = build_call_expr_loc (input_location, nextafter, 2,
8017 : fold_convert (type, args[0]), tmp);
8018 1595 : se->expr = fold_convert (type, se->expr);
8019 1595 : }
8020 :
8021 :
8022 : /* SPACING (s) is translated into
8023 : int e;
8024 : if (!isfinite (s))
8025 : res = NaN;
8026 : else if (s == 0)
8027 : res = tiny;
8028 : else
8029 : {
8030 : frexp (s, &e);
8031 : e = e - prec;
8032 : e = MAX_EXPR (e, emin);
8033 : res = scalbn (1., e);
8034 : }
8035 : return res;
8036 :
8037 : where prec is the precision of s, gfc_real_kinds[k].digits,
8038 : emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
8039 : and tiny is tiny(s), gfc_real_kinds[k].tiny. */
8040 :
8041 : static void
8042 70 : gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
8043 : {
8044 70 : tree arg, type, prec, emin, tiny, res, e;
8045 70 : tree cond, nan, tmp, frexp, scalbn;
8046 70 : int k;
8047 70 : stmtblock_t block;
8048 :
8049 70 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8050 70 : prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
8051 70 : emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
8052 70 : tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
8053 :
8054 70 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8055 70 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8056 :
8057 70 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8058 70 : arg = gfc_evaluate_now (arg, &se->pre);
8059 :
8060 70 : type = gfc_typenode_for_spec (&expr->ts);
8061 70 : e = gfc_create_var (integer_type_node, NULL);
8062 70 : res = gfc_create_var (type, NULL);
8063 :
8064 :
8065 : /* Build the block for s /= 0. */
8066 70 : gfc_start_block (&block);
8067 70 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8068 : gfc_build_addr_expr (NULL_TREE, e));
8069 70 : gfc_add_expr_to_block (&block, tmp);
8070 :
8071 70 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
8072 : prec);
8073 70 : gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
8074 : integer_type_node, tmp, emin));
8075 :
8076 70 : tmp = build_call_expr_loc (input_location, scalbn, 2,
8077 70 : build_real_from_int_cst (type, integer_one_node), e);
8078 70 : gfc_add_modify (&block, res, tmp);
8079 :
8080 : /* Finish by building the IF statement for value zero. */
8081 70 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8082 70 : build_real_from_int_cst (type, integer_zero_node));
8083 70 : tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
8084 : gfc_finish_block (&block));
8085 :
8086 : /* And deal with infinities and NaNs. */
8087 70 : cond = build_call_expr_loc (input_location,
8088 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8089 : 1, arg);
8090 70 : nan = gfc_build_nan (type, "");
8091 70 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
8092 :
8093 70 : gfc_add_expr_to_block (&se->pre, tmp);
8094 70 : se->expr = res;
8095 70 : }
8096 :
8097 :
8098 : /* RRSPACING (s) is translated into
8099 : int e;
8100 : real x;
8101 : x = fabs (s);
8102 : if (isfinite (x))
8103 : {
8104 : if (x != 0)
8105 : {
8106 : frexp (s, &e);
8107 : x = scalbn (x, precision - e);
8108 : }
8109 : }
8110 : else
8111 : x = NaN;
8112 : return x;
8113 :
8114 : where precision is gfc_real_kinds[k].digits. */
8115 :
8116 : static void
8117 48 : gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
8118 : {
8119 48 : tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
8120 48 : int prec, k;
8121 48 : stmtblock_t block;
8122 :
8123 48 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8124 48 : prec = gfc_real_kinds[k].digits;
8125 :
8126 48 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8127 48 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8128 48 : fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
8129 :
8130 48 : type = gfc_typenode_for_spec (&expr->ts);
8131 48 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8132 48 : arg = gfc_evaluate_now (arg, &se->pre);
8133 :
8134 48 : e = gfc_create_var (integer_type_node, NULL);
8135 48 : x = gfc_create_var (type, NULL);
8136 48 : gfc_add_modify (&se->pre, x,
8137 : build_call_expr_loc (input_location, fabs, 1, arg));
8138 :
8139 :
8140 48 : gfc_start_block (&block);
8141 48 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8142 : gfc_build_addr_expr (NULL_TREE, e));
8143 48 : gfc_add_expr_to_block (&block, tmp);
8144 :
8145 48 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
8146 48 : build_int_cst (integer_type_node, prec), e);
8147 48 : tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
8148 48 : gfc_add_modify (&block, x, tmp);
8149 48 : stmt = gfc_finish_block (&block);
8150 :
8151 : /* if (x != 0) */
8152 48 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
8153 48 : build_real_from_int_cst (type, integer_zero_node));
8154 48 : tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
8155 :
8156 : /* And deal with infinities and NaNs. */
8157 48 : cond = build_call_expr_loc (input_location,
8158 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8159 : 1, x);
8160 48 : nan = gfc_build_nan (type, "");
8161 48 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
8162 :
8163 48 : gfc_add_expr_to_block (&se->pre, tmp);
8164 48 : se->expr = fold_convert (type, x);
8165 48 : }
8166 :
8167 :
8168 : /* SCALE (s, i) is translated into scalbn (s, i). */
8169 : static void
8170 72 : gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
8171 : {
8172 72 : tree args[2], type, scalbn;
8173 :
8174 72 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8175 :
8176 72 : type = gfc_typenode_for_spec (&expr->ts);
8177 72 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8178 72 : se->expr = build_call_expr_loc (input_location, scalbn, 2,
8179 : fold_convert (type, args[0]),
8180 : fold_convert (integer_type_node, args[1]));
8181 72 : se->expr = fold_convert (type, se->expr);
8182 72 : }
8183 :
8184 :
8185 : /* SET_EXPONENT (s, i) is translated into
8186 : isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
8187 : static void
8188 262 : gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
8189 : {
8190 262 : tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
8191 :
8192 262 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8193 262 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8194 :
8195 262 : type = gfc_typenode_for_spec (&expr->ts);
8196 262 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8197 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
8198 :
8199 262 : tmp = gfc_create_var (integer_type_node, NULL);
8200 262 : tmp = build_call_expr_loc (input_location, frexp, 2,
8201 : fold_convert (type, args[0]),
8202 : gfc_build_addr_expr (NULL_TREE, tmp));
8203 262 : res = build_call_expr_loc (input_location, scalbn, 2, tmp,
8204 : fold_convert (integer_type_node, args[1]));
8205 262 : res = fold_convert (type, res);
8206 :
8207 : /* Call to isfinite */
8208 262 : cond = build_call_expr_loc (input_location,
8209 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8210 : 1, args[0]);
8211 262 : nan = gfc_build_nan (type, "");
8212 :
8213 262 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
8214 : res, nan);
8215 262 : }
8216 :
8217 :
8218 : static void
8219 15409 : gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
8220 : {
8221 15409 : gfc_actual_arglist *actual;
8222 15409 : tree arg1;
8223 15409 : tree type;
8224 15409 : tree size;
8225 15409 : gfc_se argse;
8226 15409 : gfc_expr *e;
8227 15409 : gfc_symbol *sym = NULL;
8228 :
8229 15409 : gfc_init_se (&argse, NULL);
8230 15409 : actual = expr->value.function.actual;
8231 :
8232 15409 : if (actual->expr->ts.type == BT_CLASS)
8233 627 : gfc_add_class_array_ref (actual->expr);
8234 :
8235 15409 : e = actual->expr;
8236 :
8237 : /* These are emerging from the interface mapping, when a class valued
8238 : function appears as the rhs in a realloc on assign statement, where
8239 : the size of the result is that of one of the actual arguments. */
8240 15409 : if (e->expr_type == EXPR_VARIABLE
8241 14933 : && e->symtree->n.sym->ns == NULL /* This is distinctive! */
8242 573 : && e->symtree->n.sym->ts.type == BT_CLASS
8243 62 : && e->ref && e->ref->type == REF_COMPONENT
8244 44 : && strcmp (e->ref->u.c.component->name, "_data") == 0)
8245 15409 : sym = e->symtree->n.sym;
8246 :
8247 15409 : if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
8248 : && e
8249 854 : && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
8250 : {
8251 854 : symbol_attribute attr;
8252 854 : char *msg;
8253 854 : tree temp;
8254 854 : tree cond;
8255 :
8256 854 : if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
8257 : {
8258 33 : attr = CLASS_DATA (e->symtree->n.sym)->attr;
8259 33 : attr.pointer = attr.class_pointer;
8260 : }
8261 : else
8262 821 : attr = gfc_expr_attr (e);
8263 :
8264 854 : if (attr.allocatable)
8265 100 : msg = xasprintf ("Allocatable argument '%s' is not allocated",
8266 100 : e->symtree->n.sym->name);
8267 754 : else if (attr.pointer)
8268 46 : msg = xasprintf ("Pointer argument '%s' is not associated",
8269 46 : e->symtree->n.sym->name);
8270 : else
8271 708 : goto end_arg_check;
8272 :
8273 146 : if (sym)
8274 : {
8275 0 : temp = gfc_class_data_get (sym->backend_decl);
8276 0 : temp = gfc_conv_descriptor_data_get (temp);
8277 : }
8278 : else
8279 : {
8280 146 : argse.descriptor_only = 1;
8281 146 : gfc_conv_expr_descriptor (&argse, actual->expr);
8282 146 : temp = gfc_conv_descriptor_data_get (argse.expr);
8283 : }
8284 :
8285 146 : cond = fold_build2_loc (input_location, EQ_EXPR,
8286 : logical_type_node, temp,
8287 146 : fold_convert (TREE_TYPE (temp),
8288 : null_pointer_node));
8289 146 : gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
8290 :
8291 146 : free (msg);
8292 : }
8293 14555 : end_arg_check:
8294 :
8295 15409 : argse.data_not_needed = 1;
8296 15409 : if (gfc_is_class_array_function (e))
8297 : {
8298 : /* For functions that return a class array conv_expr_descriptor is not
8299 : able to get the descriptor right. Therefore this special case. */
8300 7 : gfc_conv_expr_reference (&argse, e);
8301 7 : argse.expr = gfc_class_data_get (argse.expr);
8302 : }
8303 15402 : else if (sym && sym->backend_decl)
8304 : {
8305 32 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8306 32 : argse.expr = gfc_class_data_get (sym->backend_decl);
8307 : }
8308 : else
8309 15370 : gfc_conv_expr_descriptor (&argse, actual->expr);
8310 15409 : gfc_add_block_to_block (&se->pre, &argse.pre);
8311 15409 : gfc_add_block_to_block (&se->post, &argse.post);
8312 15409 : arg1 = argse.expr;
8313 :
8314 15409 : actual = actual->next;
8315 15409 : if (actual->expr)
8316 : {
8317 9205 : stmtblock_t block;
8318 9205 : gfc_init_block (&block);
8319 9205 : gfc_init_se (&argse, NULL);
8320 9205 : gfc_conv_expr_type (&argse, actual->expr,
8321 : gfc_array_index_type);
8322 9205 : gfc_add_block_to_block (&block, &argse.pre);
8323 9205 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8324 : argse.expr, gfc_index_one_node);
8325 9205 : size = gfc_tree_array_size (&block, arg1, e, tmp);
8326 :
8327 : /* Unusually, for an intrinsic, size does not exclude
8328 : an optional arg2, so we must test for it. */
8329 9205 : if (actual->expr->expr_type == EXPR_VARIABLE
8330 2499 : && actual->expr->symtree->n.sym->attr.dummy
8331 31 : && actual->expr->symtree->n.sym->attr.optional)
8332 : {
8333 31 : tree cond;
8334 31 : stmtblock_t block2;
8335 31 : gfc_init_block (&block2);
8336 31 : gfc_init_se (&argse, NULL);
8337 31 : argse.want_pointer = 1;
8338 31 : argse.data_not_needed = 1;
8339 31 : gfc_conv_expr (&argse, actual->expr);
8340 31 : gfc_add_block_to_block (&se->pre, &argse.pre);
8341 : /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8342 : case; size_var can be used in both blocks. */
8343 31 : tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8344 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8345 31 : TREE_TYPE (size_var), size_var, size);
8346 31 : gfc_add_expr_to_block (&block, tmp);
8347 31 : size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8348 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8349 31 : TREE_TYPE (size_var), size_var, size);
8350 31 : gfc_add_expr_to_block (&block2, tmp);
8351 31 : cond = gfc_conv_expr_present (actual->expr->symtree->n.sym);
8352 31 : tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8353 : gfc_finish_block (&block2));
8354 31 : gfc_add_expr_to_block (&se->pre, tmp);
8355 31 : size = size_var;
8356 31 : }
8357 : else
8358 9174 : gfc_add_block_to_block (&se->pre, &block);
8359 : }
8360 : else
8361 6204 : size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8362 15409 : type = gfc_typenode_for_spec (&expr->ts);
8363 15409 : se->expr = convert (type, size);
8364 15409 : }
8365 :
8366 :
8367 : /* Helper function to compute the size of a character variable,
8368 : excluding the terminating null characters. The result has
8369 : gfc_array_index_type type. */
8370 :
8371 : tree
8372 1894 : size_of_string_in_bytes (int kind, tree string_length)
8373 : {
8374 1894 : tree bytesize;
8375 1894 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8376 :
8377 3788 : bytesize = build_int_cst (gfc_array_index_type,
8378 1894 : gfc_character_kinds[i].bit_size / 8);
8379 :
8380 1894 : return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8381 : bytesize,
8382 1894 : fold_convert (gfc_array_index_type, string_length));
8383 : }
8384 :
8385 :
8386 : static void
8387 1309 : gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8388 : {
8389 1309 : gfc_expr *arg;
8390 1309 : gfc_se argse;
8391 1309 : tree source_bytes;
8392 1309 : tree tmp;
8393 1309 : tree lower;
8394 1309 : tree upper;
8395 1309 : tree byte_size;
8396 1309 : tree field;
8397 1309 : int n;
8398 :
8399 1309 : gfc_init_se (&argse, NULL);
8400 1309 : arg = expr->value.function.actual->expr;
8401 :
8402 1309 : if (arg->rank || arg->ts.type == BT_ASSUMED)
8403 1012 : gfc_conv_expr_descriptor (&argse, arg);
8404 : else
8405 297 : gfc_conv_expr_reference (&argse, arg);
8406 :
8407 1309 : if (arg->ts.type == BT_ASSUMED)
8408 : {
8409 : /* This only works if an array descriptor has been passed; thus, extract
8410 : the size from the descriptor. */
8411 172 : gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8412 : == TYPE_PRECISION (size_type_node));
8413 172 : tmp = arg->symtree->n.sym->backend_decl;
8414 172 : tmp = DECL_LANG_SPECIFIC (tmp)
8415 60 : && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8416 226 : ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8417 172 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8418 172 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8419 :
8420 172 : tmp = gfc_conv_descriptor_dtype (tmp);
8421 172 : field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8422 : GFC_DTYPE_ELEM_LEN);
8423 172 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8424 : tmp, field, NULL_TREE);
8425 :
8426 172 : byte_size = fold_convert (gfc_array_index_type, tmp);
8427 : }
8428 1137 : else if (arg->ts.type == BT_CLASS)
8429 : {
8430 : /* Conv_expr_descriptor returns a component_ref to _data component of the
8431 : class object. The class object may be a non-pointer object, e.g.
8432 : located on the stack, or a memory location pointed to, e.g. a
8433 : parameter, i.e., an indirect_ref. */
8434 959 : if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8435 589 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8436 198 : byte_size
8437 198 : = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8438 391 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8439 0 : byte_size = gfc_class_vtab_size_get (argse.expr);
8440 391 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8441 391 : && TREE_CODE (argse.expr) == COMPONENT_REF)
8442 328 : byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8443 63 : else if (arg->rank > 0
8444 21 : || (arg->rank == 0
8445 21 : && arg->ref && arg->ref->type == REF_COMPONENT))
8446 : {
8447 : /* The scalarizer added an additional temp. To get the class' vptr
8448 : one has to look at the original backend_decl. */
8449 63 : if (argse.class_container)
8450 21 : byte_size = gfc_class_vtab_size_get (argse.class_container);
8451 42 : else if (DECL_LANG_SPECIFIC (arg->symtree->n.sym->backend_decl))
8452 84 : byte_size = gfc_class_vtab_size_get (
8453 42 : GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8454 : else
8455 0 : gcc_unreachable ();
8456 : }
8457 : else
8458 0 : gcc_unreachable ();
8459 : }
8460 : else
8461 : {
8462 548 : if (arg->ts.type == BT_CHARACTER)
8463 84 : byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8464 : else
8465 : {
8466 464 : if (arg->rank == 0)
8467 0 : byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8468 : argse.expr));
8469 : else
8470 464 : byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8471 464 : byte_size = fold_convert (gfc_array_index_type,
8472 : size_in_bytes (byte_size));
8473 : }
8474 : }
8475 :
8476 1309 : if (arg->rank == 0)
8477 297 : se->expr = byte_size;
8478 : else
8479 : {
8480 1012 : source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8481 1012 : gfc_add_modify (&argse.pre, source_bytes, byte_size);
8482 :
8483 1012 : if (arg->rank == -1)
8484 : {
8485 365 : tree cond, loop_var, exit_label;
8486 365 : stmtblock_t body;
8487 :
8488 365 : tmp = gfc_conv_descriptor_rank (argse.expr);
8489 365 : loop_var = gfc_create_var (gfc_array_dim_rank_type, "i");
8490 365 : gfc_add_modify (&argse.pre, loop_var, gfc_rank_cst[0]);
8491 365 : exit_label = gfc_build_label_decl (NULL_TREE);
8492 :
8493 : /* Create loop:
8494 : for (;;)
8495 : {
8496 : if (i >= rank)
8497 : goto exit;
8498 : source_bytes = source_bytes * array.dim[i].extent;
8499 : i = i + 1;
8500 : }
8501 : exit: */
8502 365 : gfc_start_block (&body);
8503 365 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8504 : loop_var, tmp);
8505 365 : tmp = build1_v (GOTO_EXPR, exit_label);
8506 365 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8507 : cond, tmp, build_empty_stmt (input_location));
8508 365 : gfc_add_expr_to_block (&body, tmp);
8509 :
8510 365 : lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8511 365 : upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8512 365 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8513 365 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8514 : gfc_array_index_type, tmp, source_bytes);
8515 365 : gfc_add_modify (&body, source_bytes, tmp);
8516 :
8517 365 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8518 : gfc_array_dim_rank_type, loop_var,
8519 : gfc_rank_cst[1]);
8520 365 : gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8521 :
8522 365 : tmp = gfc_finish_block (&body);
8523 :
8524 365 : tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8525 : tmp);
8526 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8527 :
8528 365 : tmp = build1_v (LABEL_EXPR, exit_label);
8529 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8530 : }
8531 : else
8532 : {
8533 : /* Obtain the size of the array in bytes. */
8534 1834 : for (n = 0; n < arg->rank; n++)
8535 : {
8536 1187 : tree idx;
8537 1187 : idx = gfc_rank_cst[n];
8538 1187 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8539 1187 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8540 1187 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8541 1187 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8542 : gfc_array_index_type, tmp, source_bytes);
8543 1187 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8544 : }
8545 : }
8546 1012 : se->expr = source_bytes;
8547 : }
8548 :
8549 1309 : gfc_add_block_to_block (&se->pre, &argse.pre);
8550 1309 : }
8551 :
8552 :
8553 : static void
8554 859 : gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8555 : {
8556 859 : gfc_expr *arg;
8557 859 : gfc_se argse;
8558 859 : tree type, result_type, tmp, class_decl = NULL;
8559 859 : gfc_symbol *sym;
8560 859 : bool unlimited = false;
8561 :
8562 859 : arg = expr->value.function.actual->expr;
8563 :
8564 859 : gfc_init_se (&argse, NULL);
8565 859 : result_type = gfc_get_int_type (expr->ts.kind);
8566 :
8567 859 : if (arg->rank == 0)
8568 : {
8569 230 : if (arg->ts.type == BT_CLASS)
8570 : {
8571 86 : unlimited = UNLIMITED_POLY (arg);
8572 86 : gfc_add_vptr_component (arg);
8573 86 : gfc_add_size_component (arg);
8574 86 : gfc_conv_expr (&argse, arg);
8575 86 : tmp = fold_convert (result_type, argse.expr);
8576 86 : class_decl = gfc_get_class_from_expr (argse.expr);
8577 86 : goto done;
8578 : }
8579 :
8580 144 : gfc_conv_expr_reference (&argse, arg);
8581 144 : type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8582 : argse.expr));
8583 : }
8584 : else
8585 : {
8586 629 : argse.want_pointer = 0;
8587 629 : gfc_conv_expr_descriptor (&argse, arg);
8588 629 : sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
8589 629 : if (arg->ts.type == BT_CLASS)
8590 : {
8591 60 : unlimited = UNLIMITED_POLY (arg);
8592 60 : if (TREE_CODE (argse.expr) == COMPONENT_REF)
8593 54 : tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8594 6 : else if (arg->rank > 0 && sym
8595 12 : && DECL_LANG_SPECIFIC (sym->backend_decl))
8596 12 : tmp = gfc_class_vtab_size_get (
8597 6 : GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
8598 : else
8599 0 : gcc_unreachable ();
8600 60 : tmp = fold_convert (result_type, tmp);
8601 60 : class_decl = gfc_get_class_from_expr (argse.expr);
8602 60 : goto done;
8603 : }
8604 569 : type = gfc_get_element_type (TREE_TYPE (argse.expr));
8605 : }
8606 :
8607 : /* Obtain the argument's word length. */
8608 713 : if (arg->ts.type == BT_CHARACTER)
8609 241 : tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8610 : else
8611 472 : tmp = size_in_bytes (type);
8612 713 : tmp = fold_convert (result_type, tmp);
8613 :
8614 859 : done:
8615 859 : if (unlimited && class_decl)
8616 68 : tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
8617 :
8618 859 : se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8619 : build_int_cst (result_type, BITS_PER_UNIT));
8620 859 : gfc_add_block_to_block (&se->pre, &argse.pre);
8621 859 : }
8622 :
8623 :
8624 : /* Intrinsic string comparison functions. */
8625 :
8626 : static void
8627 99 : gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8628 : {
8629 99 : tree args[4];
8630 :
8631 99 : gfc_conv_intrinsic_function_args (se, expr, args, 4);
8632 :
8633 99 : se->expr
8634 198 : = gfc_build_compare_string (args[0], args[1], args[2], args[3],
8635 99 : expr->value.function.actual->expr->ts.kind,
8636 : op);
8637 99 : se->expr = fold_build2_loc (input_location, op,
8638 : gfc_typenode_for_spec (&expr->ts), se->expr,
8639 99 : build_int_cst (TREE_TYPE (se->expr), 0));
8640 99 : }
8641 :
8642 : /* Generate a call to the adjustl/adjustr library function. */
8643 : static void
8644 468 : gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8645 : {
8646 468 : tree args[3];
8647 468 : tree len;
8648 468 : tree type;
8649 468 : tree var;
8650 468 : tree tmp;
8651 :
8652 468 : gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
8653 468 : len = args[1];
8654 :
8655 468 : type = TREE_TYPE (args[2]);
8656 468 : var = gfc_conv_string_tmp (se, type, len);
8657 468 : args[0] = var;
8658 :
8659 468 : tmp = build_call_expr_loc (input_location,
8660 : fndecl, 3, args[0], args[1], args[2]);
8661 468 : gfc_add_expr_to_block (&se->pre, tmp);
8662 468 : se->expr = var;
8663 468 : se->string_length = len;
8664 468 : }
8665 :
8666 :
8667 : /* Generate code for the TRANSFER intrinsic:
8668 : For scalar results:
8669 : DEST = TRANSFER (SOURCE, MOLD)
8670 : where:
8671 : typeof<DEST> = typeof<MOLD>
8672 : and:
8673 : MOLD is scalar.
8674 :
8675 : For array results:
8676 : DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8677 : where:
8678 : typeof<DEST> = typeof<MOLD>
8679 : and:
8680 : N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8681 : sizeof (DEST(0) * SIZE). */
8682 : static void
8683 3914 : gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8684 : {
8685 3914 : tree tmp;
8686 3914 : tree tmpdecl;
8687 3914 : tree ptr;
8688 3914 : tree extent;
8689 3914 : tree source;
8690 3914 : tree source_type;
8691 3914 : tree source_bytes;
8692 3914 : tree mold_type;
8693 3914 : tree dest_word_len;
8694 3914 : tree size_words;
8695 3914 : tree size_bytes;
8696 3914 : tree upper;
8697 3914 : tree lower;
8698 3914 : tree stmt;
8699 3914 : tree class_ref = NULL_TREE;
8700 3914 : gfc_actual_arglist *arg;
8701 3914 : gfc_se argse;
8702 3914 : gfc_array_info *info;
8703 3914 : stmtblock_t block;
8704 3914 : int n;
8705 3914 : bool scalar_mold;
8706 3914 : gfc_expr *source_expr, *mold_expr, *class_expr;
8707 :
8708 3914 : info = NULL;
8709 3914 : if (se->loop)
8710 472 : info = &se->ss->info->data.array;
8711 :
8712 : /* Convert SOURCE. The output from this stage is:-
8713 : source_bytes = length of the source in bytes
8714 : source = pointer to the source data. */
8715 3914 : arg = expr->value.function.actual;
8716 3914 : source_expr = arg->expr;
8717 :
8718 : /* Ensure double transfer through LOGICAL preserves all
8719 : the needed bits. */
8720 3914 : if (arg->expr->expr_type == EXPR_FUNCTION
8721 2917 : && arg->expr->value.function.esym == NULL
8722 2893 : && arg->expr->value.function.isym != NULL
8723 2893 : && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8724 12 : && arg->expr->ts.type == BT_LOGICAL
8725 12 : && expr->ts.type != arg->expr->ts.type)
8726 12 : arg->expr->value.function.name = "__transfer_in_transfer";
8727 :
8728 3914 : gfc_init_se (&argse, NULL);
8729 :
8730 3914 : source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8731 :
8732 : /* Obtain the pointer to source and the length of source in bytes. */
8733 3914 : if (arg->expr->rank == 0)
8734 : {
8735 3558 : gfc_conv_expr_reference (&argse, arg->expr);
8736 3558 : if (arg->expr->ts.type == BT_CLASS)
8737 : {
8738 37 : tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8739 37 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8740 : {
8741 19 : source = gfc_class_data_get (tmp);
8742 19 : class_ref = tmp;
8743 : }
8744 : else
8745 : {
8746 : /* Array elements are evaluated as a reference to the data.
8747 : To obtain the vptr for the element size, the argument
8748 : expression must be stripped to the class reference and
8749 : re-evaluated. The pre and post blocks are not needed. */
8750 18 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8751 18 : source = argse.expr;
8752 18 : class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8753 18 : gfc_init_se (&argse, NULL);
8754 18 : gfc_conv_expr (&argse, class_expr);
8755 18 : class_ref = argse.expr;
8756 : }
8757 : }
8758 : else
8759 3521 : source = argse.expr;
8760 :
8761 : /* Obtain the source word length. */
8762 3558 : switch (arg->expr->ts.type)
8763 : {
8764 294 : case BT_CHARACTER:
8765 294 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8766 : argse.string_length);
8767 294 : break;
8768 37 : case BT_CLASS:
8769 37 : if (class_ref != NULL_TREE)
8770 : {
8771 37 : tmp = gfc_class_vtab_size_get (class_ref);
8772 37 : if (UNLIMITED_POLY (source_expr))
8773 30 : tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
8774 : }
8775 : else
8776 : {
8777 0 : tmp = gfc_class_vtab_size_get (argse.expr);
8778 0 : if (UNLIMITED_POLY (source_expr))
8779 0 : tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
8780 : }
8781 : break;
8782 3227 : default:
8783 3227 : source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8784 : source));
8785 3227 : tmp = fold_convert (gfc_array_index_type,
8786 : size_in_bytes (source_type));
8787 3227 : break;
8788 : }
8789 : }
8790 : else
8791 : {
8792 356 : bool simply_contiguous = gfc_is_simply_contiguous (arg->expr,
8793 : false, true);
8794 356 : argse.want_pointer = 0;
8795 : /* A non-contiguous SOURCE needs packing. */
8796 356 : if (!simply_contiguous)
8797 74 : argse.force_tmp = 1;
8798 356 : gfc_conv_expr_descriptor (&argse, arg->expr);
8799 356 : source = gfc_conv_descriptor_data_get (argse.expr);
8800 356 : source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8801 :
8802 : /* Repack the source if not simply contiguous. */
8803 356 : if (!simply_contiguous)
8804 : {
8805 74 : tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8806 :
8807 74 : if (warn_array_temporaries)
8808 0 : gfc_warning (OPT_Warray_temporaries,
8809 : "Creating array temporary at %L", &expr->where);
8810 :
8811 74 : source = build_call_expr_loc (input_location,
8812 : gfor_fndecl_in_pack, 1, tmp);
8813 74 : source = gfc_evaluate_now (source, &argse.pre);
8814 :
8815 : /* Free the temporary. */
8816 74 : gfc_start_block (&block);
8817 74 : tmp = gfc_call_free (source);
8818 74 : gfc_add_expr_to_block (&block, tmp);
8819 74 : stmt = gfc_finish_block (&block);
8820 :
8821 : /* Clean up if it was repacked. */
8822 74 : gfc_init_block (&block);
8823 74 : tmp = gfc_conv_array_data (argse.expr);
8824 74 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8825 : source, tmp);
8826 74 : tmp = build3_v (COND_EXPR, tmp, stmt,
8827 : build_empty_stmt (input_location));
8828 74 : gfc_add_expr_to_block (&block, tmp);
8829 74 : gfc_add_block_to_block (&block, &se->post);
8830 74 : gfc_init_block (&se->post);
8831 74 : gfc_add_block_to_block (&se->post, &block);
8832 : }
8833 :
8834 : /* Obtain the source word length. */
8835 356 : if (arg->expr->ts.type == BT_CHARACTER)
8836 144 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8837 : argse.string_length);
8838 212 : else if (arg->expr->ts.type == BT_CLASS)
8839 : {
8840 54 : if (UNLIMITED_POLY (source_expr)
8841 54 : && DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl))
8842 12 : class_ref = GFC_DECL_SAVED_DESCRIPTOR
8843 : (source_expr->symtree->n.sym->backend_decl);
8844 : else
8845 42 : class_ref = TREE_OPERAND (argse.expr, 0);
8846 54 : tmp = gfc_class_vtab_size_get (class_ref);
8847 54 : if (UNLIMITED_POLY (arg->expr))
8848 54 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8849 : }
8850 : else
8851 158 : tmp = fold_convert (gfc_array_index_type,
8852 : size_in_bytes (source_type));
8853 :
8854 : /* Obtain the size of the array in bytes. */
8855 356 : extent = gfc_create_var (gfc_array_index_type, NULL);
8856 742 : for (n = 0; n < arg->expr->rank; n++)
8857 : {
8858 386 : tree idx;
8859 386 : idx = gfc_rank_cst[n];
8860 386 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8861 386 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8862 386 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8863 386 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8864 : gfc_array_index_type, upper, lower);
8865 386 : gfc_add_modify (&argse.pre, extent, tmp);
8866 386 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8867 : gfc_array_index_type, extent,
8868 : gfc_index_one_node);
8869 386 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8870 : gfc_array_index_type, tmp, source_bytes);
8871 : }
8872 : }
8873 :
8874 3914 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8875 3914 : gfc_add_block_to_block (&se->pre, &argse.pre);
8876 3914 : gfc_add_block_to_block (&se->post, &argse.post);
8877 :
8878 : /* Now convert MOLD. The outputs are:
8879 : mold_type = the TREE type of MOLD
8880 : dest_word_len = destination word length in bytes. */
8881 3914 : arg = arg->next;
8882 3914 : mold_expr = arg->expr;
8883 :
8884 3914 : gfc_init_se (&argse, NULL);
8885 :
8886 3914 : scalar_mold = arg->expr->rank == 0;
8887 :
8888 3914 : if (arg->expr->rank == 0)
8889 : {
8890 3591 : gfc_conv_expr_reference (&argse, mold_expr);
8891 3591 : mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8892 : argse.expr));
8893 : }
8894 : else
8895 : {
8896 323 : argse.want_pointer = 0;
8897 323 : gfc_conv_expr_descriptor (&argse, mold_expr);
8898 323 : mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8899 : }
8900 :
8901 3914 : gfc_add_block_to_block (&se->pre, &argse.pre);
8902 3914 : gfc_add_block_to_block (&se->post, &argse.post);
8903 :
8904 3914 : if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8905 : {
8906 : /* If this TRANSFER is nested in another TRANSFER, use a type
8907 : that preserves all bits. */
8908 12 : if (mold_expr->ts.type == BT_LOGICAL)
8909 12 : mold_type = gfc_get_int_type (mold_expr->ts.kind);
8910 : }
8911 :
8912 : /* Obtain the destination word length. */
8913 3914 : switch (mold_expr->ts.type)
8914 : {
8915 467 : case BT_CHARACTER:
8916 467 : tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length);
8917 467 : mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
8918 : argse.string_length);
8919 467 : break;
8920 6 : case BT_CLASS:
8921 6 : if (scalar_mold)
8922 6 : class_ref = argse.expr;
8923 : else
8924 0 : class_ref = TREE_OPERAND (argse.expr, 0);
8925 6 : tmp = gfc_class_vtab_size_get (class_ref);
8926 6 : if (UNLIMITED_POLY (arg->expr))
8927 0 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8928 : break;
8929 3441 : default:
8930 3441 : tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8931 3441 : break;
8932 : }
8933 :
8934 : /* Do not fix dest_word_len if it is a variable, since the temporary can wind
8935 : up being used before the assignment. */
8936 3914 : if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
8937 : dest_word_len = tmp;
8938 : else
8939 : {
8940 3860 : dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8941 3860 : gfc_add_modify (&se->pre, dest_word_len, tmp);
8942 : }
8943 :
8944 : /* Finally convert SIZE, if it is present. */
8945 3914 : arg = arg->next;
8946 3914 : size_words = gfc_create_var (gfc_array_index_type, NULL);
8947 :
8948 3914 : if (arg->expr)
8949 : {
8950 222 : gfc_init_se (&argse, NULL);
8951 222 : gfc_conv_expr_reference (&argse, arg->expr);
8952 222 : tmp = convert (gfc_array_index_type,
8953 : build_fold_indirect_ref_loc (input_location,
8954 : argse.expr));
8955 222 : gfc_add_block_to_block (&se->pre, &argse.pre);
8956 222 : gfc_add_block_to_block (&se->post, &argse.post);
8957 : }
8958 : else
8959 : tmp = NULL_TREE;
8960 :
8961 : /* Separate array and scalar results. */
8962 3914 : if (scalar_mold && tmp == NULL_TREE)
8963 3442 : goto scalar_transfer;
8964 :
8965 472 : size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8966 472 : if (tmp != NULL_TREE)
8967 222 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8968 : tmp, dest_word_len);
8969 : else
8970 : tmp = source_bytes;
8971 :
8972 472 : gfc_add_modify (&se->pre, size_bytes, tmp);
8973 472 : gfc_add_modify (&se->pre, size_words,
8974 : fold_build2_loc (input_location, CEIL_DIV_EXPR,
8975 : gfc_array_index_type,
8976 : size_bytes, dest_word_len));
8977 :
8978 : /* Evaluate the bounds of the result. If the loop range exists, we have
8979 : to check if it is too large. If so, we modify loop->to be consistent
8980 : with min(size, size(source)). Otherwise, size is made consistent with
8981 : the loop range, so that the right number of bytes is transferred.*/
8982 472 : n = se->loop->order[0];
8983 472 : if (se->loop->to[n] != NULL_TREE)
8984 : {
8985 205 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8986 : se->loop->to[n], se->loop->from[n]);
8987 205 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8988 : tmp, gfc_index_one_node);
8989 205 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8990 : tmp, size_words);
8991 205 : gfc_add_modify (&se->pre, size_words, tmp);
8992 205 : gfc_add_modify (&se->pre, size_bytes,
8993 : fold_build2_loc (input_location, MULT_EXPR,
8994 : gfc_array_index_type,
8995 : size_words, dest_word_len));
8996 410 : upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8997 205 : size_words, se->loop->from[n]);
8998 205 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8999 : upper, gfc_index_one_node);
9000 : }
9001 : else
9002 : {
9003 267 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9004 : size_words, gfc_index_one_node);
9005 267 : se->loop->from[n] = gfc_index_zero_node;
9006 : }
9007 :
9008 472 : se->loop->to[n] = upper;
9009 :
9010 : /* Build a destination descriptor, using the pointer, source, as the
9011 : data field. */
9012 472 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
9013 : NULL_TREE, false, true, false, &expr->where);
9014 :
9015 : /* Cast the pointer to the result. */
9016 472 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9017 472 : tmp = fold_convert (pvoid_type_node, tmp);
9018 :
9019 : /* Use memcpy to do the transfer. */
9020 472 : tmp
9021 472 : = build_call_expr_loc (input_location,
9022 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
9023 : fold_convert (pvoid_type_node, source),
9024 : fold_convert (size_type_node,
9025 : fold_build2_loc (input_location,
9026 : MIN_EXPR,
9027 : gfc_array_index_type,
9028 : size_bytes,
9029 : source_bytes)));
9030 472 : gfc_add_expr_to_block (&se->pre, tmp);
9031 :
9032 472 : se->expr = info->descriptor;
9033 472 : if (expr->ts.type == BT_CHARACTER)
9034 : {
9035 275 : tmp = fold_convert (gfc_charlen_type_node,
9036 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9037 275 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9038 : gfc_charlen_type_node,
9039 : dest_word_len, tmp);
9040 : }
9041 :
9042 472 : return;
9043 :
9044 : /* Deal with scalar results. */
9045 3442 : scalar_transfer:
9046 3442 : extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9047 : dest_word_len, source_bytes);
9048 3442 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9049 : extent, gfc_index_zero_node);
9050 :
9051 3442 : if (expr->ts.type == BT_CHARACTER)
9052 : {
9053 192 : tree direct, indirect, free;
9054 :
9055 192 : ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
9056 192 : tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
9057 : "transfer");
9058 :
9059 : /* If source is longer than the destination, use a pointer to
9060 : the source directly. */
9061 192 : gfc_init_block (&block);
9062 192 : gfc_add_modify (&block, tmpdecl, ptr);
9063 192 : direct = gfc_finish_block (&block);
9064 :
9065 : /* Otherwise, allocate a string with the length of the destination
9066 : and copy the source into it. */
9067 192 : gfc_init_block (&block);
9068 192 : tmp = gfc_get_pchar_type (expr->ts.kind);
9069 192 : tmp = gfc_call_malloc (&block, tmp, dest_word_len);
9070 192 : gfc_add_modify (&block, tmpdecl,
9071 192 : fold_convert (TREE_TYPE (ptr), tmp));
9072 192 : tmp = build_call_expr_loc (input_location,
9073 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9074 : fold_convert (pvoid_type_node, tmpdecl),
9075 : fold_convert (pvoid_type_node, ptr),
9076 : fold_convert (size_type_node, extent));
9077 192 : gfc_add_expr_to_block (&block, tmp);
9078 192 : indirect = gfc_finish_block (&block);
9079 :
9080 : /* Wrap it up with the condition. */
9081 192 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
9082 : dest_word_len, source_bytes);
9083 192 : tmp = build3_v (COND_EXPR, tmp, direct, indirect);
9084 192 : gfc_add_expr_to_block (&se->pre, tmp);
9085 :
9086 : /* Free the temporary string, if necessary. */
9087 192 : free = gfc_call_free (tmpdecl);
9088 192 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9089 : dest_word_len, source_bytes);
9090 192 : tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
9091 192 : gfc_add_expr_to_block (&se->post, tmp);
9092 :
9093 192 : se->expr = tmpdecl;
9094 192 : tmp = fold_convert (gfc_charlen_type_node,
9095 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9096 192 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9097 : gfc_charlen_type_node,
9098 : dest_word_len, tmp);
9099 : }
9100 : else
9101 : {
9102 3250 : tmpdecl = gfc_create_var (mold_type, "transfer");
9103 :
9104 3250 : ptr = convert (build_pointer_type (mold_type), source);
9105 :
9106 : /* For CLASS results, allocate the needed memory first. */
9107 3250 : if (mold_expr->ts.type == BT_CLASS)
9108 : {
9109 6 : tree cdata;
9110 6 : cdata = gfc_class_data_get (tmpdecl);
9111 6 : tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
9112 6 : gfc_add_modify (&se->pre, cdata, tmp);
9113 : }
9114 :
9115 : /* Use memcpy to do the transfer. */
9116 3250 : if (mold_expr->ts.type == BT_CLASS)
9117 6 : tmp = gfc_class_data_get (tmpdecl);
9118 : else
9119 3244 : tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
9120 :
9121 3250 : tmp = build_call_expr_loc (input_location,
9122 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9123 : fold_convert (pvoid_type_node, tmp),
9124 : fold_convert (pvoid_type_node, ptr),
9125 : fold_convert (size_type_node, extent));
9126 3250 : gfc_add_expr_to_block (&se->pre, tmp);
9127 :
9128 : /* For CLASS results, set the _vptr. */
9129 3250 : if (mold_expr->ts.type == BT_CLASS)
9130 6 : gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
9131 :
9132 3250 : se->expr = tmpdecl;
9133 : }
9134 : }
9135 :
9136 :
9137 : /* Generate code for the ALLOCATED intrinsic.
9138 : Generate inline code that directly check the address of the argument. */
9139 :
9140 : static void
9141 7405 : gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
9142 : {
9143 7405 : gfc_se arg1se;
9144 7405 : tree tmp;
9145 7405 : gfc_expr *e = expr->value.function.actual->expr;
9146 :
9147 7405 : gfc_init_se (&arg1se, NULL);
9148 7405 : if (e->ts.type == BT_CLASS)
9149 : {
9150 : /* Make sure that class array expressions have both a _data
9151 : component reference and an array reference.... */
9152 905 : if (CLASS_DATA (e)->attr.dimension)
9153 418 : gfc_add_class_array_ref (e);
9154 : /* .... whilst scalars only need the _data component. */
9155 : else
9156 487 : gfc_add_data_component (e);
9157 : }
9158 :
9159 7405 : gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
9160 :
9161 7405 : if (e->rank == 0)
9162 : {
9163 : /* Allocatable scalar. */
9164 2894 : arg1se.want_pointer = 1;
9165 2894 : gfc_conv_expr (&arg1se, e);
9166 2894 : tmp = arg1se.expr;
9167 : }
9168 : else
9169 : {
9170 : /* Allocatable array. */
9171 4511 : arg1se.descriptor_only = 1;
9172 4511 : gfc_conv_expr_descriptor (&arg1se, e);
9173 4511 : tmp = gfc_conv_descriptor_data_get (arg1se.expr);
9174 : }
9175 :
9176 7405 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
9177 7405 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9178 :
9179 : /* Components of pointer array references sometimes come back with a pre block. */
9180 7405 : if (arg1se.pre.head)
9181 327 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9182 :
9183 7405 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9184 7405 : }
9185 :
9186 :
9187 : /* Generate code for the ASSOCIATED intrinsic.
9188 : If both POINTER and TARGET are arrays, generate a call to library function
9189 : _gfor_associated, and pass descriptors of POINTER and TARGET to it.
9190 : In other cases, generate inline code that directly compare the address of
9191 : POINTER with the address of TARGET. */
9192 :
9193 : static void
9194 9581 : gfc_conv_associated (gfc_se *se, gfc_expr *expr)
9195 : {
9196 9581 : gfc_actual_arglist *arg1;
9197 9581 : gfc_actual_arglist *arg2;
9198 9581 : gfc_se arg1se;
9199 9581 : gfc_se arg2se;
9200 9581 : tree tmp2;
9201 9581 : tree tmp;
9202 9581 : tree nonzero_arraylen = NULL_TREE;
9203 9581 : gfc_ss *ss;
9204 9581 : bool scalar;
9205 :
9206 9581 : gfc_init_se (&arg1se, NULL);
9207 9581 : gfc_init_se (&arg2se, NULL);
9208 9581 : arg1 = expr->value.function.actual;
9209 9581 : arg2 = arg1->next;
9210 :
9211 : /* Check whether the expression is a scalar or not; we cannot use
9212 : arg1->expr->rank as it can be nonzero for proc pointers. */
9213 9581 : ss = gfc_walk_expr (arg1->expr);
9214 9581 : scalar = ss == gfc_ss_terminator;
9215 9581 : if (!scalar)
9216 3919 : gfc_free_ss_chain (ss);
9217 :
9218 9581 : if (!arg2->expr)
9219 : {
9220 : /* No optional target. */
9221 7202 : if (scalar)
9222 : {
9223 : /* A pointer to a scalar. */
9224 4735 : arg1se.want_pointer = 1;
9225 4735 : gfc_conv_expr (&arg1se, arg1->expr);
9226 4735 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9227 185 : && arg1->expr->symtree->n.sym->attr.dummy)
9228 78 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9229 : arg1se.expr);
9230 4735 : if (arg1->expr->ts.type == BT_CLASS)
9231 : {
9232 390 : tmp2 = gfc_class_data_get (arg1se.expr);
9233 390 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9234 0 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
9235 : }
9236 : else
9237 4345 : tmp2 = arg1se.expr;
9238 : }
9239 : else
9240 : {
9241 : /* A pointer to an array. */
9242 2467 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9243 2467 : tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
9244 : }
9245 7202 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9246 7202 : gfc_add_block_to_block (&se->post, &arg1se.post);
9247 7202 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9248 7202 : fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9249 7202 : se->expr = tmp;
9250 : }
9251 : else
9252 : {
9253 : /* An optional target. */
9254 2379 : if (arg2->expr->ts.type == BT_CLASS
9255 30 : && arg2->expr->expr_type != EXPR_FUNCTION)
9256 24 : gfc_add_data_component (arg2->expr);
9257 :
9258 2379 : if (scalar)
9259 : {
9260 : /* A pointer to a scalar. */
9261 927 : arg1se.want_pointer = 1;
9262 927 : gfc_conv_expr (&arg1se, arg1->expr);
9263 927 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9264 128 : && arg1->expr->symtree->n.sym->attr.dummy)
9265 42 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9266 : arg1se.expr);
9267 927 : if (arg1->expr->ts.type == BT_CLASS)
9268 254 : arg1se.expr = gfc_class_data_get (arg1se.expr);
9269 :
9270 927 : arg2se.want_pointer = 1;
9271 927 : gfc_conv_expr (&arg2se, arg2->expr);
9272 927 : if (arg2->expr->symtree->n.sym->attr.proc_pointer
9273 36 : && arg2->expr->symtree->n.sym->attr.dummy)
9274 0 : arg2se.expr = build_fold_indirect_ref_loc (input_location,
9275 : arg2se.expr);
9276 927 : if (arg2->expr->ts.type == BT_CLASS)
9277 : {
9278 6 : arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
9279 6 : arg2se.expr = gfc_class_data_get (arg2se.expr);
9280 : }
9281 927 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9282 927 : gfc_add_block_to_block (&se->post, &arg1se.post);
9283 927 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9284 927 : gfc_add_block_to_block (&se->post, &arg2se.post);
9285 927 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9286 : arg1se.expr, arg2se.expr);
9287 927 : tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9288 : arg1se.expr, null_pointer_node);
9289 927 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9290 : logical_type_node, tmp, tmp2);
9291 : }
9292 : else
9293 : {
9294 : /* An array pointer of zero length is not associated if target is
9295 : present. */
9296 1452 : arg1se.descriptor_only = 1;
9297 1452 : gfc_conv_expr_lhs (&arg1se, arg1->expr);
9298 1452 : if (arg1->expr->rank == -1)
9299 : {
9300 84 : tmp = gfc_conv_descriptor_rank (arg1se.expr);
9301 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9302 84 : TREE_TYPE (tmp), tmp,
9303 84 : build_int_cst (TREE_TYPE (tmp), 1));
9304 : }
9305 : else
9306 1368 : tmp = gfc_rank_cst[arg1->expr->rank - 1];
9307 1452 : tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9308 1452 : if (arg2->expr->rank != 0)
9309 1422 : nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9310 : logical_type_node, tmp,
9311 1422 : build_int_cst (TREE_TYPE (tmp), 0));
9312 :
9313 : /* A pointer to an array, call library function _gfor_associated. */
9314 1452 : arg1se.want_pointer = 1;
9315 1452 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9316 1452 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9317 1452 : gfc_add_block_to_block (&se->post, &arg1se.post);
9318 :
9319 1452 : arg2se.want_pointer = 1;
9320 1452 : arg2se.force_no_tmp = 1;
9321 1452 : if (arg2->expr->rank != 0)
9322 1422 : gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9323 : else
9324 : {
9325 30 : gfc_conv_expr (&arg2se, arg2->expr);
9326 30 : arg2se.expr
9327 30 : = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9328 30 : gfc_expr_attr (arg2->expr));
9329 30 : arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9330 : }
9331 1452 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9332 1452 : gfc_add_block_to_block (&se->post, &arg2se.post);
9333 1452 : se->expr = build_call_expr_loc (input_location,
9334 : gfor_fndecl_associated, 2,
9335 : arg1se.expr, arg2se.expr);
9336 1452 : se->expr = convert (logical_type_node, se->expr);
9337 1452 : if (arg2->expr->rank != 0)
9338 1422 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9339 : logical_type_node, se->expr,
9340 : nonzero_arraylen);
9341 : }
9342 :
9343 : /* If target is present zero character length pointers cannot
9344 : be associated. */
9345 2379 : if (arg1->expr->ts.type == BT_CHARACTER)
9346 : {
9347 631 : tmp = arg1se.string_length;
9348 631 : tmp = fold_build2_loc (input_location, NE_EXPR,
9349 : logical_type_node, tmp,
9350 631 : build_zero_cst (TREE_TYPE (tmp)));
9351 631 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9352 : logical_type_node, se->expr, tmp);
9353 : }
9354 : }
9355 :
9356 9581 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9357 9581 : }
9358 :
9359 :
9360 : /* Generate code for the SAME_TYPE_AS intrinsic.
9361 : Generate inline code that directly checks the vindices. */
9362 :
9363 : static void
9364 409 : gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9365 : {
9366 409 : gfc_expr *a, *b;
9367 409 : gfc_se se1, se2;
9368 409 : tree tmp;
9369 409 : tree conda = NULL_TREE, condb = NULL_TREE;
9370 :
9371 409 : gfc_init_se (&se1, NULL);
9372 409 : gfc_init_se (&se2, NULL);
9373 :
9374 409 : a = expr->value.function.actual->expr;
9375 409 : b = expr->value.function.actual->next->expr;
9376 :
9377 409 : bool unlimited_poly_a = UNLIMITED_POLY (a);
9378 409 : bool unlimited_poly_b = UNLIMITED_POLY (b);
9379 409 : if (unlimited_poly_a)
9380 : {
9381 111 : se1.want_pointer = 1;
9382 111 : gfc_add_vptr_component (a);
9383 : }
9384 298 : else if (a->ts.type == BT_CLASS)
9385 : {
9386 256 : gfc_add_vptr_component (a);
9387 256 : gfc_add_hash_component (a);
9388 : }
9389 42 : else if (a->ts.type == BT_DERIVED)
9390 42 : a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9391 42 : a->ts.u.derived->hash_value);
9392 :
9393 409 : if (unlimited_poly_b)
9394 : {
9395 72 : se2.want_pointer = 1;
9396 72 : gfc_add_vptr_component (b);
9397 : }
9398 337 : else if (b->ts.type == BT_CLASS)
9399 : {
9400 169 : gfc_add_vptr_component (b);
9401 169 : gfc_add_hash_component (b);
9402 : }
9403 168 : else if (b->ts.type == BT_DERIVED)
9404 168 : b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9405 168 : b->ts.u.derived->hash_value);
9406 :
9407 409 : gfc_conv_expr (&se1, a);
9408 409 : gfc_conv_expr (&se2, b);
9409 :
9410 409 : if (unlimited_poly_a)
9411 : {
9412 111 : conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9413 : se1.expr,
9414 111 : build_int_cst (TREE_TYPE (se1.expr), 0));
9415 111 : se1.expr = gfc_vptr_hash_get (se1.expr);
9416 : }
9417 :
9418 409 : if (unlimited_poly_b)
9419 : {
9420 72 : condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9421 : se2.expr,
9422 72 : build_int_cst (TREE_TYPE (se2.expr), 0));
9423 72 : se2.expr = gfc_vptr_hash_get (se2.expr);
9424 : }
9425 :
9426 409 : tmp = fold_build2_loc (input_location, EQ_EXPR,
9427 : logical_type_node, se1.expr,
9428 409 : fold_convert (TREE_TYPE (se1.expr), se2.expr));
9429 :
9430 409 : if (conda)
9431 111 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9432 : logical_type_node, conda, tmp);
9433 :
9434 409 : if (condb)
9435 72 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9436 : logical_type_node, condb, tmp);
9437 :
9438 409 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9439 409 : }
9440 :
9441 :
9442 : /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9443 :
9444 : static void
9445 42 : gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9446 : {
9447 42 : tree args[2];
9448 :
9449 42 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
9450 42 : se->expr = build_call_expr_loc (input_location,
9451 : gfor_fndecl_sc_kind, 2, args[0], args[1]);
9452 42 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9453 42 : }
9454 :
9455 :
9456 : /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9457 :
9458 : static void
9459 45 : gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9460 : {
9461 45 : tree arg, type;
9462 :
9463 45 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9464 :
9465 : /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9466 45 : type = gfc_get_int_type (4);
9467 45 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9468 :
9469 : /* Convert it to the required type. */
9470 45 : type = gfc_typenode_for_spec (&expr->ts);
9471 45 : se->expr = build_call_expr_loc (input_location,
9472 : gfor_fndecl_si_kind, 1, arg);
9473 45 : se->expr = fold_convert (type, se->expr);
9474 45 : }
9475 :
9476 :
9477 : /* Generate code for SELECTED_LOGICAL_KIND (BITS) intrinsic function. */
9478 :
9479 : static void
9480 6 : gfc_conv_intrinsic_sl_kind (gfc_se *se, gfc_expr *expr)
9481 : {
9482 6 : tree arg, type;
9483 :
9484 6 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9485 :
9486 : /* The argument to SELECTED_LOGICAL_KIND is INTEGER(4). */
9487 6 : type = gfc_get_int_type (4);
9488 6 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9489 :
9490 : /* Convert it to the required type. */
9491 6 : type = gfc_typenode_for_spec (&expr->ts);
9492 6 : se->expr = build_call_expr_loc (input_location,
9493 : gfor_fndecl_sl_kind, 1, arg);
9494 6 : se->expr = fold_convert (type, se->expr);
9495 6 : }
9496 :
9497 :
9498 : /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9499 :
9500 : static void
9501 82 : gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9502 : {
9503 82 : gfc_actual_arglist *actual;
9504 82 : tree type;
9505 82 : gfc_se argse;
9506 82 : vec<tree, va_gc> *args = NULL;
9507 :
9508 328 : for (actual = expr->value.function.actual; actual; actual = actual->next)
9509 : {
9510 246 : gfc_init_se (&argse, se);
9511 :
9512 : /* Pass a NULL pointer for an absent arg. */
9513 246 : if (actual->expr == NULL)
9514 96 : argse.expr = null_pointer_node;
9515 : else
9516 : {
9517 150 : gfc_typespec ts;
9518 150 : gfc_clear_ts (&ts);
9519 :
9520 150 : if (actual->expr->ts.kind != gfc_c_int_kind)
9521 : {
9522 : /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9523 0 : ts.type = BT_INTEGER;
9524 0 : ts.kind = gfc_c_int_kind;
9525 0 : gfc_convert_type (actual->expr, &ts, 2);
9526 : }
9527 150 : gfc_conv_expr_reference (&argse, actual->expr);
9528 : }
9529 :
9530 246 : gfc_add_block_to_block (&se->pre, &argse.pre);
9531 246 : gfc_add_block_to_block (&se->post, &argse.post);
9532 246 : vec_safe_push (args, argse.expr);
9533 : }
9534 :
9535 : /* Convert it to the required type. */
9536 82 : type = gfc_typenode_for_spec (&expr->ts);
9537 82 : se->expr = build_call_expr_loc_vec (input_location,
9538 : gfor_fndecl_sr_kind, args);
9539 82 : se->expr = fold_convert (type, se->expr);
9540 82 : }
9541 :
9542 :
9543 : /* Generate code for TRIM (A) intrinsic function. */
9544 :
9545 : static void
9546 578 : gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9547 : {
9548 578 : tree var;
9549 578 : tree len;
9550 578 : tree addr;
9551 578 : tree tmp;
9552 578 : tree cond;
9553 578 : tree fndecl;
9554 578 : tree function;
9555 578 : tree *args;
9556 578 : unsigned int num_args;
9557 :
9558 578 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9559 578 : args = XALLOCAVEC (tree, num_args);
9560 :
9561 578 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9562 578 : addr = gfc_build_addr_expr (ppvoid_type_node, var);
9563 578 : len = gfc_create_var (gfc_charlen_type_node, "len");
9564 :
9565 578 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
9566 578 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
9567 578 : args[1] = addr;
9568 :
9569 578 : if (expr->ts.kind == 1)
9570 546 : function = gfor_fndecl_string_trim;
9571 32 : else if (expr->ts.kind == 4)
9572 32 : function = gfor_fndecl_string_trim_char4;
9573 : else
9574 0 : gcc_unreachable ();
9575 :
9576 578 : fndecl = build_addr (function);
9577 578 : tmp = build_call_array_loc (input_location,
9578 578 : TREE_TYPE (TREE_TYPE (function)), fndecl,
9579 : num_args, args);
9580 578 : gfc_add_expr_to_block (&se->pre, tmp);
9581 :
9582 : /* Free the temporary afterwards, if necessary. */
9583 578 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9584 578 : len, build_int_cst (TREE_TYPE (len), 0));
9585 578 : tmp = gfc_call_free (var);
9586 578 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9587 578 : gfc_add_expr_to_block (&se->post, tmp);
9588 :
9589 578 : se->expr = var;
9590 578 : se->string_length = len;
9591 578 : }
9592 :
9593 :
9594 : /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9595 :
9596 : static void
9597 529 : gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9598 : {
9599 529 : tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9600 529 : tree type, cond, tmp, count, exit_label, n, max, largest;
9601 529 : tree size;
9602 529 : stmtblock_t block, body;
9603 529 : int i;
9604 :
9605 : /* We store in charsize the size of a character. */
9606 529 : i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9607 529 : size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9608 :
9609 : /* Get the arguments. */
9610 529 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
9611 529 : slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9612 529 : src = args[1];
9613 529 : ncopies = gfc_evaluate_now (args[2], &se->pre);
9614 529 : ncopies_type = TREE_TYPE (ncopies);
9615 :
9616 : /* Check that NCOPIES is not negative. */
9617 529 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9618 : build_int_cst (ncopies_type, 0));
9619 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9620 : "Argument NCOPIES of REPEAT intrinsic is negative "
9621 : "(its value is %ld)",
9622 : fold_convert (long_integer_type_node, ncopies));
9623 :
9624 : /* If the source length is zero, any non negative value of NCOPIES
9625 : is valid, and nothing happens. */
9626 529 : n = gfc_create_var (ncopies_type, "ncopies");
9627 529 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9628 : size_zero_node);
9629 529 : tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9630 : build_int_cst (ncopies_type, 0), ncopies);
9631 529 : gfc_add_modify (&se->pre, n, tmp);
9632 529 : ncopies = n;
9633 :
9634 : /* Check that ncopies is not too large: ncopies should be less than
9635 : (or equal to) MAX / slen, where MAX is the maximal integer of
9636 : the gfc_charlen_type_node type. If slen == 0, we need a special
9637 : case to avoid the division by zero. */
9638 529 : max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9639 529 : fold_convert (sizetype,
9640 : TYPE_MAX_VALUE (gfc_charlen_type_node)),
9641 : slen);
9642 1054 : largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9643 529 : ? sizetype : ncopies_type;
9644 529 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9645 : fold_convert (largest, ncopies),
9646 : fold_convert (largest, max));
9647 529 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9648 : size_zero_node);
9649 529 : cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9650 : logical_false_node, cond);
9651 529 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9652 : "Argument NCOPIES of REPEAT intrinsic is too large");
9653 :
9654 : /* Compute the destination length. */
9655 529 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9656 : fold_convert (gfc_charlen_type_node, slen),
9657 : fold_convert (gfc_charlen_type_node, ncopies));
9658 529 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9659 529 : dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9660 :
9661 : /* Generate the code to do the repeat operation:
9662 : for (i = 0; i < ncopies; i++)
9663 : memmove (dest + (i * slen * size), src, slen*size); */
9664 529 : gfc_start_block (&block);
9665 529 : count = gfc_create_var (sizetype, "count");
9666 529 : gfc_add_modify (&block, count, size_zero_node);
9667 529 : exit_label = gfc_build_label_decl (NULL_TREE);
9668 :
9669 : /* Start the loop body. */
9670 529 : gfc_start_block (&body);
9671 :
9672 : /* Exit the loop if count >= ncopies. */
9673 529 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9674 : fold_convert (sizetype, ncopies));
9675 529 : tmp = build1_v (GOTO_EXPR, exit_label);
9676 529 : TREE_USED (exit_label) = 1;
9677 529 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9678 : build_empty_stmt (input_location));
9679 529 : gfc_add_expr_to_block (&body, tmp);
9680 :
9681 : /* Call memmove (dest + (i*slen*size), src, slen*size). */
9682 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9683 : count);
9684 529 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9685 : size);
9686 529 : tmp = fold_build_pointer_plus_loc (input_location,
9687 : fold_convert (pvoid_type_node, dest), tmp);
9688 529 : tmp = build_call_expr_loc (input_location,
9689 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9690 : 3, tmp, src,
9691 : fold_build2_loc (input_location, MULT_EXPR,
9692 : size_type_node, slen, size));
9693 529 : gfc_add_expr_to_block (&body, tmp);
9694 :
9695 : /* Increment count. */
9696 529 : tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9697 : count, size_one_node);
9698 529 : gfc_add_modify (&body, count, tmp);
9699 :
9700 : /* Build the loop. */
9701 529 : tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9702 529 : gfc_add_expr_to_block (&block, tmp);
9703 :
9704 : /* Add the exit label. */
9705 529 : tmp = build1_v (LABEL_EXPR, exit_label);
9706 529 : gfc_add_expr_to_block (&block, tmp);
9707 :
9708 : /* Finish the block. */
9709 529 : tmp = gfc_finish_block (&block);
9710 529 : gfc_add_expr_to_block (&se->pre, tmp);
9711 :
9712 : /* Set the result value. */
9713 529 : se->expr = dest;
9714 529 : se->string_length = dlen;
9715 529 : }
9716 :
9717 :
9718 : /* Generate code for the IARGC intrinsic. */
9719 :
9720 : static void
9721 12 : gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9722 : {
9723 12 : tree tmp;
9724 12 : tree fndecl;
9725 12 : tree type;
9726 :
9727 : /* Call the library function. This always returns an INTEGER(4). */
9728 12 : fndecl = gfor_fndecl_iargc;
9729 12 : tmp = build_call_expr_loc (input_location,
9730 : fndecl, 0);
9731 :
9732 : /* Convert it to the required type. */
9733 12 : type = gfc_typenode_for_spec (&expr->ts);
9734 12 : tmp = fold_convert (type, tmp);
9735 :
9736 12 : se->expr = tmp;
9737 12 : }
9738 :
9739 :
9740 : /* Generate code for the KILL intrinsic. */
9741 :
9742 : static void
9743 8 : conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9744 : {
9745 8 : tree *args;
9746 8 : tree int4_type_node = gfc_get_int_type (4);
9747 8 : tree pid;
9748 8 : tree sig;
9749 8 : tree tmp;
9750 8 : unsigned int num_args;
9751 :
9752 8 : num_args = gfc_intrinsic_argument_list_length (expr);
9753 8 : args = XALLOCAVEC (tree, num_args);
9754 8 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
9755 :
9756 : /* Convert PID to a INTEGER(4) entity. */
9757 8 : pid = convert (int4_type_node, args[0]);
9758 :
9759 : /* Convert SIG to a INTEGER(4) entity. */
9760 8 : sig = convert (int4_type_node, args[1]);
9761 :
9762 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9763 :
9764 8 : se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9765 8 : }
9766 :
9767 :
9768 : static tree
9769 15 : conv_intrinsic_kill_sub (gfc_code *code)
9770 : {
9771 15 : stmtblock_t block;
9772 15 : gfc_se se, se_stat;
9773 15 : tree int4_type_node = gfc_get_int_type (4);
9774 15 : tree pid;
9775 15 : tree sig;
9776 15 : tree statp;
9777 15 : tree tmp;
9778 :
9779 : /* Make the function call. */
9780 15 : gfc_init_block (&block);
9781 15 : gfc_init_se (&se, NULL);
9782 :
9783 : /* Convert PID to a INTEGER(4) entity. */
9784 15 : gfc_conv_expr (&se, code->ext.actual->expr);
9785 15 : gfc_add_block_to_block (&block, &se.pre);
9786 15 : pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9787 15 : gfc_add_block_to_block (&block, &se.post);
9788 :
9789 : /* Convert SIG to a INTEGER(4) entity. */
9790 15 : gfc_conv_expr (&se, code->ext.actual->next->expr);
9791 15 : gfc_add_block_to_block (&block, &se.pre);
9792 15 : sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9793 15 : gfc_add_block_to_block (&block, &se.post);
9794 :
9795 : /* Deal with an optional STATUS. */
9796 15 : if (code->ext.actual->next->next->expr)
9797 : {
9798 10 : gfc_init_se (&se_stat, NULL);
9799 10 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
9800 10 : statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9801 : }
9802 : else
9803 : statp = NULL_TREE;
9804 :
9805 25 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9806 10 : statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9807 :
9808 15 : gfc_add_expr_to_block (&block, tmp);
9809 :
9810 15 : if (statp && statp != se_stat.expr)
9811 10 : gfc_add_modify (&block, se_stat.expr,
9812 10 : fold_convert (TREE_TYPE (se_stat.expr), statp));
9813 :
9814 15 : return gfc_finish_block (&block);
9815 : }
9816 :
9817 :
9818 :
9819 : /* The loc intrinsic returns the address of its argument as
9820 : gfc_index_integer_kind integer. */
9821 :
9822 : static void
9823 8908 : gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9824 : {
9825 8908 : tree temp_var;
9826 8908 : gfc_expr *arg_expr;
9827 :
9828 8908 : gcc_assert (!se->ss);
9829 :
9830 8908 : arg_expr = expr->value.function.actual->expr;
9831 8908 : if (arg_expr->rank == 0)
9832 : {
9833 6491 : if (arg_expr->ts.type == BT_CLASS)
9834 18 : gfc_add_data_component (arg_expr);
9835 6491 : gfc_conv_expr_reference (se, arg_expr);
9836 : }
9837 2417 : else if (gfc_is_simply_contiguous (arg_expr, false, false))
9838 2380 : gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9839 : else
9840 : {
9841 37 : gfc_conv_expr_descriptor (se, arg_expr);
9842 37 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9843 : }
9844 8908 : se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9845 8908 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9846 :
9847 : /* Create a temporary variable for loc return value. Without this,
9848 : we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9849 8908 : temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9850 8908 : gfc_add_modify (&se->pre, temp_var, se->expr);
9851 8908 : se->expr = temp_var;
9852 8908 : }
9853 :
9854 : /* The following routine generates code for the intrinsic functions from
9855 : the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
9856 : F_C_STRING. */
9857 :
9858 : static void
9859 9879 : conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9860 : {
9861 9879 : gfc_actual_arglist *arg = expr->value.function.actual;
9862 :
9863 9879 : if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9864 : {
9865 7489 : if (arg->expr->rank == 0)
9866 2010 : gfc_conv_expr_reference (se, arg->expr);
9867 5479 : else if (gfc_is_simply_contiguous (arg->expr, false, false))
9868 4395 : gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9869 : else
9870 : {
9871 1084 : gfc_conv_expr_descriptor (se, arg->expr);
9872 1084 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9873 : }
9874 :
9875 : /* TODO -- the following two lines shouldn't be necessary, but if
9876 : they're removed, a bug is exposed later in the code path.
9877 : This workaround was thus introduced, but will have to be
9878 : removed; please see PR 35150 for details about the issue. */
9879 7489 : se->expr = convert (pvoid_type_node, se->expr);
9880 7489 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9881 : }
9882 2390 : else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9883 : {
9884 260 : gfc_conv_expr_reference (se, arg->expr);
9885 260 : if (arg->expr->symtree->n.sym->attr.proc_pointer
9886 29 : && arg->expr->symtree->n.sym->attr.dummy)
9887 7 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9888 : /* The code below is necessary to create a reference from the calling
9889 : subprogram to the argument of C_FUNLOC() in the call graph.
9890 : Please see PR 117303 for more details. */
9891 260 : se->expr = convert (pvoid_type_node, se->expr);
9892 260 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9893 : }
9894 2130 : else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9895 : {
9896 2054 : gfc_se arg1se;
9897 2054 : gfc_se arg2se;
9898 :
9899 : /* Build the addr_expr for the first argument. The argument is
9900 : already an *address* so we don't need to set want_pointer in
9901 : the gfc_se. */
9902 2054 : gfc_init_se (&arg1se, NULL);
9903 2054 : gfc_conv_expr (&arg1se, arg->expr);
9904 2054 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9905 2054 : gfc_add_block_to_block (&se->post, &arg1se.post);
9906 :
9907 : /* See if we were given two arguments. */
9908 2054 : if (arg->next->expr == NULL)
9909 : /* Only given one arg so generate a null and do a
9910 : not-equal comparison against the first arg. */
9911 1675 : se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9912 : arg1se.expr,
9913 1675 : fold_convert (TREE_TYPE (arg1se.expr),
9914 : null_pointer_node));
9915 : else
9916 : {
9917 379 : tree eq_expr;
9918 379 : tree not_null_expr;
9919 :
9920 : /* Given two arguments so build the arg2se from second arg. */
9921 379 : gfc_init_se (&arg2se, NULL);
9922 379 : gfc_conv_expr (&arg2se, arg->next->expr);
9923 379 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9924 379 : gfc_add_block_to_block (&se->post, &arg2se.post);
9925 :
9926 : /* Generate test to compare that the two args are equal. */
9927 379 : eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9928 : arg1se.expr, arg2se.expr);
9929 : /* Generate test to ensure that the first arg is not null. */
9930 379 : not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9931 : logical_type_node,
9932 : arg1se.expr, null_pointer_node);
9933 :
9934 : /* Finally, the generated test must check that both arg1 is not
9935 : NULL and that it is equal to the second arg. */
9936 379 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9937 : logical_type_node,
9938 : not_null_expr, eq_expr);
9939 : }
9940 : }
9941 76 : else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
9942 : {
9943 : /* There are three cases:
9944 : f_c_string(string) -> trim(string) // c_null_char
9945 : f_c_string(string, .false.) -> trim(string) // c_null_char
9946 : f_c_string(string, .true.) -> string // c_null_char */
9947 :
9948 76 : gfc_expr *string = arg->expr;
9949 76 : gfc_expr *asis = arg->next->expr;
9950 76 : bool need_asis = false, need_trim = false;
9951 76 : gfc_se asis_se;
9952 :
9953 76 : if (!asis)
9954 : {
9955 : need_trim = true;
9956 : need_asis = false;
9957 : }
9958 54 : else if (asis->expr_type == EXPR_CONSTANT)
9959 : {
9960 32 : need_asis = asis->value.logical;
9961 32 : need_trim = !need_asis;
9962 : }
9963 : else
9964 : {
9965 : /* A conditional expression is needed. */
9966 22 : need_asis = true;
9967 22 : need_trim = true;
9968 22 : gfc_init_se (&asis_se, se);
9969 22 : gfc_conv_expr (&asis_se, asis);
9970 22 : if (asis->expr_type == EXPR_VARIABLE
9971 22 : && asis->symtree->n.sym->attr.dummy
9972 10 : && asis->symtree->n.sym->attr.optional)
9973 : {
9974 6 : tree present = gfc_conv_expr_present (asis->symtree->n.sym);
9975 6 : asis_se.expr
9976 6 : = build3_loc (input_location, COND_EXPR,
9977 : logical_type_node, present,
9978 : asis_se.expr, logical_false_node);
9979 : }
9980 22 : gfc_make_safe_expr (&asis_se);
9981 : }
9982 :
9983 : /* Handle the case of a constant string argument first. */
9984 76 : if (string->expr_type == EXPR_CONSTANT)
9985 : {
9986 : /* Output for the asis "then" case goes tlen/tstr, and the
9987 : trimmed case in elen/estr. */
9988 34 : tree elen, estr, tlen, tstr;
9989 34 : elen = estr = tlen = tstr = NULL_TREE;
9990 :
9991 34 : gfc_char_t *orig_string = string->value.character.string;
9992 34 : gfc_charlen_t orig_len = string->value.character.length;
9993 34 : gfc_charlen_t n;
9994 34 : gfc_char_t *buf
9995 34 : = (gfc_char_t *) alloca ((orig_len + 1) * sizeof (gfc_char_t));
9996 34 : memcpy (buf, orig_string, orig_len * sizeof (gfc_char_t));
9997 34 : buf[orig_len] = '\0';
9998 34 : int kind = gfc_default_character_kind;
9999 34 : gcc_assert (string->ts.kind == kind);
10000 :
10001 : /* Build the new string constant(s). */
10002 34 : if (need_asis)
10003 : {
10004 14 : tstr = gfc_build_wide_string_const (kind, orig_len + 1, buf);
10005 14 : tlen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tstr)));
10006 14 : if (!need_trim)
10007 : {
10008 10 : se->expr = tstr;
10009 10 : se->string_length = tlen;
10010 10 : return;
10011 : }
10012 : }
10013 24 : if (need_trim)
10014 : {
10015 72 : for (n = orig_len; n; n--)
10016 72 : if (buf[n - 1] != ' ')
10017 : break;
10018 24 : buf[n] = '\0';
10019 24 : if (need_asis && n == orig_len)
10020 : {
10021 : /* Special case; trimming is a no-op. Add side-effects
10022 : from the condition and then just return the string
10023 : without a conditional. */
10024 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10025 2 : se->expr = tstr;
10026 2 : se->string_length = tlen;
10027 2 : return;
10028 : }
10029 : else
10030 : {
10031 22 : estr = gfc_build_wide_string_const (kind, n + 1, buf);
10032 22 : elen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (estr)));
10033 : }
10034 22 : if (!need_asis)
10035 : {
10036 20 : se->expr = estr;
10037 20 : se->string_length = elen;
10038 20 : return;
10039 : }
10040 : }
10041 0 : gcc_assert (need_asis && need_trim);
10042 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10043 2 : se->expr
10044 2 : = fold_build3_loc (input_location, COND_EXPR,
10045 : pchar_type_node, asis_se.expr,
10046 : tstr, estr);
10047 2 : se->string_length
10048 2 : = fold_build3_loc (input_location, COND_EXPR,
10049 : gfc_charlen_type_node, asis_se.expr,
10050 : tlen, elen);
10051 2 : return;
10052 : }
10053 : else
10054 : /* We have to generate code to do the string transformation(s) at
10055 : runtime. */
10056 : {
10057 42 : tree tmp;
10058 :
10059 : /* Convert input string. */
10060 42 : gfc_se sse;
10061 42 : gfc_init_se (&sse, se);
10062 42 : gfc_conv_expr (&sse, string);
10063 42 : gfc_conv_string_parameter (&sse);
10064 42 : gfc_make_safe_expr (&sse);
10065 42 : gfc_add_block_to_block (&se->pre, &sse.pre);
10066 :
10067 : /* Use a temporary for the (possibly trimmed) string length. */
10068 42 : tree lenvar = gfc_create_var (gfc_charlen_type_node, NULL);
10069 42 : gfc_add_modify (&se->pre, lenvar, sse.string_length);
10070 :
10071 : /* Build the expression for a call to LEN_TRIM if we may need
10072 : to trim the string. If it's conditional, handle that too. */
10073 42 : if (need_trim)
10074 : {
10075 36 : tree trimlen
10076 36 : = build_call_expr_loc (input_location,
10077 : gfor_fndecl_string_len_trim, 2,
10078 : lenvar, sse.expr);
10079 36 : if (need_asis)
10080 : {
10081 18 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10082 18 : tmp = fold_build3_loc (input_location, COND_EXPR,
10083 : gfc_charlen_type_node, asis_se.expr,
10084 : lenvar, trimlen);
10085 18 : gfc_add_modify (&se->pre, lenvar, tmp);
10086 : }
10087 : else
10088 18 : gfc_add_modify (&se->pre, lenvar, trimlen);
10089 : }
10090 :
10091 : /* Allocate a new string newvar that is lenvar+1 bytes long.
10092 : memcpy the first lenvar bytes from the input string, and
10093 : add a null character. Note that lenvar, the length of
10094 : the (trimmed) original string, has type gfc_charlen_type_node,
10095 : but newlen is size_type_node. */
10096 42 : tree string_type_node = build_pointer_type (char_type_node);
10097 42 : tree newvar = gfc_create_var (string_type_node, NULL);
10098 42 : tree newlen = fold_build2_loc (input_location, PLUS_EXPR,
10099 : size_type_node,
10100 : fold_convert (size_type_node,
10101 : lenvar),
10102 : size_one_node);
10103 42 : gfc_add_modify (&se->pre, newvar,
10104 : gfc_call_malloc (&se->pre, string_type_node,
10105 : newlen));
10106 42 : tmp = build_call_expr_loc (input_location,
10107 : builtin_decl_explicit (BUILT_IN_MEMCPY),
10108 : 3,
10109 : fold_convert (pvoid_type_node, newvar),
10110 : fold_convert (pvoid_type_node, sse.expr),
10111 : fold_convert (size_type_node, lenvar));
10112 42 : gfc_add_expr_to_block (&se->pre, tmp);
10113 42 : tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
10114 : string_type_node, newvar,
10115 : fold_convert (size_type_node, lenvar));
10116 42 : tmp = fold_build1_loc (input_location, INDIRECT_REF,
10117 : char_type_node, tmp);
10118 42 : gfc_add_modify (&se->pre, tmp,
10119 : fold_convert (char_type_node, integer_zero_node));
10120 :
10121 : /* Remember to free the string later. */
10122 42 : tmp = gfc_call_free (newvar);
10123 42 : gfc_add_expr_to_block (&se->post, tmp);
10124 :
10125 : /* Return the result. */
10126 42 : se->expr = newvar;
10127 42 : se->string_length = fold_convert (gfc_charlen_type_node, newlen);
10128 42 : return;
10129 : }
10130 : }
10131 : else
10132 0 : gcc_unreachable ();
10133 : }
10134 :
10135 :
10136 : /* The following routine generates code for the intrinsic
10137 : subroutines from the ISO_C_BINDING module:
10138 : * C_F_POINTER
10139 : * C_F_PROCPOINTER. */
10140 :
10141 : static tree
10142 3303 : conv_isocbinding_subroutine (gfc_code *code)
10143 : {
10144 3303 : gfc_expr *cptr, *fptr, *shape, *lower;
10145 3303 : gfc_se se, cptrse, fptrse, shapese, lowerse;
10146 3303 : gfc_ss *shape_ss, *lower_ss;
10147 3303 : tree desc, dim, tmp, stride, offset, lbound, ubound;
10148 3303 : stmtblock_t body, block;
10149 3303 : gfc_loopinfo loop;
10150 3303 : gfc_actual_arglist *arg;
10151 :
10152 3303 : arg = code->ext.actual;
10153 3303 : cptr = arg->expr;
10154 3303 : fptr = arg->next->expr;
10155 3303 : shape = arg->next->next ? arg->next->next->expr : NULL;
10156 3221 : lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
10157 :
10158 3303 : gfc_init_se (&se, NULL);
10159 3303 : gfc_init_se (&cptrse, NULL);
10160 3303 : gfc_conv_expr (&cptrse, cptr);
10161 3303 : gfc_add_block_to_block (&se.pre, &cptrse.pre);
10162 3303 : gfc_add_block_to_block (&se.post, &cptrse.post);
10163 :
10164 3303 : gfc_init_se (&fptrse, NULL);
10165 3303 : if (fptr->rank == 0)
10166 : {
10167 2818 : fptrse.want_pointer = 1;
10168 2818 : gfc_conv_expr (&fptrse, fptr);
10169 2818 : gfc_add_block_to_block (&se.pre, &fptrse.pre);
10170 2818 : gfc_add_block_to_block (&se.post, &fptrse.post);
10171 2818 : if (fptr->symtree->n.sym->attr.proc_pointer
10172 81 : && fptr->symtree->n.sym->attr.dummy)
10173 19 : fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
10174 2818 : se.expr
10175 2818 : = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
10176 : fptrse.expr,
10177 2818 : fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
10178 2818 : gfc_add_expr_to_block (&se.pre, se.expr);
10179 2818 : gfc_add_block_to_block (&se.pre, &se.post);
10180 2818 : return gfc_finish_block (&se.pre);
10181 : }
10182 :
10183 485 : gfc_start_block (&block);
10184 :
10185 : /* Get the descriptor of the Fortran pointer. */
10186 485 : fptrse.descriptor_only = 1;
10187 485 : gfc_conv_expr_descriptor (&fptrse, fptr);
10188 485 : gfc_add_block_to_block (&block, &fptrse.pre);
10189 485 : desc = fptrse.expr;
10190 :
10191 : /* Set the span field. */
10192 485 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
10193 485 : tmp = fold_convert (gfc_array_index_type, tmp);
10194 485 : gfc_conv_descriptor_span_set (&block, desc, tmp);
10195 :
10196 : /* Set data value, dtype, and offset. */
10197 485 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
10198 485 : gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
10199 485 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
10200 485 : gfc_get_dtype (TREE_TYPE (desc)));
10201 :
10202 : /* Start scalarization of the bounds, using the shape argument. */
10203 :
10204 485 : shape_ss = gfc_walk_expr (shape);
10205 485 : gcc_assert (shape_ss != gfc_ss_terminator);
10206 485 : gfc_init_se (&shapese, NULL);
10207 485 : if (lower)
10208 : {
10209 12 : lower_ss = gfc_walk_expr (lower);
10210 12 : gcc_assert (lower_ss != gfc_ss_terminator);
10211 12 : gfc_init_se (&lowerse, NULL);
10212 : }
10213 :
10214 485 : gfc_init_loopinfo (&loop);
10215 485 : gfc_add_ss_to_loop (&loop, shape_ss);
10216 485 : if (lower)
10217 12 : gfc_add_ss_to_loop (&loop, lower_ss);
10218 485 : gfc_conv_ss_startstride (&loop);
10219 485 : gfc_conv_loop_setup (&loop, &fptr->where);
10220 485 : gfc_mark_ss_chain_used (shape_ss, 1);
10221 485 : if (lower)
10222 12 : gfc_mark_ss_chain_used (lower_ss, 1);
10223 :
10224 485 : gfc_copy_loopinfo_to_se (&shapese, &loop);
10225 485 : shapese.ss = shape_ss;
10226 485 : if (lower)
10227 : {
10228 12 : gfc_copy_loopinfo_to_se (&lowerse, &loop);
10229 12 : lowerse.ss = lower_ss;
10230 : }
10231 :
10232 485 : stride = gfc_create_var (gfc_array_index_type, "stride");
10233 485 : offset = gfc_create_var (gfc_array_index_type, "offset");
10234 485 : gfc_add_modify (&block, stride, gfc_index_one_node);
10235 485 : gfc_add_modify (&block, offset, gfc_index_zero_node);
10236 :
10237 : /* Loop body. */
10238 485 : gfc_start_scalarized_body (&loop, &body);
10239 :
10240 485 : dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10241 : loop.loopvar[0], loop.from[0]);
10242 :
10243 485 : if (lower)
10244 : {
10245 12 : gfc_conv_expr (&lowerse, lower);
10246 12 : gfc_add_block_to_block (&body, &lowerse.pre);
10247 12 : lbound = fold_convert (gfc_array_index_type, lowerse.expr);
10248 12 : gfc_add_block_to_block (&body, &lowerse.post);
10249 : }
10250 : else
10251 473 : lbound = gfc_index_one_node;
10252 :
10253 : /* Set bounds and stride. */
10254 485 : gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
10255 485 : gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
10256 :
10257 485 : gfc_conv_expr (&shapese, shape);
10258 485 : gfc_add_block_to_block (&body, &shapese.pre);
10259 485 : ubound = fold_build2_loc (
10260 : input_location, MINUS_EXPR, gfc_array_index_type,
10261 : fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
10262 : fold_convert (gfc_array_index_type, shapese.expr)),
10263 : gfc_index_one_node);
10264 485 : gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
10265 485 : gfc_add_block_to_block (&body, &shapese.post);
10266 :
10267 : /* Calculate offset. */
10268 485 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10269 : stride, lbound);
10270 485 : gfc_add_modify (&body, offset,
10271 : fold_build2_loc (input_location, PLUS_EXPR,
10272 : gfc_array_index_type, offset, tmp));
10273 :
10274 : /* Update stride. */
10275 485 : gfc_add_modify (
10276 : &body, stride,
10277 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
10278 : fold_convert (gfc_array_index_type, shapese.expr)));
10279 : /* Finish scalarization loop. */
10280 485 : gfc_trans_scalarizing_loops (&loop, &body);
10281 485 : gfc_add_block_to_block (&block, &loop.pre);
10282 485 : gfc_add_block_to_block (&block, &loop.post);
10283 485 : gfc_add_block_to_block (&block, &fptrse.post);
10284 485 : gfc_cleanup_loop (&loop);
10285 :
10286 485 : gfc_add_modify (&block, offset,
10287 : fold_build1_loc (input_location, NEGATE_EXPR,
10288 : gfc_array_index_type, offset));
10289 485 : gfc_conv_descriptor_offset_set (&block, desc, offset);
10290 :
10291 485 : gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
10292 485 : gfc_add_block_to_block (&se.pre, &se.post);
10293 485 : return gfc_finish_block (&se.pre);
10294 : }
10295 :
10296 :
10297 : /* The following routine generates code for both forms of the intrinsic
10298 : subroutine C_F_STRPOINTER from the ISO_C_BINDING module. */
10299 : static tree
10300 60 : conv_isocbinding_subroutine_strpointer (gfc_code *code)
10301 : {
10302 60 : gfc_actual_arglist *arg = code->ext.actual;
10303 60 : gfc_expr *arg0 = arg->expr;
10304 60 : gfc_expr *fstrptr = arg->next->expr;
10305 60 : gfc_expr *nchars = arg->next->next->expr;
10306 60 : tree ptr;
10307 60 : tree size = NULL_TREE;
10308 60 : tree nc = NULL_TREE;
10309 60 : tree fstrptr_ptr, fstrptr_len;
10310 60 : stmtblock_t block;
10311 60 : gfc_init_block (&block);
10312 60 : gfc_se se0, se1, se2;
10313 60 : gfc_init_se (&se0, NULL);
10314 60 : gfc_init_se (&se1, NULL);
10315 60 : gfc_init_se (&se2, NULL);
10316 :
10317 : /* arg0 can either be a simply contiguous rank-one character array,
10318 : or a scalar of type c_ptr that points to a contiguous array.
10319 : In the first case nchars may be omitted and defaults to the size
10320 : of the array. */
10321 60 : if (arg0->rank == 1)
10322 : {
10323 42 : gfc_array_ref *ar = gfc_find_array_ref (arg0);
10324 42 : if (ar->as && ar->as->type == AS_ASSUMED_SIZE
10325 12 : && (ar->type == AR_FULL || ar->end[0] == nullptr))
10326 : /* No size available. */
10327 12 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, NULL);
10328 : else
10329 : {
10330 30 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, &size);
10331 30 : gcc_assert (size);
10332 : }
10333 42 : ptr = se0.expr;
10334 : }
10335 18 : else if (arg0->rank == 0)
10336 : {
10337 : /* Scalar case. arg0 is a C pointer to the string, and the
10338 : nchars argument is required. */
10339 18 : gfc_conv_expr (&se0, arg0);
10340 18 : ptr = se0.expr;
10341 : /* We already issued a diagnostic for this in parsing. */
10342 18 : gcc_assert (nchars);
10343 : }
10344 : else
10345 0 : gcc_unreachable ();
10346 :
10347 : /* Translate the fortran array pointer argument. AFAICT the
10348 : representation here is that this returns the pointer location in
10349 : se1.expr and there is a separate decl for the length.
10350 : Of course none of this is properly documented.... :-( */
10351 60 : gfc_conv_expr (&se1, fstrptr);
10352 60 : fstrptr_ptr = se1.expr;
10353 60 : gcc_assert (fstrptr->ts.u.cl && fstrptr->ts.u.cl->backend_decl);
10354 60 : fstrptr_len = fstrptr->ts.u.cl->backend_decl;
10355 :
10356 : /* Translate nchars, if provided. If we have both the array size
10357 : and nchars, take the minimum value. NC is the tree expr to hold
10358 : the value. */
10359 60 : if (nchars)
10360 : {
10361 30 : gfc_conv_expr (&se2, nchars);
10362 30 : nc = se2.expr;
10363 30 : if (size)
10364 0 : nc = fold_build2_loc (input_location, MIN_EXPR,
10365 0 : TREE_TYPE (nc), nc, size);
10366 : /* Check for the case where an optional dummy parameter is
10367 : passed as the optional nchars argument. It's not supposed to
10368 : be omitted if we don't also have an array size; rather than
10369 : produce a run-time error, assume size 0. */
10370 30 : if (nchars->expr_type == EXPR_VARIABLE
10371 18 : && nchars->symtree->n.sym->attr.dummy
10372 18 : && nchars->symtree->n.sym->attr.optional)
10373 : {
10374 12 : tree present = gfc_conv_expr_present (nchars->symtree->n.sym);
10375 12 : nc = build3_loc (input_location, COND_EXPR,
10376 12 : TREE_TYPE (nc), present, nc,
10377 24 : size ? size : build_int_cst (TREE_TYPE (nc), 0));
10378 : }
10379 : }
10380 : else
10381 : {
10382 30 : gcc_assert (size);
10383 : nc = size;
10384 : }
10385 :
10386 : /* Collect argument side-effect statements. */
10387 60 : gfc_add_block_to_block (&block, &se0.pre);
10388 60 : gfc_add_block_to_block (&block, &se1.pre);
10389 60 : gfc_add_block_to_block (&block, &se2.pre);
10390 :
10391 : /* Generate a call to builtin_strnlen to get the C string length
10392 : for the output fstrptr. */
10393 60 : ptr = gfc_evaluate_now (ptr, &block);
10394 60 : size = build_call_expr_loc (input_location,
10395 : builtin_decl_explicit (BUILT_IN_STRNLEN), 2,
10396 : fold_convert (const_ptr_type_node, ptr),
10397 : fold_convert (size_type_node, nc));
10398 :
10399 : /* Stuff the raw C char pointer PTR and actual length SIZE into fstrptr. */
10400 60 : gfc_add_modify (&block, fstrptr_ptr,
10401 60 : fold_convert (TREE_TYPE (fstrptr_ptr), ptr));
10402 60 : gfc_add_modify (&block, fstrptr_len,
10403 : fold_convert (gfc_charlen_type_node, size));
10404 :
10405 : /* Collect argument cleanups. */
10406 60 : gfc_add_block_to_block (&block, &se2.post);
10407 60 : gfc_add_block_to_block (&block, &se1.post);
10408 60 : gfc_add_block_to_block (&block, &se0.post);
10409 :
10410 60 : return gfc_finish_block (&block);
10411 : }
10412 :
10413 : /* Save and restore floating-point state. */
10414 :
10415 : tree
10416 941 : gfc_save_fp_state (stmtblock_t *block)
10417 : {
10418 941 : tree type, fpstate, tmp;
10419 :
10420 941 : type = build_array_type (char_type_node,
10421 : build_range_type (size_type_node, size_zero_node,
10422 : size_int (GFC_FPE_STATE_BUFFER_SIZE)));
10423 941 : fpstate = gfc_create_var (type, "fpstate");
10424 941 : fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
10425 :
10426 941 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
10427 : 1, fpstate);
10428 941 : gfc_add_expr_to_block (block, tmp);
10429 :
10430 941 : return fpstate;
10431 : }
10432 :
10433 :
10434 : void
10435 941 : gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
10436 : {
10437 941 : tree tmp;
10438 :
10439 941 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
10440 : 1, fpstate);
10441 941 : gfc_add_expr_to_block (block, tmp);
10442 941 : }
10443 :
10444 :
10445 : /* Generate code for arguments of IEEE functions. */
10446 :
10447 : static void
10448 12457 : conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
10449 : int nargs)
10450 : {
10451 12457 : gfc_actual_arglist *actual;
10452 12457 : gfc_expr *e;
10453 12457 : gfc_se argse;
10454 12457 : int arg;
10455 :
10456 12457 : actual = expr->value.function.actual;
10457 34461 : for (arg = 0; arg < nargs; arg++, actual = actual->next)
10458 : {
10459 22004 : gcc_assert (actual);
10460 22004 : e = actual->expr;
10461 :
10462 22004 : gfc_init_se (&argse, se);
10463 22004 : gfc_conv_expr_val (&argse, e);
10464 :
10465 22004 : gfc_add_block_to_block (&se->pre, &argse.pre);
10466 22004 : gfc_add_block_to_block (&se->post, &argse.post);
10467 22004 : argarray[arg] = argse.expr;
10468 : }
10469 12457 : }
10470 :
10471 :
10472 : /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
10473 : and IEEE_UNORDERED, which translate directly to GCC type-generic
10474 : built-ins. */
10475 :
10476 : static void
10477 1062 : conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
10478 : enum built_in_function code, int nargs)
10479 : {
10480 1062 : tree args[2];
10481 1062 : gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
10482 :
10483 1062 : conv_ieee_function_args (se, expr, args, nargs);
10484 1062 : se->expr = build_call_expr_loc_array (input_location,
10485 : builtin_decl_explicit (code),
10486 : nargs, args);
10487 2388 : STRIP_TYPE_NOPS (se->expr);
10488 1062 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10489 1062 : }
10490 :
10491 :
10492 : /* Generate code for intrinsics IEEE_SIGNBIT. */
10493 :
10494 : static void
10495 624 : conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
10496 : {
10497 624 : tree arg, signbit;
10498 :
10499 624 : conv_ieee_function_args (se, expr, &arg, 1);
10500 624 : signbit = build_call_expr_loc (input_location,
10501 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10502 : 1, arg);
10503 624 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10504 : signbit, integer_zero_node);
10505 624 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
10506 624 : }
10507 :
10508 :
10509 : /* Generate code for IEEE_IS_NORMAL intrinsic:
10510 : IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
10511 :
10512 : static void
10513 312 : conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
10514 : {
10515 312 : tree arg, isnormal, iszero;
10516 :
10517 : /* Convert arg, evaluate it only once. */
10518 312 : conv_ieee_function_args (se, expr, &arg, 1);
10519 312 : arg = gfc_evaluate_now (arg, &se->pre);
10520 :
10521 312 : isnormal = build_call_expr_loc (input_location,
10522 : builtin_decl_explicit (BUILT_IN_ISNORMAL),
10523 : 1, arg);
10524 312 : iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
10525 312 : build_real_from_int_cst (TREE_TYPE (arg),
10526 312 : integer_zero_node));
10527 312 : se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10528 : logical_type_node, isnormal, iszero);
10529 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10530 312 : }
10531 :
10532 :
10533 : /* Generate code for IEEE_IS_NEGATIVE intrinsic:
10534 : IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10535 :
10536 : static void
10537 312 : conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
10538 : {
10539 312 : tree arg, signbit, isnan;
10540 :
10541 : /* Convert arg, evaluate it only once. */
10542 312 : conv_ieee_function_args (se, expr, &arg, 1);
10543 312 : arg = gfc_evaluate_now (arg, &se->pre);
10544 :
10545 312 : isnan = build_call_expr_loc (input_location,
10546 : builtin_decl_explicit (BUILT_IN_ISNAN),
10547 : 1, arg);
10548 936 : STRIP_TYPE_NOPS (isnan);
10549 :
10550 312 : signbit = build_call_expr_loc (input_location,
10551 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10552 : 1, arg);
10553 312 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10554 : signbit, integer_zero_node);
10555 :
10556 312 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10557 : logical_type_node, signbit,
10558 : fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10559 312 : TREE_TYPE(isnan), isnan));
10560 :
10561 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10562 312 : }
10563 :
10564 :
10565 : /* Generate code for IEEE_LOGB and IEEE_RINT. */
10566 :
10567 : static void
10568 240 : conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
10569 : enum built_in_function code)
10570 : {
10571 240 : tree arg, decl, call, fpstate;
10572 240 : int argprec;
10573 :
10574 240 : conv_ieee_function_args (se, expr, &arg, 1);
10575 240 : argprec = TYPE_PRECISION (TREE_TYPE (arg));
10576 240 : decl = builtin_decl_for_precision (code, argprec);
10577 :
10578 : /* Save floating-point state. */
10579 240 : fpstate = gfc_save_fp_state (&se->pre);
10580 :
10581 : /* Make the function call. */
10582 240 : call = build_call_expr_loc (input_location, decl, 1, arg);
10583 240 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
10584 :
10585 : /* Restore floating-point state. */
10586 240 : gfc_restore_fp_state (&se->post, fpstate);
10587 240 : }
10588 :
10589 :
10590 : /* Generate code for IEEE_REM. */
10591 :
10592 : static void
10593 84 : conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
10594 : {
10595 84 : tree args[2], decl, call, fpstate;
10596 84 : int argprec;
10597 :
10598 84 : conv_ieee_function_args (se, expr, args, 2);
10599 :
10600 : /* If arguments have unequal size, convert them to the larger. */
10601 84 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
10602 84 : > TYPE_PRECISION (TREE_TYPE (args[1])))
10603 6 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10604 78 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
10605 78 : > TYPE_PRECISION (TREE_TYPE (args[0])))
10606 24 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
10607 :
10608 84 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10609 84 : decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
10610 :
10611 : /* Save floating-point state. */
10612 84 : fpstate = gfc_save_fp_state (&se->pre);
10613 :
10614 : /* Make the function call. */
10615 84 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10616 84 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10617 :
10618 : /* Restore floating-point state. */
10619 84 : gfc_restore_fp_state (&se->post, fpstate);
10620 84 : }
10621 :
10622 :
10623 : /* Generate code for IEEE_NEXT_AFTER. */
10624 :
10625 : static void
10626 180 : conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
10627 : {
10628 180 : tree args[2], decl, call, fpstate;
10629 180 : int argprec;
10630 :
10631 180 : conv_ieee_function_args (se, expr, args, 2);
10632 :
10633 : /* Result has the characteristics of first argument. */
10634 180 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10635 180 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10636 180 : decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
10637 :
10638 : /* Save floating-point state. */
10639 180 : fpstate = gfc_save_fp_state (&se->pre);
10640 :
10641 : /* Make the function call. */
10642 180 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10643 180 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10644 :
10645 : /* Restore floating-point state. */
10646 180 : gfc_restore_fp_state (&se->post, fpstate);
10647 180 : }
10648 :
10649 :
10650 : /* Generate code for IEEE_SCALB. */
10651 :
10652 : static void
10653 228 : conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10654 : {
10655 228 : tree args[2], decl, call, huge, type;
10656 228 : int argprec, n;
10657 :
10658 228 : conv_ieee_function_args (se, expr, args, 2);
10659 :
10660 : /* Result has the characteristics of first argument. */
10661 228 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10662 228 : decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10663 :
10664 228 : if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10665 : {
10666 : /* We need to fold the integer into the range of a C int. */
10667 18 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10668 18 : type = TREE_TYPE (args[1]);
10669 :
10670 18 : n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10671 18 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10672 : gfc_c_int_kind);
10673 18 : huge = fold_convert (type, huge);
10674 18 : args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10675 : huge);
10676 18 : args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10677 : fold_build1_loc (input_location, NEGATE_EXPR,
10678 : type, huge));
10679 : }
10680 :
10681 228 : args[1] = fold_convert (integer_type_node, args[1]);
10682 :
10683 : /* Make the function call. */
10684 228 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10685 228 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10686 228 : }
10687 :
10688 :
10689 : /* Generate code for IEEE_COPY_SIGN. */
10690 :
10691 : static void
10692 576 : conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10693 : {
10694 576 : tree args[2], decl, sign;
10695 576 : int argprec;
10696 :
10697 576 : conv_ieee_function_args (se, expr, args, 2);
10698 :
10699 : /* Get the sign of the second argument. */
10700 576 : sign = build_call_expr_loc (input_location,
10701 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10702 : 1, args[1]);
10703 576 : sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10704 : sign, integer_zero_node);
10705 :
10706 : /* Create a value of one, with the right sign. */
10707 576 : sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10708 : sign,
10709 : fold_build1_loc (input_location, NEGATE_EXPR,
10710 : integer_type_node,
10711 : integer_one_node),
10712 : integer_one_node);
10713 576 : args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10714 :
10715 576 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10716 576 : decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10717 :
10718 576 : se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10719 576 : }
10720 :
10721 :
10722 : /* Generate code for IEEE_CLASS. */
10723 :
10724 : static void
10725 648 : conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10726 : {
10727 648 : tree arg, c, t1, t2, t3, t4;
10728 :
10729 : /* Convert arg, evaluate it only once. */
10730 648 : conv_ieee_function_args (se, expr, &arg, 1);
10731 648 : arg = gfc_evaluate_now (arg, &se->pre);
10732 :
10733 648 : c = build_call_expr_loc (input_location,
10734 : builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
10735 : build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10736 : build_int_cst (integer_type_node,
10737 : IEEE_POSITIVE_INF),
10738 : build_int_cst (integer_type_node,
10739 : IEEE_POSITIVE_NORMAL),
10740 : build_int_cst (integer_type_node,
10741 : IEEE_POSITIVE_DENORMAL),
10742 : build_int_cst (integer_type_node,
10743 : IEEE_POSITIVE_ZERO),
10744 : arg);
10745 648 : c = gfc_evaluate_now (c, &se->pre);
10746 648 : t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10747 : c, build_int_cst (integer_type_node,
10748 : IEEE_QUIET_NAN));
10749 648 : t2 = build_call_expr_loc (input_location,
10750 : builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
10751 : arg);
10752 648 : t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10753 648 : t2, build_zero_cst (TREE_TYPE (t2)));
10754 648 : t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10755 : logical_type_node, t1, t2);
10756 648 : t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10757 : c, build_int_cst (integer_type_node,
10758 : IEEE_POSITIVE_ZERO));
10759 648 : t4 = build_call_expr_loc (input_location,
10760 : builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
10761 : arg);
10762 648 : t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10763 648 : t4, build_zero_cst (TREE_TYPE (t4)));
10764 648 : t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10765 : logical_type_node, t3, t4);
10766 648 : int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10767 648 : gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10768 648 : gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10769 648 : gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10770 648 : gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10771 648 : gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10772 648 : t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10773 648 : build_int_cst (TREE_TYPE (c), s), c);
10774 648 : t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10775 : t3, t4, c);
10776 648 : t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10777 648 : build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10778 : t3);
10779 648 : tree type = gfc_typenode_for_spec (&expr->ts);
10780 : /* Perform a quick sanity check that the return type is
10781 : IEEE_CLASS_TYPE derived type defined in
10782 : libgfortran/ieee/ieee_arithmetic.F90
10783 : Primarily check that it is a derived type with a single
10784 : member in it. */
10785 648 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10786 648 : tree field = NULL_TREE;
10787 1296 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10788 648 : if (TREE_CODE (f) == FIELD_DECL)
10789 : {
10790 648 : gcc_assert (field == NULL_TREE);
10791 : field = f;
10792 : }
10793 648 : gcc_assert (field);
10794 648 : t1 = fold_convert (TREE_TYPE (field), t1);
10795 648 : se->expr = build_constructor_single (type, field, t1);
10796 648 : }
10797 :
10798 :
10799 : /* Generate code for IEEE_VALUE. */
10800 :
10801 : static void
10802 1111 : conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10803 : {
10804 1111 : tree args[2], arg, ret, tmp;
10805 1111 : stmtblock_t body;
10806 :
10807 : /* Convert args, evaluate the second one only once. */
10808 1111 : conv_ieee_function_args (se, expr, args, 2);
10809 1111 : arg = gfc_evaluate_now (args[1], &se->pre);
10810 :
10811 1111 : tree type = TREE_TYPE (arg);
10812 : /* Perform a quick sanity check that the second argument's type is
10813 : IEEE_CLASS_TYPE derived type defined in
10814 : libgfortran/ieee/ieee_arithmetic.F90
10815 : Primarily check that it is a derived type with a single
10816 : member in it. */
10817 1111 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10818 1111 : tree field = NULL_TREE;
10819 2222 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10820 1111 : if (TREE_CODE (f) == FIELD_DECL)
10821 : {
10822 1111 : gcc_assert (field == NULL_TREE);
10823 : field = f;
10824 : }
10825 1111 : gcc_assert (field);
10826 1111 : arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10827 : arg, field, NULL_TREE);
10828 1111 : arg = gfc_evaluate_now (arg, &se->pre);
10829 :
10830 1111 : type = gfc_typenode_for_spec (&expr->ts);
10831 1111 : gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10832 1111 : ret = gfc_create_var (type, NULL);
10833 :
10834 1111 : gfc_init_block (&body);
10835 :
10836 1111 : tree end_label = gfc_build_label_decl (NULL_TREE);
10837 12221 : for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10838 : {
10839 11110 : tree label = gfc_build_label_decl (NULL_TREE);
10840 11110 : tree low = build_int_cst (TREE_TYPE (arg), c);
10841 11110 : tmp = build_case_label (low, low, label);
10842 11110 : gfc_add_expr_to_block (&body, tmp);
10843 :
10844 11110 : REAL_VALUE_TYPE real;
10845 11110 : int k;
10846 11110 : switch (c)
10847 : {
10848 1111 : case IEEE_SIGNALING_NAN:
10849 1111 : real_nan (&real, "", 0, TYPE_MODE (type));
10850 1111 : break;
10851 1111 : case IEEE_QUIET_NAN:
10852 1111 : real_nan (&real, "", 1, TYPE_MODE (type));
10853 1111 : break;
10854 1111 : case IEEE_NEGATIVE_INF:
10855 1111 : real_inf (&real);
10856 1111 : real = real_value_negate (&real);
10857 1111 : break;
10858 1111 : case IEEE_NEGATIVE_NORMAL:
10859 1111 : real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10860 1111 : break;
10861 1111 : case IEEE_NEGATIVE_DENORMAL:
10862 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10863 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10864 : type, GFC_RND_MODE);
10865 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10866 1111 : real = real_value_negate (&real);
10867 1111 : break;
10868 1111 : case IEEE_NEGATIVE_ZERO:
10869 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10870 1111 : real = real_value_negate (&real);
10871 1111 : break;
10872 1111 : case IEEE_POSITIVE_ZERO:
10873 : /* Make this also the default: label. The other possibility
10874 : would be to add a separate default: label followed by
10875 : __builtin_unreachable (). */
10876 1111 : label = gfc_build_label_decl (NULL_TREE);
10877 1111 : tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10878 1111 : gfc_add_expr_to_block (&body, tmp);
10879 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10880 1111 : break;
10881 1111 : case IEEE_POSITIVE_DENORMAL:
10882 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10883 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10884 : type, GFC_RND_MODE);
10885 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10886 1111 : break;
10887 1111 : case IEEE_POSITIVE_NORMAL:
10888 1111 : real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10889 1111 : break;
10890 1111 : case IEEE_POSITIVE_INF:
10891 1111 : real_inf (&real);
10892 1111 : break;
10893 : default:
10894 : gcc_unreachable ();
10895 : }
10896 :
10897 11110 : tree val = build_real (type, real);
10898 11110 : gfc_add_modify (&body, ret, val);
10899 :
10900 11110 : tmp = build1_v (GOTO_EXPR, end_label);
10901 11110 : gfc_add_expr_to_block (&body, tmp);
10902 : }
10903 :
10904 1111 : tmp = gfc_finish_block (&body);
10905 1111 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10906 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10907 :
10908 1111 : tmp = build1_v (LABEL_EXPR, end_label);
10909 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10910 :
10911 1111 : se->expr = ret;
10912 1111 : }
10913 :
10914 :
10915 : /* Generate code for IEEE_FMA. */
10916 :
10917 : static void
10918 120 : conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10919 : {
10920 120 : tree args[3], decl, call;
10921 120 : int argprec;
10922 :
10923 120 : conv_ieee_function_args (se, expr, args, 3);
10924 :
10925 : /* All three arguments should have the same type. */
10926 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10927 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10928 :
10929 : /* Call the type-generic FMA built-in. */
10930 120 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10931 120 : decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
10932 120 : call = build_call_expr_loc_array (input_location, decl, 3, args);
10933 :
10934 : /* Convert to the final type. */
10935 120 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10936 120 : }
10937 :
10938 :
10939 : /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10940 :
10941 : static void
10942 3072 : conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10943 : const char *name)
10944 : {
10945 3072 : tree args[2], func;
10946 3072 : built_in_function fn;
10947 :
10948 3072 : conv_ieee_function_args (se, expr, args, 2);
10949 3072 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10950 3072 : args[0] = gfc_evaluate_now (args[0], &se->pre);
10951 3072 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10952 :
10953 3072 : if (startswith (name, "mag"))
10954 : {
10955 : /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10956 : fminmag() and fmaxmag(), which do not exist as built-ins.
10957 :
10958 : Following glibc, we emit this:
10959 :
10960 : fminmag (x, y) {
10961 : ax = ABS (x);
10962 : ay = ABS (y);
10963 : if (isless (ax, ay))
10964 : return x;
10965 : else if (isgreater (ax, ay))
10966 : return y;
10967 : else if (ax == ay)
10968 : return x < y ? x : y;
10969 : else if (issignaling (x) || issignaling (y))
10970 : return x + y;
10971 : else
10972 : return isnan (y) ? x : y;
10973 : }
10974 :
10975 : fmaxmag (x, y) {
10976 : ax = ABS (x);
10977 : ay = ABS (y);
10978 : if (isgreater (ax, ay))
10979 : return x;
10980 : else if (isless (ax, ay))
10981 : return y;
10982 : else if (ax == ay)
10983 : return x > y ? x : y;
10984 : else if (issignaling (x) || issignaling (y))
10985 : return x + y;
10986 : else
10987 : return isnan (y) ? x : y;
10988 : }
10989 :
10990 : */
10991 :
10992 1536 : tree abs0, abs1, sig0, sig1;
10993 1536 : tree cond1, cond2, cond3, cond4, cond5;
10994 1536 : tree res;
10995 1536 : tree type = TREE_TYPE (args[0]);
10996 :
10997 1536 : func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
10998 1536 : abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
10999 1536 : abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
11000 1536 : abs0 = gfc_evaluate_now (abs0, &se->pre);
11001 1536 : abs1 = gfc_evaluate_now (abs1, &se->pre);
11002 :
11003 1536 : cond5 = build_call_expr_loc (input_location,
11004 : builtin_decl_explicit (BUILT_IN_ISNAN),
11005 : 1, args[1]);
11006 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
11007 : args[0], args[1]);
11008 :
11009 1536 : sig0 = build_call_expr_loc (input_location,
11010 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11011 : 1, args[0]);
11012 1536 : sig1 = build_call_expr_loc (input_location,
11013 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11014 : 1, args[1]);
11015 1536 : cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
11016 : logical_type_node, sig0, sig1);
11017 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
11018 : fold_build2_loc (input_location, PLUS_EXPR,
11019 : type, args[0], args[1]),
11020 : res);
11021 :
11022 1536 : cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11023 : abs0, abs1);
11024 2304 : res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
11025 : fold_build2_loc (input_location,
11026 : max ? MAX_EXPR : MIN_EXPR,
11027 : type, args[0], args[1]),
11028 : res);
11029 :
11030 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
11031 1536 : cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11032 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
11033 : args[1], res);
11034 :
11035 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
11036 1536 : cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11037 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
11038 : args[0], res);
11039 :
11040 1536 : se->expr = res;
11041 : }
11042 : else
11043 : {
11044 : /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
11045 1536 : fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
11046 1536 : func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind);
11047 1536 : se->expr = build_call_expr_loc_array (input_location, func, 2, args);
11048 : }
11049 3072 : }
11050 :
11051 :
11052 : /* Generate code for comparison functions IEEE_QUIET_* and
11053 : IEEE_SIGNALING_*. */
11054 :
11055 : static void
11056 3888 : conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
11057 : const char *name)
11058 : {
11059 3888 : tree args[2];
11060 3888 : tree arg1, arg2, res;
11061 :
11062 : /* Evaluate arguments only once. */
11063 3888 : conv_ieee_function_args (se, expr, args, 2);
11064 3888 : arg1 = gfc_evaluate_now (args[0], &se->pre);
11065 3888 : arg2 = gfc_evaluate_now (args[1], &se->pre);
11066 :
11067 3888 : if (startswith (name, "eq"))
11068 : {
11069 648 : if (signaling)
11070 324 : res = build_call_expr_loc (input_location,
11071 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11072 : 2, arg1, arg2);
11073 : else
11074 324 : res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11075 : arg1, arg2);
11076 : }
11077 3240 : else if (startswith (name, "ne"))
11078 : {
11079 648 : if (signaling)
11080 : {
11081 324 : res = build_call_expr_loc (input_location,
11082 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11083 : 2, arg1, arg2);
11084 324 : res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
11085 : logical_type_node, res);
11086 : }
11087 : else
11088 324 : res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
11089 : arg1, arg2);
11090 : }
11091 2592 : else if (startswith (name, "ge"))
11092 : {
11093 648 : if (signaling)
11094 324 : res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11095 : arg1, arg2);
11096 : else
11097 324 : res = build_call_expr_loc (input_location,
11098 : builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
11099 : 2, arg1, arg2);
11100 : }
11101 1944 : else if (startswith (name, "gt"))
11102 : {
11103 648 : if (signaling)
11104 324 : res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
11105 : arg1, arg2);
11106 : else
11107 324 : res = build_call_expr_loc (input_location,
11108 : builtin_decl_explicit (BUILT_IN_ISGREATER),
11109 : 2, arg1, arg2);
11110 : }
11111 1296 : else if (startswith (name, "le"))
11112 : {
11113 648 : if (signaling)
11114 324 : res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
11115 : arg1, arg2);
11116 : else
11117 324 : res = build_call_expr_loc (input_location,
11118 : builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
11119 : 2, arg1, arg2);
11120 : }
11121 648 : else if (startswith (name, "lt"))
11122 : {
11123 648 : if (signaling)
11124 324 : res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11125 : arg1, arg2);
11126 : else
11127 324 : res = build_call_expr_loc (input_location,
11128 : builtin_decl_explicit (BUILT_IN_ISLESS),
11129 : 2, arg1, arg2);
11130 : }
11131 : else
11132 0 : gcc_unreachable ();
11133 :
11134 3888 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
11135 3888 : }
11136 :
11137 :
11138 : /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
11139 : module. */
11140 :
11141 : bool
11142 13939 : gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
11143 : {
11144 13939 : const char *name = expr->value.function.name;
11145 :
11146 13939 : if (startswith (name, "_gfortran_ieee_is_nan"))
11147 522 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
11148 13417 : else if (startswith (name, "_gfortran_ieee_is_finite"))
11149 372 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
11150 13045 : else if (startswith (name, "_gfortran_ieee_unordered"))
11151 168 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
11152 12877 : else if (startswith (name, "_gfortran_ieee_signbit"))
11153 624 : conv_intrinsic_ieee_signbit (se, expr);
11154 12253 : else if (startswith (name, "_gfortran_ieee_is_normal"))
11155 312 : conv_intrinsic_ieee_is_normal (se, expr);
11156 11941 : else if (startswith (name, "_gfortran_ieee_is_negative"))
11157 312 : conv_intrinsic_ieee_is_negative (se, expr);
11158 11629 : else if (startswith (name, "_gfortran_ieee_copy_sign"))
11159 576 : conv_intrinsic_ieee_copy_sign (se, expr);
11160 11053 : else if (startswith (name, "_gfortran_ieee_scalb"))
11161 228 : conv_intrinsic_ieee_scalb (se, expr);
11162 10825 : else if (startswith (name, "_gfortran_ieee_next_after"))
11163 180 : conv_intrinsic_ieee_next_after (se, expr);
11164 10645 : else if (startswith (name, "_gfortran_ieee_rem"))
11165 84 : conv_intrinsic_ieee_rem (se, expr);
11166 10561 : else if (startswith (name, "_gfortran_ieee_logb"))
11167 144 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
11168 10417 : else if (startswith (name, "_gfortran_ieee_rint"))
11169 96 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
11170 10321 : else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
11171 648 : conv_intrinsic_ieee_class (se, expr);
11172 9673 : else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
11173 1111 : conv_intrinsic_ieee_value (se, expr);
11174 8562 : else if (startswith (name, "_gfortran_ieee_fma"))
11175 120 : conv_intrinsic_ieee_fma (se, expr);
11176 8442 : else if (startswith (name, "_gfortran_ieee_min_num_"))
11177 1536 : conv_intrinsic_ieee_minmax (se, expr, 0, name + 23);
11178 6906 : else if (startswith (name, "_gfortran_ieee_max_num_"))
11179 1536 : conv_intrinsic_ieee_minmax (se, expr, 1, name + 23);
11180 5370 : else if (startswith (name, "_gfortran_ieee_quiet_"))
11181 1944 : conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
11182 3426 : else if (startswith (name, "_gfortran_ieee_signaling_"))
11183 1944 : conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
11184 : else
11185 : /* It is not among the functions we translate directly. We return
11186 : false, so a library function call is emitted. */
11187 : return false;
11188 :
11189 : return true;
11190 : }
11191 :
11192 :
11193 : /* Generate a direct call to malloc() for the MALLOC intrinsic. */
11194 :
11195 : static void
11196 16 : gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
11197 : {
11198 16 : tree arg, res, restype;
11199 :
11200 16 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
11201 16 : arg = fold_convert (size_type_node, arg);
11202 16 : res = build_call_expr_loc (input_location,
11203 : builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
11204 16 : restype = gfc_typenode_for_spec (&expr->ts);
11205 16 : se->expr = fold_convert (restype, res);
11206 16 : }
11207 :
11208 :
11209 : /* Generate code for an intrinsic function. Some map directly to library
11210 : calls, others get special handling. In some cases the name of the function
11211 : used depends on the type specifiers. */
11212 :
11213 : void
11214 266180 : gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
11215 : {
11216 266180 : const char *name;
11217 266180 : int lib, kind;
11218 266180 : tree fndecl;
11219 :
11220 266180 : name = &expr->value.function.name[2];
11221 :
11222 266180 : if (expr->rank > 0)
11223 : {
11224 50520 : lib = gfc_is_intrinsic_libcall (expr);
11225 50520 : if (lib != 0)
11226 : {
11227 19200 : if (lib == 1)
11228 11798 : se->ignore_optional = 1;
11229 :
11230 19200 : switch (expr->value.function.isym->id)
11231 : {
11232 5843 : case GFC_ISYM_EOSHIFT:
11233 5843 : case GFC_ISYM_PACK:
11234 5843 : case GFC_ISYM_RESHAPE:
11235 5843 : case GFC_ISYM_REDUCE:
11236 : /* For all of those the first argument specifies the type and the
11237 : third is optional. */
11238 5843 : conv_generic_with_optional_char_arg (se, expr, 1, 3);
11239 5843 : break;
11240 :
11241 1116 : case GFC_ISYM_FINDLOC:
11242 1116 : gfc_conv_intrinsic_findloc (se, expr);
11243 1116 : break;
11244 :
11245 2935 : case GFC_ISYM_MINLOC:
11246 2935 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11247 2935 : break;
11248 :
11249 2439 : case GFC_ISYM_MAXLOC:
11250 2439 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11251 2439 : break;
11252 :
11253 6867 : default:
11254 6867 : gfc_conv_intrinsic_funcall (se, expr);
11255 6867 : break;
11256 : }
11257 :
11258 19200 : return;
11259 : }
11260 : }
11261 :
11262 246980 : switch (expr->value.function.isym->id)
11263 : {
11264 0 : case GFC_ISYM_NONE:
11265 0 : gcc_unreachable ();
11266 :
11267 529 : case GFC_ISYM_REPEAT:
11268 529 : gfc_conv_intrinsic_repeat (se, expr);
11269 529 : break;
11270 :
11271 578 : case GFC_ISYM_TRIM:
11272 578 : gfc_conv_intrinsic_trim (se, expr);
11273 578 : break;
11274 :
11275 42 : case GFC_ISYM_SC_KIND:
11276 42 : gfc_conv_intrinsic_sc_kind (se, expr);
11277 42 : break;
11278 :
11279 45 : case GFC_ISYM_SI_KIND:
11280 45 : gfc_conv_intrinsic_si_kind (se, expr);
11281 45 : break;
11282 :
11283 6 : case GFC_ISYM_SL_KIND:
11284 6 : gfc_conv_intrinsic_sl_kind (se, expr);
11285 6 : break;
11286 :
11287 82 : case GFC_ISYM_SR_KIND:
11288 82 : gfc_conv_intrinsic_sr_kind (se, expr);
11289 82 : break;
11290 :
11291 228 : case GFC_ISYM_EXPONENT:
11292 228 : gfc_conv_intrinsic_exponent (se, expr);
11293 228 : break;
11294 :
11295 316 : case GFC_ISYM_SCAN:
11296 316 : kind = expr->value.function.actual->expr->ts.kind;
11297 316 : if (kind == 1)
11298 250 : fndecl = gfor_fndecl_string_scan;
11299 66 : else if (kind == 4)
11300 66 : fndecl = gfor_fndecl_string_scan_char4;
11301 : else
11302 0 : gcc_unreachable ();
11303 :
11304 316 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11305 316 : break;
11306 :
11307 94 : case GFC_ISYM_VERIFY:
11308 94 : kind = expr->value.function.actual->expr->ts.kind;
11309 94 : if (kind == 1)
11310 70 : fndecl = gfor_fndecl_string_verify;
11311 24 : else if (kind == 4)
11312 24 : fndecl = gfor_fndecl_string_verify_char4;
11313 : else
11314 0 : gcc_unreachable ();
11315 :
11316 94 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11317 94 : break;
11318 :
11319 7405 : case GFC_ISYM_ALLOCATED:
11320 7405 : gfc_conv_allocated (se, expr);
11321 7405 : break;
11322 :
11323 9581 : case GFC_ISYM_ASSOCIATED:
11324 9581 : gfc_conv_associated(se, expr);
11325 9581 : break;
11326 :
11327 409 : case GFC_ISYM_SAME_TYPE_AS:
11328 409 : gfc_conv_same_type_as (se, expr);
11329 409 : break;
11330 :
11331 7980 : case GFC_ISYM_ABS:
11332 7980 : gfc_conv_intrinsic_abs (se, expr);
11333 7980 : break;
11334 :
11335 345 : case GFC_ISYM_ADJUSTL:
11336 345 : if (expr->ts.kind == 1)
11337 291 : fndecl = gfor_fndecl_adjustl;
11338 54 : else if (expr->ts.kind == 4)
11339 54 : fndecl = gfor_fndecl_adjustl_char4;
11340 : else
11341 0 : gcc_unreachable ();
11342 :
11343 345 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11344 345 : break;
11345 :
11346 123 : case GFC_ISYM_ADJUSTR:
11347 123 : if (expr->ts.kind == 1)
11348 68 : fndecl = gfor_fndecl_adjustr;
11349 55 : else if (expr->ts.kind == 4)
11350 55 : fndecl = gfor_fndecl_adjustr_char4;
11351 : else
11352 0 : gcc_unreachable ();
11353 :
11354 123 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11355 123 : break;
11356 :
11357 440 : case GFC_ISYM_AIMAG:
11358 440 : gfc_conv_intrinsic_imagpart (se, expr);
11359 440 : break;
11360 :
11361 146 : case GFC_ISYM_AINT:
11362 146 : gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
11363 146 : break;
11364 :
11365 420 : case GFC_ISYM_ALL:
11366 420 : gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
11367 420 : break;
11368 :
11369 74 : case GFC_ISYM_ANINT:
11370 74 : gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
11371 74 : break;
11372 :
11373 12 : case GFC_ISYM_AND:
11374 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11375 12 : break;
11376 :
11377 38143 : case GFC_ISYM_ANY:
11378 38143 : gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
11379 38143 : break;
11380 :
11381 270 : case GFC_ISYM_ACOSD:
11382 270 : case GFC_ISYM_ASIND:
11383 270 : case GFC_ISYM_ATAND:
11384 270 : gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
11385 270 : break;
11386 :
11387 102 : case GFC_ISYM_COTAN:
11388 102 : gfc_conv_intrinsic_cotan (se, expr);
11389 102 : break;
11390 :
11391 108 : case GFC_ISYM_COTAND:
11392 108 : gfc_conv_intrinsic_cotand (se, expr);
11393 108 : break;
11394 :
11395 138 : case GFC_ISYM_ATAN2D:
11396 138 : gfc_conv_intrinsic_atan2d (se, expr);
11397 138 : break;
11398 :
11399 145 : case GFC_ISYM_BTEST:
11400 145 : gfc_conv_intrinsic_btest (se, expr);
11401 145 : break;
11402 :
11403 54 : case GFC_ISYM_BGE:
11404 54 : gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
11405 54 : break;
11406 :
11407 54 : case GFC_ISYM_BGT:
11408 54 : gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
11409 54 : break;
11410 :
11411 54 : case GFC_ISYM_BLE:
11412 54 : gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
11413 54 : break;
11414 :
11415 54 : case GFC_ISYM_BLT:
11416 54 : gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
11417 54 : break;
11418 :
11419 9879 : case GFC_ISYM_C_ASSOCIATED:
11420 9879 : case GFC_ISYM_C_FUNLOC:
11421 9879 : case GFC_ISYM_C_LOC:
11422 9879 : case GFC_ISYM_F_C_STRING:
11423 9879 : conv_isocbinding_function (se, expr);
11424 9879 : break;
11425 :
11426 2020 : case GFC_ISYM_ACHAR:
11427 2020 : case GFC_ISYM_CHAR:
11428 2020 : gfc_conv_intrinsic_char (se, expr);
11429 2020 : break;
11430 :
11431 40447 : case GFC_ISYM_CONVERSION:
11432 40447 : case GFC_ISYM_DBLE:
11433 40447 : case GFC_ISYM_DFLOAT:
11434 40447 : case GFC_ISYM_FLOAT:
11435 40447 : case GFC_ISYM_LOGICAL:
11436 40447 : case GFC_ISYM_REAL:
11437 40447 : case GFC_ISYM_REALPART:
11438 40447 : case GFC_ISYM_SNGL:
11439 40447 : gfc_conv_intrinsic_conversion (se, expr);
11440 40447 : break;
11441 :
11442 : /* Integer conversions are handled separately to make sure we get the
11443 : correct rounding mode. */
11444 2836 : case GFC_ISYM_INT:
11445 2836 : case GFC_ISYM_INT2:
11446 2836 : case GFC_ISYM_INT8:
11447 2836 : case GFC_ISYM_LONG:
11448 2836 : case GFC_ISYM_UINT:
11449 2836 : gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
11450 2836 : break;
11451 :
11452 162 : case GFC_ISYM_NINT:
11453 162 : gfc_conv_intrinsic_int (se, expr, RND_ROUND);
11454 162 : break;
11455 :
11456 16 : case GFC_ISYM_CEILING:
11457 16 : gfc_conv_intrinsic_int (se, expr, RND_CEIL);
11458 16 : break;
11459 :
11460 116 : case GFC_ISYM_FLOOR:
11461 116 : gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
11462 116 : break;
11463 :
11464 3318 : case GFC_ISYM_MOD:
11465 3318 : gfc_conv_intrinsic_mod (se, expr, 0);
11466 3318 : break;
11467 :
11468 442 : case GFC_ISYM_MODULO:
11469 442 : gfc_conv_intrinsic_mod (se, expr, 1);
11470 442 : break;
11471 :
11472 1006 : case GFC_ISYM_CAF_GET:
11473 1006 : gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL);
11474 1006 : break;
11475 :
11476 167 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
11477 167 : gfc_conv_intrinsic_caf_is_present_remote (se, expr);
11478 167 : break;
11479 :
11480 485 : case GFC_ISYM_CMPLX:
11481 485 : gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
11482 485 : break;
11483 :
11484 10 : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
11485 10 : gfc_conv_intrinsic_iargc (se, expr);
11486 10 : break;
11487 :
11488 6 : case GFC_ISYM_COMPLEX:
11489 6 : gfc_conv_intrinsic_cmplx (se, expr, 1);
11490 6 : break;
11491 :
11492 257 : case GFC_ISYM_CONJG:
11493 257 : gfc_conv_intrinsic_conjg (se, expr);
11494 257 : break;
11495 :
11496 4 : case GFC_ISYM_COSHAPE:
11497 4 : conv_intrinsic_cobound (se, expr);
11498 4 : break;
11499 :
11500 143 : case GFC_ISYM_COUNT:
11501 143 : gfc_conv_intrinsic_count (se, expr);
11502 143 : break;
11503 :
11504 0 : case GFC_ISYM_CTIME:
11505 0 : gfc_conv_intrinsic_ctime (se, expr);
11506 0 : break;
11507 :
11508 96 : case GFC_ISYM_DIM:
11509 96 : gfc_conv_intrinsic_dim (se, expr);
11510 96 : break;
11511 :
11512 113 : case GFC_ISYM_DOT_PRODUCT:
11513 113 : gfc_conv_intrinsic_dot_product (se, expr);
11514 113 : break;
11515 :
11516 13 : case GFC_ISYM_DPROD:
11517 13 : gfc_conv_intrinsic_dprod (se, expr);
11518 13 : break;
11519 :
11520 66 : case GFC_ISYM_DSHIFTL:
11521 66 : gfc_conv_intrinsic_dshift (se, expr, true);
11522 66 : break;
11523 :
11524 66 : case GFC_ISYM_DSHIFTR:
11525 66 : gfc_conv_intrinsic_dshift (se, expr, false);
11526 66 : break;
11527 :
11528 0 : case GFC_ISYM_FDATE:
11529 0 : gfc_conv_intrinsic_fdate (se, expr);
11530 0 : break;
11531 :
11532 60 : case GFC_ISYM_FRACTION:
11533 60 : gfc_conv_intrinsic_fraction (se, expr);
11534 60 : break;
11535 :
11536 24 : case GFC_ISYM_IALL:
11537 24 : gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
11538 24 : break;
11539 :
11540 606 : case GFC_ISYM_IAND:
11541 606 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11542 606 : break;
11543 :
11544 12 : case GFC_ISYM_IANY:
11545 12 : gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
11546 12 : break;
11547 :
11548 168 : case GFC_ISYM_IBCLR:
11549 168 : gfc_conv_intrinsic_singlebitop (se, expr, 0);
11550 168 : break;
11551 :
11552 27 : case GFC_ISYM_IBITS:
11553 27 : gfc_conv_intrinsic_ibits (se, expr);
11554 27 : break;
11555 :
11556 138 : case GFC_ISYM_IBSET:
11557 138 : gfc_conv_intrinsic_singlebitop (se, expr, 1);
11558 138 : break;
11559 :
11560 2033 : case GFC_ISYM_IACHAR:
11561 2033 : case GFC_ISYM_ICHAR:
11562 : /* We assume ASCII character sequence. */
11563 2033 : gfc_conv_intrinsic_ichar (se, expr);
11564 2033 : break;
11565 :
11566 2 : case GFC_ISYM_IARGC:
11567 2 : gfc_conv_intrinsic_iargc (se, expr);
11568 2 : break;
11569 :
11570 694 : case GFC_ISYM_IEOR:
11571 694 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11572 694 : break;
11573 :
11574 341 : case GFC_ISYM_INDEX:
11575 341 : kind = expr->value.function.actual->expr->ts.kind;
11576 341 : if (kind == 1)
11577 275 : fndecl = gfor_fndecl_string_index;
11578 66 : else if (kind == 4)
11579 66 : fndecl = gfor_fndecl_string_index_char4;
11580 : else
11581 0 : gcc_unreachable ();
11582 :
11583 341 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11584 341 : break;
11585 :
11586 495 : case GFC_ISYM_IOR:
11587 495 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11588 495 : break;
11589 :
11590 12 : case GFC_ISYM_IPARITY:
11591 12 : gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
11592 12 : break;
11593 :
11594 6 : case GFC_ISYM_IS_IOSTAT_END:
11595 6 : gfc_conv_has_intvalue (se, expr, LIBERROR_END);
11596 6 : break;
11597 :
11598 18 : case GFC_ISYM_IS_IOSTAT_EOR:
11599 18 : gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
11600 18 : break;
11601 :
11602 735 : case GFC_ISYM_IS_CONTIGUOUS:
11603 735 : gfc_conv_intrinsic_is_contiguous (se, expr);
11604 735 : break;
11605 :
11606 432 : case GFC_ISYM_ISNAN:
11607 432 : gfc_conv_intrinsic_isnan (se, expr);
11608 432 : break;
11609 :
11610 8 : case GFC_ISYM_KILL:
11611 8 : conv_intrinsic_kill (se, expr);
11612 8 : break;
11613 :
11614 90 : case GFC_ISYM_LSHIFT:
11615 90 : gfc_conv_intrinsic_shift (se, expr, false, false);
11616 90 : break;
11617 :
11618 24 : case GFC_ISYM_RSHIFT:
11619 24 : gfc_conv_intrinsic_shift (se, expr, true, true);
11620 24 : break;
11621 :
11622 78 : case GFC_ISYM_SHIFTA:
11623 78 : gfc_conv_intrinsic_shift (se, expr, true, true);
11624 78 : break;
11625 :
11626 234 : case GFC_ISYM_SHIFTL:
11627 234 : gfc_conv_intrinsic_shift (se, expr, false, false);
11628 234 : break;
11629 :
11630 66 : case GFC_ISYM_SHIFTR:
11631 66 : gfc_conv_intrinsic_shift (se, expr, true, false);
11632 66 : break;
11633 :
11634 318 : case GFC_ISYM_ISHFT:
11635 318 : gfc_conv_intrinsic_ishft (se, expr);
11636 318 : break;
11637 :
11638 658 : case GFC_ISYM_ISHFTC:
11639 658 : gfc_conv_intrinsic_ishftc (se, expr);
11640 658 : break;
11641 :
11642 270 : case GFC_ISYM_LEADZ:
11643 270 : gfc_conv_intrinsic_leadz (se, expr);
11644 270 : break;
11645 :
11646 282 : case GFC_ISYM_TRAILZ:
11647 282 : gfc_conv_intrinsic_trailz (se, expr);
11648 282 : break;
11649 :
11650 103 : case GFC_ISYM_POPCNT:
11651 103 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
11652 103 : break;
11653 :
11654 31 : case GFC_ISYM_POPPAR:
11655 31 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
11656 31 : break;
11657 :
11658 5561 : case GFC_ISYM_LBOUND:
11659 5561 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
11660 5561 : break;
11661 :
11662 210 : case GFC_ISYM_LCOBOUND:
11663 210 : conv_intrinsic_cobound (se, expr);
11664 210 : break;
11665 :
11666 768 : case GFC_ISYM_TRANSPOSE:
11667 : /* The scalarizer has already been set up for reversed dimension access
11668 : order ; now we just get the argument value normally. */
11669 768 : gfc_conv_expr (se, expr->value.function.actual->expr);
11670 768 : break;
11671 :
11672 5873 : case GFC_ISYM_LEN:
11673 5873 : gfc_conv_intrinsic_len (se, expr);
11674 5873 : break;
11675 :
11676 2340 : case GFC_ISYM_LEN_TRIM:
11677 2340 : gfc_conv_intrinsic_len_trim (se, expr);
11678 2340 : break;
11679 :
11680 18 : case GFC_ISYM_LGE:
11681 18 : gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
11682 18 : break;
11683 :
11684 36 : case GFC_ISYM_LGT:
11685 36 : gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
11686 36 : break;
11687 :
11688 18 : case GFC_ISYM_LLE:
11689 18 : gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
11690 18 : break;
11691 :
11692 27 : case GFC_ISYM_LLT:
11693 27 : gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
11694 27 : break;
11695 :
11696 16 : case GFC_ISYM_MALLOC:
11697 16 : gfc_conv_intrinsic_malloc (se, expr);
11698 16 : break;
11699 :
11700 32 : case GFC_ISYM_MASKL:
11701 32 : gfc_conv_intrinsic_mask (se, expr, 1);
11702 32 : break;
11703 :
11704 32 : case GFC_ISYM_MASKR:
11705 32 : gfc_conv_intrinsic_mask (se, expr, 0);
11706 32 : break;
11707 :
11708 1049 : case GFC_ISYM_MAX:
11709 1049 : if (expr->ts.type == BT_CHARACTER)
11710 138 : gfc_conv_intrinsic_minmax_char (se, expr, 1);
11711 : else
11712 911 : gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
11713 : break;
11714 :
11715 6348 : case GFC_ISYM_MAXLOC:
11716 6348 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11717 6348 : break;
11718 :
11719 216 : case GFC_ISYM_FINDLOC:
11720 216 : gfc_conv_intrinsic_findloc (se, expr);
11721 216 : break;
11722 :
11723 1101 : case GFC_ISYM_MAXVAL:
11724 1101 : gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
11725 1101 : break;
11726 :
11727 949 : case GFC_ISYM_MERGE:
11728 949 : gfc_conv_intrinsic_merge (se, expr);
11729 949 : break;
11730 :
11731 42 : case GFC_ISYM_MERGE_BITS:
11732 42 : gfc_conv_intrinsic_merge_bits (se, expr);
11733 42 : break;
11734 :
11735 598 : case GFC_ISYM_MIN:
11736 598 : if (expr->ts.type == BT_CHARACTER)
11737 144 : gfc_conv_intrinsic_minmax_char (se, expr, -1);
11738 : else
11739 454 : gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
11740 : break;
11741 :
11742 7176 : case GFC_ISYM_MINLOC:
11743 7176 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11744 7176 : break;
11745 :
11746 1316 : case GFC_ISYM_MINVAL:
11747 1316 : gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
11748 1316 : break;
11749 :
11750 1595 : case GFC_ISYM_NEAREST:
11751 1595 : gfc_conv_intrinsic_nearest (se, expr);
11752 1595 : break;
11753 :
11754 68 : case GFC_ISYM_NORM2:
11755 68 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
11756 68 : break;
11757 :
11758 230 : case GFC_ISYM_NOT:
11759 230 : gfc_conv_intrinsic_not (se, expr);
11760 230 : break;
11761 :
11762 12 : case GFC_ISYM_OR:
11763 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11764 12 : break;
11765 :
11766 468 : case GFC_ISYM_OUT_OF_RANGE:
11767 468 : gfc_conv_intrinsic_out_of_range (se, expr);
11768 468 : break;
11769 :
11770 36 : case GFC_ISYM_PARITY:
11771 36 : gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
11772 36 : break;
11773 :
11774 5070 : case GFC_ISYM_PRESENT:
11775 5070 : gfc_conv_intrinsic_present (se, expr);
11776 5070 : break;
11777 :
11778 358 : case GFC_ISYM_PRODUCT:
11779 358 : gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
11780 358 : break;
11781 :
11782 13016 : case GFC_ISYM_RANK:
11783 13016 : gfc_conv_intrinsic_rank (se, expr);
11784 13016 : break;
11785 :
11786 48 : case GFC_ISYM_RRSPACING:
11787 48 : gfc_conv_intrinsic_rrspacing (se, expr);
11788 48 : break;
11789 :
11790 262 : case GFC_ISYM_SET_EXPONENT:
11791 262 : gfc_conv_intrinsic_set_exponent (se, expr);
11792 262 : break;
11793 :
11794 72 : case GFC_ISYM_SCALE:
11795 72 : gfc_conv_intrinsic_scale (se, expr);
11796 72 : break;
11797 :
11798 4988 : case GFC_ISYM_SHAPE:
11799 4988 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
11800 4988 : break;
11801 :
11802 423 : case GFC_ISYM_SIGN:
11803 423 : gfc_conv_intrinsic_sign (se, expr);
11804 423 : break;
11805 :
11806 15409 : case GFC_ISYM_SIZE:
11807 15409 : gfc_conv_intrinsic_size (se, expr);
11808 15409 : break;
11809 :
11810 1309 : case GFC_ISYM_SIZEOF:
11811 1309 : case GFC_ISYM_C_SIZEOF:
11812 1309 : gfc_conv_intrinsic_sizeof (se, expr);
11813 1309 : break;
11814 :
11815 859 : case GFC_ISYM_STORAGE_SIZE:
11816 859 : gfc_conv_intrinsic_storage_size (se, expr);
11817 859 : break;
11818 :
11819 70 : case GFC_ISYM_SPACING:
11820 70 : gfc_conv_intrinsic_spacing (se, expr);
11821 70 : break;
11822 :
11823 2357 : case GFC_ISYM_STRIDE:
11824 2357 : conv_intrinsic_stride (se, expr);
11825 2357 : break;
11826 :
11827 2005 : case GFC_ISYM_SUM:
11828 2005 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
11829 2005 : break;
11830 :
11831 21 : case GFC_ISYM_TEAM_NUMBER:
11832 21 : conv_intrinsic_team_number (se, expr);
11833 21 : break;
11834 :
11835 4195 : case GFC_ISYM_TRANSFER:
11836 4195 : if (se->ss && se->ss->info->useflags)
11837 : /* Access the previously obtained result. */
11838 281 : gfc_conv_tmp_array_ref (se);
11839 : else
11840 3914 : gfc_conv_intrinsic_transfer (se, expr);
11841 : break;
11842 :
11843 0 : case GFC_ISYM_TTYNAM:
11844 0 : gfc_conv_intrinsic_ttynam (se, expr);
11845 0 : break;
11846 :
11847 5748 : case GFC_ISYM_UBOUND:
11848 5748 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
11849 5748 : break;
11850 :
11851 244 : case GFC_ISYM_UCOBOUND:
11852 244 : conv_intrinsic_cobound (se, expr);
11853 244 : break;
11854 :
11855 18 : case GFC_ISYM_XOR:
11856 18 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11857 18 : break;
11858 :
11859 8908 : case GFC_ISYM_LOC:
11860 8908 : gfc_conv_intrinsic_loc (se, expr);
11861 8908 : break;
11862 :
11863 1506 : case GFC_ISYM_THIS_IMAGE:
11864 : /* For num_images() == 1, handle as LCOBOUND. */
11865 1506 : if (expr->value.function.actual->expr
11866 526 : && flag_coarray == GFC_FCOARRAY_SINGLE)
11867 208 : conv_intrinsic_cobound (se, expr);
11868 : else
11869 1298 : trans_this_image (se, expr);
11870 : break;
11871 :
11872 193 : case GFC_ISYM_IMAGE_INDEX:
11873 193 : trans_image_index (se, expr);
11874 193 : break;
11875 :
11876 25 : case GFC_ISYM_IMAGE_STATUS:
11877 25 : conv_intrinsic_image_status (se, expr);
11878 25 : break;
11879 :
11880 810 : case GFC_ISYM_NUM_IMAGES:
11881 810 : trans_num_images (se, expr);
11882 810 : break;
11883 :
11884 1394 : case GFC_ISYM_ACCESS:
11885 1394 : case GFC_ISYM_CHDIR:
11886 1394 : case GFC_ISYM_CHMOD:
11887 1394 : case GFC_ISYM_DTIME:
11888 1394 : case GFC_ISYM_ETIME:
11889 1394 : case GFC_ISYM_EXTENDS_TYPE_OF:
11890 1394 : case GFC_ISYM_FGET:
11891 1394 : case GFC_ISYM_FGETC:
11892 1394 : case GFC_ISYM_FNUM:
11893 1394 : case GFC_ISYM_FPUT:
11894 1394 : case GFC_ISYM_FPUTC:
11895 1394 : case GFC_ISYM_FSTAT:
11896 1394 : case GFC_ISYM_FTELL:
11897 1394 : case GFC_ISYM_GETCWD:
11898 1394 : case GFC_ISYM_GETGID:
11899 1394 : case GFC_ISYM_GETPID:
11900 1394 : case GFC_ISYM_GETUID:
11901 1394 : case GFC_ISYM_GET_TEAM:
11902 1394 : case GFC_ISYM_HOSTNM:
11903 1394 : case GFC_ISYM_IERRNO:
11904 1394 : case GFC_ISYM_IRAND:
11905 1394 : case GFC_ISYM_ISATTY:
11906 1394 : case GFC_ISYM_JN2:
11907 1394 : case GFC_ISYM_LINK:
11908 1394 : case GFC_ISYM_LSTAT:
11909 1394 : case GFC_ISYM_MATMUL:
11910 1394 : case GFC_ISYM_MCLOCK:
11911 1394 : case GFC_ISYM_MCLOCK8:
11912 1394 : case GFC_ISYM_RAND:
11913 1394 : case GFC_ISYM_REDUCE:
11914 1394 : case GFC_ISYM_RENAME:
11915 1394 : case GFC_ISYM_SECOND:
11916 1394 : case GFC_ISYM_SECNDS:
11917 1394 : case GFC_ISYM_SIGNAL:
11918 1394 : case GFC_ISYM_STAT:
11919 1394 : case GFC_ISYM_SYMLNK:
11920 1394 : case GFC_ISYM_SYSTEM:
11921 1394 : case GFC_ISYM_TIME:
11922 1394 : case GFC_ISYM_TIME8:
11923 1394 : case GFC_ISYM_UMASK:
11924 1394 : case GFC_ISYM_UNLINK:
11925 1394 : case GFC_ISYM_YN2:
11926 1394 : gfc_conv_intrinsic_funcall (se, expr);
11927 1394 : break;
11928 :
11929 0 : case GFC_ISYM_EOSHIFT:
11930 0 : case GFC_ISYM_PACK:
11931 0 : case GFC_ISYM_RESHAPE:
11932 : /* For those, expr->rank should always be >0 and thus the if above the
11933 : switch should have matched. */
11934 0 : gcc_unreachable ();
11935 3927 : break;
11936 :
11937 3927 : default:
11938 3927 : gfc_conv_intrinsic_lib_function (se, expr);
11939 3927 : break;
11940 : }
11941 : }
11942 :
11943 :
11944 : static gfc_ss *
11945 1680 : walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11946 : {
11947 1680 : gfc_ss *arg_ss, *tmp_ss;
11948 1680 : gfc_actual_arglist *arg;
11949 :
11950 1680 : arg = expr->value.function.actual;
11951 :
11952 1680 : gcc_assert (arg->expr);
11953 :
11954 1680 : arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11955 1680 : gcc_assert (arg_ss != gfc_ss_terminator);
11956 :
11957 : for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11958 : {
11959 1785 : if (tmp_ss->info->type != GFC_SS_SCALAR
11960 : && tmp_ss->info->type != GFC_SS_REFERENCE)
11961 : {
11962 1748 : gcc_assert (tmp_ss->dimen == 2);
11963 :
11964 : /* We just invert dimensions. */
11965 1748 : std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
11966 : }
11967 :
11968 : /* Stop when tmp_ss points to the last valid element of the chain... */
11969 1785 : if (tmp_ss->next == gfc_ss_terminator)
11970 : break;
11971 : }
11972 :
11973 : /* ... so that we can attach the rest of the chain to it. */
11974 1680 : tmp_ss->next = ss;
11975 :
11976 1680 : return arg_ss;
11977 : }
11978 :
11979 :
11980 : /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11981 : This has the side effect of reversing the nested list, so there is no
11982 : need to call gfc_reverse_ss on it (the given list is assumed not to be
11983 : reversed yet). */
11984 :
11985 : static gfc_ss *
11986 3371 : nest_loop_dimension (gfc_ss *ss, int dim)
11987 : {
11988 3371 : int ss_dim, i;
11989 3371 : gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11990 3371 : gfc_loopinfo *new_loop;
11991 :
11992 3371 : gcc_assert (ss != gfc_ss_terminator);
11993 :
11994 8118 : for (; ss != gfc_ss_terminator; ss = ss->next)
11995 : {
11996 4747 : new_ss = gfc_get_ss ();
11997 4747 : new_ss->next = prev_ss;
11998 4747 : new_ss->parent = ss;
11999 4747 : new_ss->info = ss->info;
12000 4747 : new_ss->info->refcount++;
12001 4747 : if (ss->dimen != 0)
12002 : {
12003 4684 : gcc_assert (ss->info->type != GFC_SS_SCALAR
12004 : && ss->info->type != GFC_SS_REFERENCE);
12005 :
12006 4684 : new_ss->dimen = 1;
12007 4684 : new_ss->dim[0] = ss->dim[dim];
12008 :
12009 4684 : gcc_assert (dim < ss->dimen);
12010 :
12011 4684 : ss_dim = --ss->dimen;
12012 10430 : for (i = dim; i < ss_dim; i++)
12013 5746 : ss->dim[i] = ss->dim[i + 1];
12014 :
12015 4684 : ss->dim[ss_dim] = 0;
12016 : }
12017 4747 : prev_ss = new_ss;
12018 :
12019 4747 : if (ss->nested_ss)
12020 : {
12021 81 : ss->nested_ss->parent = new_ss;
12022 81 : new_ss->nested_ss = ss->nested_ss;
12023 : }
12024 4747 : ss->nested_ss = new_ss;
12025 : }
12026 :
12027 3371 : new_loop = gfc_get_loopinfo ();
12028 3371 : gfc_init_loopinfo (new_loop);
12029 :
12030 3371 : gcc_assert (prev_ss != NULL);
12031 3371 : gcc_assert (prev_ss != gfc_ss_terminator);
12032 3371 : gfc_add_ss_to_loop (new_loop, prev_ss);
12033 3371 : return new_ss->parent;
12034 : }
12035 :
12036 :
12037 : /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
12038 : is to be inlined. */
12039 :
12040 : static gfc_ss *
12041 575 : walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
12042 : {
12043 575 : gfc_ss *tmp_ss, *tail, *array_ss;
12044 575 : gfc_actual_arglist *arg1, *arg2, *arg3;
12045 575 : int sum_dim;
12046 575 : bool scalar_mask = false;
12047 :
12048 : /* The rank of the result will be determined later. */
12049 575 : arg1 = expr->value.function.actual;
12050 575 : arg2 = arg1->next;
12051 575 : arg3 = arg2->next;
12052 575 : gcc_assert (arg3 != NULL);
12053 :
12054 575 : if (expr->rank == 0)
12055 : return ss;
12056 :
12057 575 : tmp_ss = gfc_ss_terminator;
12058 :
12059 575 : if (arg3->expr)
12060 : {
12061 118 : gfc_ss *mask_ss;
12062 :
12063 118 : mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
12064 118 : if (mask_ss == tmp_ss)
12065 34 : scalar_mask = 1;
12066 :
12067 : tmp_ss = mask_ss;
12068 : }
12069 :
12070 575 : array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
12071 575 : gcc_assert (array_ss != tmp_ss);
12072 :
12073 : /* Odd thing: If the mask is scalar, it is used by the frontend after
12074 : the array (to make an if around the nested loop). Thus it shall
12075 : be after array_ss once the gfc_ss list is reversed. */
12076 575 : if (scalar_mask)
12077 34 : tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
12078 : else
12079 : tmp_ss = array_ss;
12080 :
12081 : /* "Hide" the dimension on which we will sum in the first arg's scalarization
12082 : chain. */
12083 575 : sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
12084 575 : tail = nest_loop_dimension (tmp_ss, sum_dim);
12085 575 : tail->next = ss;
12086 :
12087 575 : return tmp_ss;
12088 : }
12089 :
12090 :
12091 : /* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the
12092 : function is to be inlined. */
12093 :
12094 : static gfc_ss *
12095 6085 : walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
12096 : {
12097 6085 : if (expr->rank == 0)
12098 : return ss;
12099 :
12100 6085 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12101 6085 : gfc_actual_arglist *dim_arg = array_arg->next;
12102 6085 : gfc_actual_arglist *mask_arg = dim_arg->next;
12103 6085 : gfc_actual_arglist *kind_arg = mask_arg->next;
12104 6085 : gfc_actual_arglist *back_arg = kind_arg->next;
12105 :
12106 6085 : gfc_expr *array = array_arg->expr;
12107 6085 : gfc_expr *dim = dim_arg->expr;
12108 6085 : gfc_expr *mask = mask_arg->expr;
12109 6085 : gfc_expr *back = back_arg->expr;
12110 :
12111 6085 : if (dim == nullptr)
12112 3289 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12113 :
12114 2796 : gfc_ss *tmp_ss = gfc_ss_terminator;
12115 :
12116 2796 : bool scalar_mask = false;
12117 2796 : if (mask)
12118 : {
12119 1866 : gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
12120 1866 : if (mask_ss == tmp_ss)
12121 : scalar_mask = true;
12122 1174 : else if (maybe_absent_optional_variable (mask))
12123 20 : mask_ss->info->can_be_null_ref = true;
12124 :
12125 : tmp_ss = mask_ss;
12126 : }
12127 :
12128 2796 : gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
12129 2796 : gcc_assert (array_ss != tmp_ss);
12130 :
12131 2796 : tmp_ss = array_ss;
12132 :
12133 : /* Move the dimension on which we will sum to a separate nested scalarization
12134 : chain, "hiding" that dimension from the outer scalarization. */
12135 2796 : int dim_val = mpz_get_si (dim->value.integer);
12136 2796 : gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
12137 :
12138 2796 : if (back && array->rank > 1)
12139 : {
12140 : /* If there are nested scalarization loops, include BACK in the
12141 : scalarization chains to avoid evaluating it multiple times in a loop.
12142 : Otherwise, prefer to handle it outside of scalarization. */
12143 2796 : gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
12144 2796 : back_ss->info->type = GFC_SS_REFERENCE;
12145 2796 : if (maybe_absent_optional_variable (back))
12146 16 : back_ss->info->can_be_null_ref = true;
12147 :
12148 2796 : tail->next = back_ss;
12149 2796 : }
12150 : else
12151 0 : tail->next = ss;
12152 :
12153 2796 : if (scalar_mask)
12154 : {
12155 692 : tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
12156 : /* MASK can be a forwarded optional argument, so make the necessary setup
12157 : to avoid the scalarizer generating any unguarded pointer dereference in
12158 : that case. */
12159 692 : tmp_ss->info->type = GFC_SS_REFERENCE;
12160 692 : if (maybe_absent_optional_variable (mask))
12161 4 : tmp_ss->info->can_be_null_ref = true;
12162 : }
12163 :
12164 : return tmp_ss;
12165 : }
12166 :
12167 :
12168 : static gfc_ss *
12169 8340 : walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
12170 : {
12171 :
12172 8340 : switch (expr->value.function.isym->id)
12173 : {
12174 575 : case GFC_ISYM_PRODUCT:
12175 575 : case GFC_ISYM_SUM:
12176 575 : return walk_inline_intrinsic_arith (ss, expr);
12177 :
12178 1680 : case GFC_ISYM_TRANSPOSE:
12179 1680 : return walk_inline_intrinsic_transpose (ss, expr);
12180 :
12181 6085 : case GFC_ISYM_MAXLOC:
12182 6085 : case GFC_ISYM_MINLOC:
12183 6085 : return walk_inline_intrinsic_minmaxloc (ss, expr);
12184 :
12185 0 : default:
12186 0 : gcc_unreachable ();
12187 : }
12188 : gcc_unreachable ();
12189 : }
12190 :
12191 :
12192 : /* This generates code to execute before entering the scalarization loop.
12193 : Currently does nothing. */
12194 :
12195 : void
12196 11581 : gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
12197 : {
12198 11581 : switch (ss->info->expr->value.function.isym->id)
12199 : {
12200 11581 : case GFC_ISYM_UBOUND:
12201 11581 : case GFC_ISYM_LBOUND:
12202 11581 : case GFC_ISYM_COSHAPE:
12203 11581 : case GFC_ISYM_UCOBOUND:
12204 11581 : case GFC_ISYM_LCOBOUND:
12205 11581 : case GFC_ISYM_MAXLOC:
12206 11581 : case GFC_ISYM_MINLOC:
12207 11581 : case GFC_ISYM_THIS_IMAGE:
12208 11581 : case GFC_ISYM_SHAPE:
12209 11581 : break;
12210 :
12211 0 : default:
12212 0 : gcc_unreachable ();
12213 : }
12214 11581 : }
12215 :
12216 :
12217 : /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
12218 : one parameter are expanded into code inside the scalarization loop. */
12219 :
12220 : static gfc_ss *
12221 10161 : gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
12222 : {
12223 10161 : if (expr->value.function.actual->expr->ts.type == BT_CLASS)
12224 438 : gfc_add_class_array_ref (expr->value.function.actual->expr);
12225 :
12226 : /* The two argument version returns a scalar. */
12227 10161 : if (expr->value.function.isym->id != GFC_ISYM_SHAPE
12228 3522 : && expr->value.function.isym->id != GFC_ISYM_COSHAPE
12229 3518 : && expr->value.function.actual->next->expr)
12230 : return ss;
12231 :
12232 10161 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12233 : }
12234 :
12235 :
12236 : /* Walk an intrinsic array libcall. */
12237 :
12238 : static gfc_ss *
12239 14494 : gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
12240 : {
12241 14494 : gcc_assert (expr->rank > 0);
12242 14494 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12243 : }
12244 :
12245 :
12246 : /* Return whether the function call expression EXPR will be expanded
12247 : inline by gfc_conv_intrinsic_function. */
12248 :
12249 : bool
12250 302919 : gfc_inline_intrinsic_function_p (gfc_expr *expr)
12251 : {
12252 302919 : gfc_actual_arglist *args, *dim_arg, *mask_arg;
12253 302919 : gfc_expr *maskexpr;
12254 :
12255 302919 : gfc_intrinsic_sym *isym = expr->value.function.isym;
12256 302919 : if (!isym)
12257 : return false;
12258 :
12259 302877 : switch (isym->id)
12260 : {
12261 5106 : case GFC_ISYM_PRODUCT:
12262 5106 : case GFC_ISYM_SUM:
12263 : /* Disable inline expansion if code size matters. */
12264 5106 : if (optimize_size)
12265 : return false;
12266 :
12267 4251 : args = expr->value.function.actual;
12268 4251 : dim_arg = args->next;
12269 :
12270 : /* We need to be able to subset the SUM argument at compile-time. */
12271 4251 : if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
12272 : return false;
12273 :
12274 : /* FIXME: If MASK is optional for a more than two-dimensional
12275 : argument, the scalarizer gets confused if the mask is
12276 : absent. See PR 82995. For now, fall back to the library
12277 : function. */
12278 :
12279 3639 : mask_arg = dim_arg->next;
12280 3639 : maskexpr = mask_arg->expr;
12281 :
12282 3639 : if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
12283 276 : && maskexpr->symtree->n.sym->attr.dummy
12284 48 : && maskexpr->symtree->n.sym->attr.optional)
12285 : return false;
12286 :
12287 : return true;
12288 :
12289 : case GFC_ISYM_TRANSPOSE:
12290 : return true;
12291 :
12292 57188 : case GFC_ISYM_MINLOC:
12293 57188 : case GFC_ISYM_MAXLOC:
12294 57188 : {
12295 57188 : if ((isym->id == GFC_ISYM_MINLOC
12296 30521 : && (flag_inline_intrinsics
12297 30521 : & GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0)
12298 46611 : || (isym->id == GFC_ISYM_MAXLOC
12299 26667 : && (flag_inline_intrinsics
12300 26667 : & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0))
12301 : return false;
12302 :
12303 37638 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12304 37638 : gfc_actual_arglist *dim_arg = array_arg->next;
12305 :
12306 37638 : gfc_expr *array = array_arg->expr;
12307 37638 : gfc_expr *dim = dim_arg->expr;
12308 :
12309 37638 : if (!(array->ts.type == BT_INTEGER
12310 : || array->ts.type == BT_REAL))
12311 : return false;
12312 :
12313 34658 : if (array->rank == 1)
12314 : return true;
12315 :
12316 20711 : if (dim != nullptr
12317 13372 : && dim->expr_type != EXPR_CONSTANT)
12318 : return false;
12319 :
12320 : return true;
12321 : }
12322 :
12323 : default:
12324 : return false;
12325 : }
12326 : }
12327 :
12328 :
12329 : /* Returns nonzero if the specified intrinsic function call maps directly to
12330 : an external library call. Should only be used for functions that return
12331 : arrays. */
12332 :
12333 : int
12334 87995 : gfc_is_intrinsic_libcall (gfc_expr * expr)
12335 : {
12336 87995 : gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
12337 87995 : gcc_assert (expr->rank > 0);
12338 :
12339 87995 : if (gfc_inline_intrinsic_function_p (expr))
12340 : return 0;
12341 :
12342 73390 : switch (expr->value.function.isym->id)
12343 : {
12344 : case GFC_ISYM_ALL:
12345 : case GFC_ISYM_ANY:
12346 : case GFC_ISYM_COUNT:
12347 : case GFC_ISYM_FINDLOC:
12348 : case GFC_ISYM_JN2:
12349 : case GFC_ISYM_IANY:
12350 : case GFC_ISYM_IALL:
12351 : case GFC_ISYM_IPARITY:
12352 : case GFC_ISYM_MATMUL:
12353 : case GFC_ISYM_MAXLOC:
12354 : case GFC_ISYM_MAXVAL:
12355 : case GFC_ISYM_MINLOC:
12356 : case GFC_ISYM_MINVAL:
12357 : case GFC_ISYM_NORM2:
12358 : case GFC_ISYM_PARITY:
12359 : case GFC_ISYM_PRODUCT:
12360 : case GFC_ISYM_SUM:
12361 : case GFC_ISYM_SPREAD:
12362 : case GFC_ISYM_YN2:
12363 : /* Ignore absent optional parameters. */
12364 : return 1;
12365 :
12366 15801 : case GFC_ISYM_CSHIFT:
12367 15801 : case GFC_ISYM_EOSHIFT:
12368 15801 : case GFC_ISYM_GET_TEAM:
12369 15801 : case GFC_ISYM_FAILED_IMAGES:
12370 15801 : case GFC_ISYM_STOPPED_IMAGES:
12371 15801 : case GFC_ISYM_PACK:
12372 15801 : case GFC_ISYM_REDUCE:
12373 15801 : case GFC_ISYM_RESHAPE:
12374 15801 : case GFC_ISYM_UNPACK:
12375 : /* Pass absent optional parameters. */
12376 15801 : return 2;
12377 :
12378 : default:
12379 : return 0;
12380 : }
12381 : }
12382 :
12383 : /* Walk an intrinsic function. */
12384 : gfc_ss *
12385 55904 : gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
12386 : gfc_intrinsic_sym * isym)
12387 : {
12388 55904 : gcc_assert (isym);
12389 :
12390 55904 : if (isym->elemental)
12391 18417 : return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
12392 : expr->value.function.isym,
12393 18417 : GFC_SS_SCALAR);
12394 :
12395 37487 : if (expr->rank == 0 && expr->corank == 0)
12396 : return ss;
12397 :
12398 32995 : if (gfc_inline_intrinsic_function_p (expr))
12399 8340 : return walk_inline_intrinsic_function (ss, expr);
12400 :
12401 24655 : if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
12402 13511 : return gfc_walk_intrinsic_libfunc (ss, expr);
12403 :
12404 : /* Special cases. */
12405 11144 : switch (isym->id)
12406 : {
12407 10161 : case GFC_ISYM_COSHAPE:
12408 10161 : case GFC_ISYM_LBOUND:
12409 10161 : case GFC_ISYM_LCOBOUND:
12410 10161 : case GFC_ISYM_UBOUND:
12411 10161 : case GFC_ISYM_UCOBOUND:
12412 10161 : case GFC_ISYM_THIS_IMAGE:
12413 10161 : case GFC_ISYM_SHAPE:
12414 10161 : return gfc_walk_intrinsic_bound (ss, expr);
12415 :
12416 983 : case GFC_ISYM_TRANSFER:
12417 983 : case GFC_ISYM_CAF_GET:
12418 983 : return gfc_walk_intrinsic_libfunc (ss, expr);
12419 :
12420 0 : default:
12421 : /* This probably meant someone forgot to add an intrinsic to the above
12422 : list(s) when they implemented it, or something's gone horribly
12423 : wrong. */
12424 0 : gcc_unreachable ();
12425 : }
12426 : }
12427 :
12428 : static tree
12429 88 : conv_co_collective (gfc_code *code)
12430 : {
12431 88 : gfc_se argse;
12432 88 : stmtblock_t block, post_block;
12433 88 : tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
12434 88 : gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
12435 :
12436 88 : gfc_start_block (&block);
12437 88 : gfc_init_block (&post_block);
12438 :
12439 88 : if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
12440 : {
12441 17 : opr_expr = code->ext.actual->next->expr;
12442 17 : image_idx_expr = code->ext.actual->next->next->expr;
12443 17 : stat_expr = code->ext.actual->next->next->next->expr;
12444 17 : errmsg_expr = code->ext.actual->next->next->next->next->expr;
12445 : }
12446 : else
12447 : {
12448 71 : opr_expr = NULL;
12449 71 : image_idx_expr = code->ext.actual->next->expr;
12450 71 : stat_expr = code->ext.actual->next->next->expr;
12451 71 : errmsg_expr = code->ext.actual->next->next->next->expr;
12452 : }
12453 :
12454 : /* stat. */
12455 88 : if (stat_expr)
12456 : {
12457 59 : gfc_init_se (&argse, NULL);
12458 59 : gfc_conv_expr (&argse, stat_expr);
12459 59 : gfc_add_block_to_block (&block, &argse.pre);
12460 59 : gfc_add_block_to_block (&post_block, &argse.post);
12461 59 : stat = argse.expr;
12462 59 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
12463 32 : stat = gfc_build_addr_expr (NULL_TREE, stat);
12464 : }
12465 29 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
12466 : stat = NULL_TREE;
12467 : else
12468 20 : stat = null_pointer_node;
12469 :
12470 : /* Early exit for GFC_FCOARRAY_SINGLE. */
12471 88 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
12472 : {
12473 36 : if (stat != NULL_TREE)
12474 : {
12475 : /* For optional stats, check the pointer is valid before zero'ing. */
12476 27 : if (gfc_expr_attr (stat_expr).optional)
12477 : {
12478 12 : tree tmp;
12479 12 : stmtblock_t ass_block;
12480 12 : gfc_start_block (&ass_block);
12481 12 : gfc_add_modify (&ass_block, stat,
12482 12 : fold_convert (TREE_TYPE (stat),
12483 : integer_zero_node));
12484 12 : tmp = fold_build2 (NE_EXPR, logical_type_node,
12485 : gfc_build_addr_expr (NULL_TREE, stat),
12486 : null_pointer_node);
12487 12 : tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
12488 : gfc_finish_block (&ass_block),
12489 : build_empty_stmt (input_location));
12490 12 : gfc_add_expr_to_block (&block, tmp);
12491 : }
12492 : else
12493 15 : gfc_add_modify (&block, stat,
12494 15 : fold_convert (TREE_TYPE (stat), integer_zero_node));
12495 : }
12496 36 : return gfc_finish_block (&block);
12497 : }
12498 :
12499 5 : gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
12500 52 : ? code->ext.actual->expr->ts.u.derived : NULL;
12501 :
12502 : /* Handle the array. */
12503 52 : gfc_init_se (&argse, NULL);
12504 52 : if (!derived || !derived->attr.alloc_comp
12505 1 : || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
12506 : {
12507 51 : if (code->ext.actual->expr->rank == 0)
12508 : {
12509 22 : symbol_attribute attr;
12510 22 : gfc_clear_attr (&attr);
12511 22 : gfc_init_se (&argse, NULL);
12512 22 : gfc_conv_expr (&argse, code->ext.actual->expr);
12513 22 : gfc_add_block_to_block (&block, &argse.pre);
12514 22 : gfc_add_block_to_block (&post_block, &argse.post);
12515 22 : array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
12516 22 : array = gfc_build_addr_expr (NULL_TREE, array);
12517 : }
12518 : else
12519 : {
12520 29 : argse.want_pointer = 1;
12521 29 : gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
12522 29 : array = argse.expr;
12523 : }
12524 : }
12525 :
12526 52 : gfc_add_block_to_block (&block, &argse.pre);
12527 52 : gfc_add_block_to_block (&post_block, &argse.post);
12528 :
12529 52 : if (code->ext.actual->expr->ts.type == BT_CHARACTER)
12530 15 : strlen = argse.string_length;
12531 : else
12532 37 : strlen = integer_zero_node;
12533 :
12534 : /* image_index. */
12535 52 : if (image_idx_expr)
12536 : {
12537 35 : gfc_init_se (&argse, NULL);
12538 35 : gfc_conv_expr (&argse, image_idx_expr);
12539 35 : gfc_add_block_to_block (&block, &argse.pre);
12540 35 : gfc_add_block_to_block (&post_block, &argse.post);
12541 35 : image_index = fold_convert (integer_type_node, argse.expr);
12542 : }
12543 : else
12544 17 : image_index = integer_zero_node;
12545 :
12546 : /* errmsg. */
12547 52 : if (errmsg_expr)
12548 : {
12549 25 : gfc_init_se (&argse, NULL);
12550 25 : gfc_conv_expr (&argse, errmsg_expr);
12551 25 : gfc_add_block_to_block (&block, &argse.pre);
12552 25 : gfc_add_block_to_block (&post_block, &argse.post);
12553 25 : errmsg = argse.expr;
12554 25 : errmsg_len = fold_convert (size_type_node, argse.string_length);
12555 : }
12556 : else
12557 : {
12558 27 : errmsg = null_pointer_node;
12559 27 : errmsg_len = build_zero_cst (size_type_node);
12560 : }
12561 :
12562 : /* Generate the function call. */
12563 52 : switch (code->resolved_isym->id)
12564 : {
12565 20 : case GFC_ISYM_CO_BROADCAST:
12566 20 : fndecl = gfor_fndecl_co_broadcast;
12567 20 : break;
12568 8 : case GFC_ISYM_CO_MAX:
12569 8 : fndecl = gfor_fndecl_co_max;
12570 8 : break;
12571 6 : case GFC_ISYM_CO_MIN:
12572 6 : fndecl = gfor_fndecl_co_min;
12573 6 : break;
12574 12 : case GFC_ISYM_CO_REDUCE:
12575 12 : fndecl = gfor_fndecl_co_reduce;
12576 12 : break;
12577 6 : case GFC_ISYM_CO_SUM:
12578 6 : fndecl = gfor_fndecl_co_sum;
12579 6 : break;
12580 0 : default:
12581 0 : gcc_unreachable ();
12582 : }
12583 :
12584 52 : if (derived && derived->attr.alloc_comp
12585 1 : && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12586 : /* The derived type has the attribute 'alloc_comp'. */
12587 : {
12588 2 : tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
12589 1 : code->ext.actual->expr->rank,
12590 : image_index, stat, errmsg, errmsg_len);
12591 1 : gfc_add_expr_to_block (&block, tmp);
12592 1 : }
12593 : else
12594 : {
12595 51 : if (code->resolved_isym->id == GFC_ISYM_CO_SUM
12596 45 : || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12597 25 : fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
12598 : image_index, stat, errmsg, errmsg_len);
12599 26 : else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
12600 14 : fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
12601 : image_index, stat, errmsg,
12602 : strlen, errmsg_len);
12603 : else
12604 : {
12605 12 : tree opr, opr_flags;
12606 :
12607 : // FIXME: Handle TS29113's bind(C) strings with descriptor.
12608 12 : int opr_flag_int;
12609 12 : if (gfc_is_proc_ptr_comp (opr_expr))
12610 : {
12611 0 : gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
12612 0 : opr_flag_int = sym->attr.dimension
12613 0 : || (sym->ts.type == BT_CHARACTER
12614 0 : && !sym->attr.is_bind_c)
12615 0 : ? GFC_CAF_BYREF : 0;
12616 0 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12617 0 : && !sym->attr.is_bind_c
12618 0 : ? GFC_CAF_HIDDENLEN : 0;
12619 0 : opr_flag_int |= sym->formal->sym->attr.value
12620 0 : ? GFC_CAF_ARG_VALUE : 0;
12621 : }
12622 : else
12623 : {
12624 12 : opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
12625 12 : ? GFC_CAF_BYREF : 0;
12626 24 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12627 0 : && !opr_expr->symtree->n.sym->attr.is_bind_c
12628 12 : ? GFC_CAF_HIDDENLEN : 0;
12629 12 : opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
12630 12 : ? GFC_CAF_ARG_VALUE : 0;
12631 : }
12632 12 : opr_flags = build_int_cst (integer_type_node, opr_flag_int);
12633 12 : gfc_conv_expr (&argse, opr_expr);
12634 12 : opr = argse.expr;
12635 12 : fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
12636 : opr_flags, image_index, stat, errmsg,
12637 : strlen, errmsg_len);
12638 : }
12639 : }
12640 :
12641 52 : gfc_add_expr_to_block (&block, fndecl);
12642 52 : gfc_add_block_to_block (&block, &post_block);
12643 :
12644 52 : return gfc_finish_block (&block);
12645 : }
12646 :
12647 :
12648 : static tree
12649 95 : conv_intrinsic_atomic_op (gfc_code *code)
12650 : {
12651 95 : gfc_se argse;
12652 95 : tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
12653 95 : stmtblock_t block, post_block;
12654 95 : gfc_expr *atom_expr = code->ext.actual->expr;
12655 95 : gfc_expr *stat_expr;
12656 95 : built_in_function fn;
12657 :
12658 95 : if (atom_expr->expr_type == EXPR_FUNCTION
12659 0 : && atom_expr->value.function.isym
12660 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12661 0 : atom_expr = atom_expr->value.function.actual->expr;
12662 :
12663 95 : gfc_start_block (&block);
12664 95 : gfc_init_block (&post_block);
12665 :
12666 95 : gfc_init_se (&argse, NULL);
12667 95 : argse.want_pointer = 1;
12668 95 : gfc_conv_expr (&argse, atom_expr);
12669 95 : gfc_add_block_to_block (&block, &argse.pre);
12670 95 : gfc_add_block_to_block (&post_block, &argse.post);
12671 95 : atom = argse.expr;
12672 :
12673 95 : gfc_init_se (&argse, NULL);
12674 95 : if (flag_coarray == GFC_FCOARRAY_LIB
12675 56 : && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
12676 54 : argse.want_pointer = 1;
12677 95 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12678 95 : gfc_add_block_to_block (&block, &argse.pre);
12679 95 : gfc_add_block_to_block (&post_block, &argse.post);
12680 95 : value = argse.expr;
12681 :
12682 95 : switch (code->resolved_isym->id)
12683 : {
12684 58 : case GFC_ISYM_ATOMIC_ADD:
12685 58 : case GFC_ISYM_ATOMIC_AND:
12686 58 : case GFC_ISYM_ATOMIC_DEF:
12687 58 : case GFC_ISYM_ATOMIC_OR:
12688 58 : case GFC_ISYM_ATOMIC_XOR:
12689 58 : stat_expr = code->ext.actual->next->next->expr;
12690 58 : if (flag_coarray == GFC_FCOARRAY_LIB)
12691 34 : old = null_pointer_node;
12692 : break;
12693 37 : default:
12694 37 : gfc_init_se (&argse, NULL);
12695 37 : if (flag_coarray == GFC_FCOARRAY_LIB)
12696 22 : argse.want_pointer = 1;
12697 37 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12698 37 : gfc_add_block_to_block (&block, &argse.pre);
12699 37 : gfc_add_block_to_block (&post_block, &argse.post);
12700 37 : old = argse.expr;
12701 37 : stat_expr = code->ext.actual->next->next->next->expr;
12702 : }
12703 :
12704 : /* STAT= */
12705 95 : if (stat_expr != NULL)
12706 : {
12707 82 : gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
12708 82 : gfc_init_se (&argse, NULL);
12709 82 : if (flag_coarray == GFC_FCOARRAY_LIB)
12710 48 : argse.want_pointer = 1;
12711 82 : gfc_conv_expr_val (&argse, stat_expr);
12712 82 : gfc_add_block_to_block (&block, &argse.pre);
12713 82 : gfc_add_block_to_block (&post_block, &argse.post);
12714 82 : stat = argse.expr;
12715 : }
12716 13 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12717 8 : stat = null_pointer_node;
12718 :
12719 95 : if (flag_coarray == GFC_FCOARRAY_LIB)
12720 : {
12721 56 : tree image_index, caf_decl, offset, token;
12722 56 : int op;
12723 :
12724 56 : switch (code->resolved_isym->id)
12725 : {
12726 : case GFC_ISYM_ATOMIC_ADD:
12727 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12728 : op = (int) GFC_CAF_ATOMIC_ADD;
12729 : break;
12730 12 : case GFC_ISYM_ATOMIC_AND:
12731 12 : case GFC_ISYM_ATOMIC_FETCH_AND:
12732 12 : op = (int) GFC_CAF_ATOMIC_AND;
12733 12 : break;
12734 12 : case GFC_ISYM_ATOMIC_OR:
12735 12 : case GFC_ISYM_ATOMIC_FETCH_OR:
12736 12 : op = (int) GFC_CAF_ATOMIC_OR;
12737 12 : break;
12738 12 : case GFC_ISYM_ATOMIC_XOR:
12739 12 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12740 12 : op = (int) GFC_CAF_ATOMIC_XOR;
12741 12 : break;
12742 11 : case GFC_ISYM_ATOMIC_DEF:
12743 11 : op = 0; /* Unused. */
12744 11 : break;
12745 0 : default:
12746 0 : gcc_unreachable ();
12747 : }
12748 :
12749 56 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12750 56 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12751 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12752 :
12753 56 : if (gfc_is_coindexed (atom_expr))
12754 48 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12755 : else
12756 8 : image_index = integer_zero_node;
12757 :
12758 : /* Ensure VALUE names addressable storage: taking the address of a
12759 : constant is invalid in C, and scalars need a temporary as well. */
12760 56 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12761 : {
12762 42 : tree elem
12763 42 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value);
12764 42 : elem = gfc_trans_force_lval (&block, elem);
12765 42 : value = gfc_build_addr_expr (NULL_TREE, elem);
12766 : }
12767 14 : else if (TREE_CODE (value) == ADDR_EXPR
12768 14 : && TREE_CONSTANT (TREE_OPERAND (value, 0)))
12769 : {
12770 0 : tree elem
12771 0 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)),
12772 : build_fold_indirect_ref (value));
12773 0 : elem = gfc_trans_force_lval (&block, elem);
12774 0 : value = gfc_build_addr_expr (NULL_TREE, elem);
12775 : }
12776 :
12777 56 : gfc_init_se (&argse, NULL);
12778 56 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12779 : atom_expr);
12780 :
12781 56 : gfc_add_block_to_block (&block, &argse.pre);
12782 56 : if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
12783 11 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
12784 : token, offset, image_index, value, stat,
12785 : build_int_cst (integer_type_node,
12786 11 : (int) atom_expr->ts.type),
12787 : build_int_cst (integer_type_node,
12788 11 : (int) atom_expr->ts.kind));
12789 : else
12790 45 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
12791 45 : build_int_cst (integer_type_node, op),
12792 : token, offset, image_index, value, old, stat,
12793 : build_int_cst (integer_type_node,
12794 45 : (int) atom_expr->ts.type),
12795 : build_int_cst (integer_type_node,
12796 45 : (int) atom_expr->ts.kind));
12797 :
12798 56 : gfc_add_expr_to_block (&block, tmp);
12799 56 : gfc_add_block_to_block (&block, &argse.post);
12800 56 : gfc_add_block_to_block (&block, &post_block);
12801 56 : return gfc_finish_block (&block);
12802 : }
12803 :
12804 :
12805 39 : switch (code->resolved_isym->id)
12806 : {
12807 : case GFC_ISYM_ATOMIC_ADD:
12808 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12809 : fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
12810 : break;
12811 8 : case GFC_ISYM_ATOMIC_AND:
12812 8 : case GFC_ISYM_ATOMIC_FETCH_AND:
12813 8 : fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12814 8 : break;
12815 9 : case GFC_ISYM_ATOMIC_DEF:
12816 9 : fn = BUILT_IN_ATOMIC_STORE_N;
12817 9 : break;
12818 8 : case GFC_ISYM_ATOMIC_OR:
12819 8 : case GFC_ISYM_ATOMIC_FETCH_OR:
12820 8 : fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12821 8 : break;
12822 8 : case GFC_ISYM_ATOMIC_XOR:
12823 8 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12824 8 : fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12825 8 : break;
12826 0 : default:
12827 0 : gcc_unreachable ();
12828 : }
12829 :
12830 39 : tmp = TREE_TYPE (TREE_TYPE (atom));
12831 78 : fn = (built_in_function) ((int) fn
12832 39 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12833 39 : + 1);
12834 39 : tree itype = TREE_TYPE (TREE_TYPE (atom));
12835 39 : tmp = builtin_decl_explicit (fn);
12836 :
12837 39 : switch (code->resolved_isym->id)
12838 : {
12839 24 : case GFC_ISYM_ATOMIC_ADD:
12840 24 : case GFC_ISYM_ATOMIC_AND:
12841 24 : case GFC_ISYM_ATOMIC_DEF:
12842 24 : case GFC_ISYM_ATOMIC_OR:
12843 24 : case GFC_ISYM_ATOMIC_XOR:
12844 24 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12845 : fold_convert (itype, value),
12846 : build_int_cst (NULL, MEMMODEL_RELAXED));
12847 24 : gfc_add_expr_to_block (&block, tmp);
12848 24 : break;
12849 15 : default:
12850 15 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12851 : fold_convert (itype, value),
12852 : build_int_cst (NULL, MEMMODEL_RELAXED));
12853 15 : gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12854 15 : break;
12855 : }
12856 :
12857 39 : if (stat != NULL_TREE)
12858 34 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12859 39 : gfc_add_block_to_block (&block, &post_block);
12860 39 : return gfc_finish_block (&block);
12861 : }
12862 :
12863 :
12864 : static tree
12865 176 : conv_intrinsic_atomic_ref (gfc_code *code)
12866 : {
12867 176 : gfc_se argse;
12868 176 : tree tmp, atom, value, stat = NULL_TREE;
12869 176 : stmtblock_t block, post_block;
12870 176 : built_in_function fn;
12871 176 : gfc_expr *atom_expr = code->ext.actual->next->expr;
12872 :
12873 176 : if (atom_expr->expr_type == EXPR_FUNCTION
12874 0 : && atom_expr->value.function.isym
12875 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12876 0 : atom_expr = atom_expr->value.function.actual->expr;
12877 :
12878 176 : gfc_start_block (&block);
12879 176 : gfc_init_block (&post_block);
12880 176 : gfc_init_se (&argse, NULL);
12881 176 : argse.want_pointer = 1;
12882 176 : gfc_conv_expr (&argse, atom_expr);
12883 176 : gfc_add_block_to_block (&block, &argse.pre);
12884 176 : gfc_add_block_to_block (&post_block, &argse.post);
12885 176 : atom = argse.expr;
12886 :
12887 176 : gfc_init_se (&argse, NULL);
12888 176 : if (flag_coarray == GFC_FCOARRAY_LIB
12889 115 : && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12890 109 : argse.want_pointer = 1;
12891 176 : gfc_conv_expr (&argse, code->ext.actual->expr);
12892 176 : gfc_add_block_to_block (&block, &argse.pre);
12893 176 : gfc_add_block_to_block (&post_block, &argse.post);
12894 176 : value = argse.expr;
12895 :
12896 : /* STAT= */
12897 176 : if (code->ext.actual->next->next->expr != NULL)
12898 : {
12899 164 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12900 : == EXPR_VARIABLE);
12901 164 : gfc_init_se (&argse, NULL);
12902 164 : if (flag_coarray == GFC_FCOARRAY_LIB)
12903 108 : argse.want_pointer = 1;
12904 164 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12905 164 : gfc_add_block_to_block (&block, &argse.pre);
12906 164 : gfc_add_block_to_block (&post_block, &argse.post);
12907 164 : stat = argse.expr;
12908 : }
12909 12 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12910 7 : stat = null_pointer_node;
12911 :
12912 176 : if (flag_coarray == GFC_FCOARRAY_LIB)
12913 : {
12914 115 : tree image_index, caf_decl, offset, token;
12915 115 : tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12916 :
12917 115 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12918 115 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12919 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12920 :
12921 115 : if (gfc_is_coindexed (atom_expr))
12922 103 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12923 : else
12924 12 : image_index = integer_zero_node;
12925 :
12926 115 : gfc_init_se (&argse, NULL);
12927 115 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12928 : atom_expr);
12929 115 : gfc_add_block_to_block (&block, &argse.pre);
12930 :
12931 : /* Different type, need type conversion. */
12932 115 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12933 : {
12934 6 : vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12935 6 : orig_value = value;
12936 6 : value = gfc_build_addr_expr (NULL_TREE, vardecl);
12937 : }
12938 :
12939 115 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12940 : token, offset, image_index, value, stat,
12941 : build_int_cst (integer_type_node,
12942 115 : (int) atom_expr->ts.type),
12943 : build_int_cst (integer_type_node,
12944 115 : (int) atom_expr->ts.kind));
12945 115 : gfc_add_expr_to_block (&block, tmp);
12946 115 : if (vardecl != NULL_TREE)
12947 6 : gfc_add_modify (&block, orig_value,
12948 6 : fold_convert (TREE_TYPE (orig_value), vardecl));
12949 115 : gfc_add_block_to_block (&block, &argse.post);
12950 115 : gfc_add_block_to_block (&block, &post_block);
12951 115 : return gfc_finish_block (&block);
12952 : }
12953 :
12954 61 : tmp = TREE_TYPE (TREE_TYPE (atom));
12955 122 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12956 61 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12957 61 : + 1);
12958 61 : tmp = builtin_decl_explicit (fn);
12959 61 : tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12960 : build_int_cst (integer_type_node,
12961 : MEMMODEL_RELAXED));
12962 61 : gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12963 :
12964 61 : if (stat != NULL_TREE)
12965 56 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12966 61 : gfc_add_block_to_block (&block, &post_block);
12967 61 : return gfc_finish_block (&block);
12968 : }
12969 :
12970 :
12971 : static tree
12972 14 : conv_intrinsic_atomic_cas (gfc_code *code)
12973 : {
12974 14 : gfc_se argse;
12975 14 : tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12976 14 : stmtblock_t block, post_block;
12977 14 : built_in_function fn;
12978 14 : gfc_expr *atom_expr = code->ext.actual->expr;
12979 :
12980 14 : if (atom_expr->expr_type == EXPR_FUNCTION
12981 0 : && atom_expr->value.function.isym
12982 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12983 0 : atom_expr = atom_expr->value.function.actual->expr;
12984 :
12985 14 : gfc_init_block (&block);
12986 14 : gfc_init_block (&post_block);
12987 14 : gfc_init_se (&argse, NULL);
12988 14 : argse.want_pointer = 1;
12989 14 : gfc_conv_expr (&argse, atom_expr);
12990 14 : atom = argse.expr;
12991 :
12992 14 : gfc_init_se (&argse, NULL);
12993 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
12994 8 : argse.want_pointer = 1;
12995 14 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12996 14 : gfc_add_block_to_block (&block, &argse.pre);
12997 14 : gfc_add_block_to_block (&post_block, &argse.post);
12998 14 : old = argse.expr;
12999 :
13000 14 : gfc_init_se (&argse, NULL);
13001 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13002 8 : argse.want_pointer = 1;
13003 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
13004 14 : gfc_add_block_to_block (&block, &argse.pre);
13005 14 : gfc_add_block_to_block (&post_block, &argse.post);
13006 14 : comp = argse.expr;
13007 :
13008 14 : gfc_init_se (&argse, NULL);
13009 14 : if (flag_coarray == GFC_FCOARRAY_LIB
13010 8 : && code->ext.actual->next->next->next->expr->ts.kind
13011 8 : == atom_expr->ts.kind)
13012 8 : argse.want_pointer = 1;
13013 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
13014 14 : gfc_add_block_to_block (&block, &argse.pre);
13015 14 : gfc_add_block_to_block (&post_block, &argse.post);
13016 14 : new_val = argse.expr;
13017 :
13018 : /* STAT= */
13019 14 : if (code->ext.actual->next->next->next->next->expr != NULL)
13020 : {
13021 14 : gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
13022 : == EXPR_VARIABLE);
13023 14 : gfc_init_se (&argse, NULL);
13024 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13025 8 : argse.want_pointer = 1;
13026 14 : gfc_conv_expr_val (&argse,
13027 14 : code->ext.actual->next->next->next->next->expr);
13028 14 : gfc_add_block_to_block (&block, &argse.pre);
13029 14 : gfc_add_block_to_block (&post_block, &argse.post);
13030 14 : stat = argse.expr;
13031 : }
13032 0 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13033 0 : stat = null_pointer_node;
13034 :
13035 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13036 : {
13037 8 : tree image_index, caf_decl, offset, token;
13038 :
13039 8 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
13040 8 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
13041 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
13042 :
13043 8 : if (gfc_is_coindexed (atom_expr))
13044 8 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
13045 : else
13046 0 : image_index = integer_zero_node;
13047 :
13048 8 : if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
13049 : {
13050 0 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
13051 0 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
13052 0 : new_val = gfc_build_addr_expr (NULL_TREE, tmp);
13053 : }
13054 :
13055 8 : gfc_init_se (&argse, NULL);
13056 8 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
13057 : atom_expr);
13058 8 : gfc_add_block_to_block (&block, &argse.pre);
13059 :
13060 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
13061 : token, offset, image_index, old, comp, new_val,
13062 : stat, build_int_cst (integer_type_node,
13063 8 : (int) atom_expr->ts.type),
13064 : build_int_cst (integer_type_node,
13065 8 : (int) atom_expr->ts.kind));
13066 8 : gfc_add_expr_to_block (&block, tmp);
13067 8 : gfc_add_block_to_block (&block, &argse.post);
13068 8 : gfc_add_block_to_block (&block, &post_block);
13069 8 : return gfc_finish_block (&block);
13070 : }
13071 :
13072 6 : tmp = TREE_TYPE (TREE_TYPE (atom));
13073 12 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
13074 6 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
13075 6 : + 1);
13076 6 : tmp = builtin_decl_explicit (fn);
13077 :
13078 6 : gfc_add_modify (&block, old, comp);
13079 12 : tmp = build_call_expr_loc (input_location, tmp, 6, atom,
13080 : gfc_build_addr_expr (NULL, old),
13081 6 : fold_convert (TREE_TYPE (old), new_val),
13082 : boolean_false_node,
13083 : build_int_cst (NULL, MEMMODEL_RELAXED),
13084 : build_int_cst (NULL, MEMMODEL_RELAXED));
13085 6 : gfc_add_expr_to_block (&block, tmp);
13086 :
13087 6 : if (stat != NULL_TREE)
13088 6 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
13089 6 : gfc_add_block_to_block (&block, &post_block);
13090 6 : return gfc_finish_block (&block);
13091 : }
13092 :
13093 : static tree
13094 105 : conv_intrinsic_event_query (gfc_code *code)
13095 : {
13096 105 : gfc_se se, argse;
13097 105 : tree stat = NULL_TREE, stat2 = NULL_TREE;
13098 105 : tree count = NULL_TREE, count2 = NULL_TREE;
13099 :
13100 105 : gfc_expr *event_expr = code->ext.actual->expr;
13101 :
13102 105 : if (code->ext.actual->next->next->expr)
13103 : {
13104 18 : gcc_assert (code->ext.actual->next->next->expr->expr_type
13105 : == EXPR_VARIABLE);
13106 18 : gfc_init_se (&argse, NULL);
13107 18 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
13108 18 : stat = argse.expr;
13109 : }
13110 87 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13111 58 : stat = null_pointer_node;
13112 :
13113 105 : if (code->ext.actual->next->expr)
13114 : {
13115 105 : gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
13116 105 : gfc_init_se (&argse, NULL);
13117 105 : gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
13118 105 : count = argse.expr;
13119 : }
13120 :
13121 105 : gfc_start_block (&se.pre);
13122 105 : if (flag_coarray == GFC_FCOARRAY_LIB)
13123 : {
13124 70 : tree tmp, token, image_index;
13125 70 : tree index = build_zero_cst (gfc_array_index_type);
13126 :
13127 70 : if (event_expr->expr_type == EXPR_FUNCTION
13128 0 : && event_expr->value.function.isym
13129 0 : && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
13130 0 : event_expr = event_expr->value.function.actual->expr;
13131 :
13132 70 : tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
13133 :
13134 70 : if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
13135 70 : || event_expr->symtree->n.sym->ts.u.derived->from_intmod
13136 : != INTMOD_ISO_FORTRAN_ENV
13137 70 : || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
13138 : != ISOFORTRAN_EVENT_TYPE)
13139 : {
13140 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
13141 : "yet supported", &event_expr->where);
13142 0 : return NULL_TREE;
13143 : }
13144 :
13145 70 : if (gfc_is_coindexed (event_expr))
13146 : {
13147 0 : gfc_error ("The event variable at %L shall not be coindexed",
13148 : &event_expr->where);
13149 0 : return NULL_TREE;
13150 : }
13151 :
13152 70 : image_index = integer_zero_node;
13153 :
13154 70 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
13155 : event_expr);
13156 :
13157 : /* For arrays, obtain the array index. */
13158 70 : if (gfc_expr_attr (event_expr).dimension)
13159 : {
13160 52 : tree desc, tmp, extent, lbound, ubound;
13161 52 : gfc_array_ref *ar, ar2;
13162 52 : int i;
13163 :
13164 : /* TODO: Extend this, once DT components are supported. */
13165 52 : ar = &event_expr->ref->u.ar;
13166 52 : ar2 = *ar;
13167 52 : memset (ar, '\0', sizeof (*ar));
13168 52 : ar->as = ar2.as;
13169 52 : ar->type = AR_FULL;
13170 :
13171 52 : gfc_init_se (&argse, NULL);
13172 52 : argse.descriptor_only = 1;
13173 52 : gfc_conv_expr_descriptor (&argse, event_expr);
13174 52 : gfc_add_block_to_block (&se.pre, &argse.pre);
13175 52 : desc = argse.expr;
13176 52 : *ar = ar2;
13177 :
13178 52 : extent = build_one_cst (gfc_array_index_type);
13179 156 : for (i = 0; i < ar->dimen; i++)
13180 : {
13181 52 : gfc_init_se (&argse, NULL);
13182 52 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
13183 52 : gfc_add_block_to_block (&argse.pre, &argse.pre);
13184 52 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
13185 52 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
13186 52 : TREE_TYPE (lbound), argse.expr, lbound);
13187 52 : tmp = fold_build2_loc (input_location, MULT_EXPR,
13188 52 : TREE_TYPE (tmp), extent, tmp);
13189 52 : index = fold_build2_loc (input_location, PLUS_EXPR,
13190 52 : TREE_TYPE (tmp), index, tmp);
13191 52 : if (i < ar->dimen - 1)
13192 : {
13193 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
13194 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
13195 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
13196 0 : TREE_TYPE (tmp), extent, tmp);
13197 : }
13198 : }
13199 : }
13200 :
13201 70 : if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
13202 : {
13203 0 : count2 = count;
13204 0 : count = gfc_create_var (integer_type_node, "count");
13205 : }
13206 :
13207 70 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
13208 : {
13209 0 : stat2 = stat;
13210 0 : stat = gfc_create_var (integer_type_node, "stat");
13211 : }
13212 :
13213 70 : index = fold_convert (size_type_node, index);
13214 140 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
13215 : token, index, image_index, count
13216 70 : ? gfc_build_addr_expr (NULL, count) : count,
13217 70 : stat != null_pointer_node
13218 12 : ? gfc_build_addr_expr (NULL, stat) : stat);
13219 70 : gfc_add_expr_to_block (&se.pre, tmp);
13220 :
13221 70 : if (count2 != NULL_TREE)
13222 0 : gfc_add_modify (&se.pre, count2,
13223 0 : fold_convert (TREE_TYPE (count2), count));
13224 :
13225 70 : if (stat2 != NULL_TREE)
13226 0 : gfc_add_modify (&se.pre, stat2,
13227 0 : fold_convert (TREE_TYPE (stat2), stat));
13228 :
13229 70 : return gfc_finish_block (&se.pre);
13230 : }
13231 :
13232 35 : gfc_init_se (&argse, NULL);
13233 35 : gfc_conv_expr_val (&argse, code->ext.actual->expr);
13234 35 : gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
13235 :
13236 35 : if (stat != NULL_TREE)
13237 6 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
13238 :
13239 35 : return gfc_finish_block (&se.pre);
13240 : }
13241 :
13242 :
13243 : /* This is a peculiar case because of the need to do dependency checking.
13244 : It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
13245 : a special case and this function called instead of
13246 : gfc_conv_procedure_call. */
13247 : void
13248 197 : gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
13249 : gfc_loopinfo *loop)
13250 : {
13251 197 : gfc_actual_arglist *actual;
13252 197 : gfc_se argse[5];
13253 197 : gfc_expr *arg[5];
13254 197 : gfc_ss *lss;
13255 197 : int n;
13256 :
13257 197 : tree from, frompos, len, to, topos;
13258 197 : tree lenmask, oldbits, newbits, bitsize;
13259 197 : tree type, utype, above, mask1, mask2;
13260 :
13261 197 : if (loop)
13262 67 : lss = loop->ss;
13263 : else
13264 130 : lss = gfc_ss_terminator;
13265 :
13266 : actual = actual_args;
13267 1182 : for (n = 0; n < 5; n++, actual = actual->next)
13268 : {
13269 985 : arg[n] = actual->expr;
13270 985 : gfc_init_se (&argse[n], NULL);
13271 :
13272 985 : if (lss != gfc_ss_terminator)
13273 : {
13274 335 : gfc_copy_loopinfo_to_se (&argse[n], loop);
13275 : /* Find the ss for the expression if it is there. */
13276 335 : argse[n].ss = lss;
13277 335 : gfc_mark_ss_chain_used (lss, 1);
13278 : }
13279 :
13280 985 : gfc_conv_expr (&argse[n], arg[n]);
13281 :
13282 985 : if (loop)
13283 335 : lss = argse[n].ss;
13284 : }
13285 :
13286 197 : from = argse[0].expr;
13287 197 : frompos = argse[1].expr;
13288 197 : len = argse[2].expr;
13289 197 : to = argse[3].expr;
13290 197 : topos = argse[4].expr;
13291 :
13292 : /* The type of the result (TO). */
13293 197 : type = TREE_TYPE (to);
13294 197 : bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
13295 :
13296 : /* Optionally generate code for runtime argument check. */
13297 197 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
13298 : {
13299 18 : tree nbits, below, ccond;
13300 18 : tree fp = fold_convert (long_integer_type_node, frompos);
13301 18 : tree ln = fold_convert (long_integer_type_node, len);
13302 18 : tree tp = fold_convert (long_integer_type_node, topos);
13303 18 : below = fold_build2_loc (input_location, LT_EXPR,
13304 : logical_type_node, frompos,
13305 18 : build_int_cst (TREE_TYPE (frompos), 0));
13306 18 : above = fold_build2_loc (input_location, GT_EXPR,
13307 : logical_type_node, frompos,
13308 18 : fold_convert (TREE_TYPE (frompos), bitsize));
13309 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13310 : logical_type_node, below, above);
13311 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13312 18 : &arg[1]->where,
13313 : "FROMPOS argument (%ld) out of range 0:%d "
13314 : "in intrinsic MVBITS", fp, bitsize);
13315 18 : below = fold_build2_loc (input_location, LT_EXPR,
13316 : logical_type_node, len,
13317 18 : build_int_cst (TREE_TYPE (len), 0));
13318 18 : above = fold_build2_loc (input_location, GT_EXPR,
13319 : logical_type_node, len,
13320 18 : fold_convert (TREE_TYPE (len), bitsize));
13321 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13322 : logical_type_node, below, above);
13323 18 : gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
13324 18 : &arg[2]->where,
13325 : "LEN argument (%ld) out of range 0:%d "
13326 : "in intrinsic MVBITS", ln, bitsize);
13327 18 : below = fold_build2_loc (input_location, LT_EXPR,
13328 : logical_type_node, topos,
13329 18 : build_int_cst (TREE_TYPE (topos), 0));
13330 18 : above = fold_build2_loc (input_location, GT_EXPR,
13331 : logical_type_node, topos,
13332 18 : fold_convert (TREE_TYPE (topos), bitsize));
13333 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13334 : logical_type_node, below, above);
13335 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13336 18 : &arg[4]->where,
13337 : "TOPOS argument (%ld) out of range 0:%d "
13338 : "in intrinsic MVBITS", tp, bitsize);
13339 :
13340 : /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
13341 : integers. Additions below cannot overflow. */
13342 18 : nbits = fold_convert (long_integer_type_node, bitsize);
13343 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13344 : long_integer_type_node, fp, ln);
13345 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13346 : logical_type_node, above, nbits);
13347 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13348 : &arg[1]->where,
13349 : "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13350 : "in intrinsic MVBITS", fp, ln, bitsize);
13351 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13352 : long_integer_type_node, tp, ln);
13353 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13354 : logical_type_node, above, nbits);
13355 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13356 : &arg[4]->where,
13357 : "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13358 : "in intrinsic MVBITS", tp, ln, bitsize);
13359 : }
13360 :
13361 1182 : for (n = 0; n < 5; n++)
13362 : {
13363 985 : gfc_add_block_to_block (&se->pre, &argse[n].pre);
13364 985 : gfc_add_block_to_block (&se->post, &argse[n].post);
13365 : }
13366 :
13367 : /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
13368 197 : above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
13369 197 : len, fold_convert (TREE_TYPE (len), bitsize));
13370 197 : mask1 = build_int_cst (type, -1);
13371 197 : mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13372 : build_int_cst (type, 1), len);
13373 197 : mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
13374 : mask2, build_int_cst (type, 1));
13375 197 : lenmask = fold_build3_loc (input_location, COND_EXPR, type,
13376 : above, mask1, mask2);
13377 :
13378 : /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
13379 : * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
13380 : * not strictly necessary; artificial bits from rshift will be masked. */
13381 197 : utype = unsigned_type_for (type);
13382 197 : newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
13383 : fold_convert (utype, from), frompos);
13384 197 : newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
13385 : fold_convert (type, newbits), lenmask);
13386 197 : newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13387 : newbits, topos);
13388 :
13389 : /* oldbits = TO & (~(lenmask << TOPOS)). */
13390 197 : oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13391 : lenmask, topos);
13392 197 : oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
13393 197 : oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
13394 :
13395 : /* TO = newbits | oldbits. */
13396 197 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
13397 : oldbits, newbits);
13398 :
13399 : /* Return the assignment. */
13400 197 : se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
13401 : void_type_node, to, se->expr);
13402 197 : }
13403 :
13404 : /* Comes from trans-stmt.cc, but we don't want the whole header included. */
13405 : extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
13406 : tree *stat, tree *errmsg, tree *errmsg_len);
13407 :
13408 : static tree
13409 263 : conv_intrinsic_move_alloc (gfc_code *code)
13410 : {
13411 263 : stmtblock_t block;
13412 263 : gfc_expr *from_expr, *to_expr;
13413 263 : gfc_se from_se, to_se;
13414 263 : tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE;
13415 263 : bool coarray, from_is_class, from_is_scalar;
13416 263 : gfc_actual_arglist *arg = code->ext.actual;
13417 263 : sync_stat tmp_sync_stat = {nullptr, nullptr};
13418 :
13419 263 : gfc_start_block (&block);
13420 :
13421 263 : from_expr = arg->expr;
13422 263 : arg = arg->next;
13423 263 : to_expr = arg->expr;
13424 263 : arg = arg->next;
13425 :
13426 789 : while (arg)
13427 : {
13428 526 : if (arg->expr)
13429 : {
13430 0 : if (!strcmp ("stat", arg->name))
13431 0 : tmp_sync_stat.stat = arg->expr;
13432 0 : else if (!strcmp ("errmsg", arg->name))
13433 0 : tmp_sync_stat.errmsg = arg->expr;
13434 : }
13435 526 : arg = arg->next;
13436 : }
13437 :
13438 263 : gfc_init_se (&from_se, NULL);
13439 263 : gfc_init_se (&to_se, NULL);
13440 :
13441 263 : gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len);
13442 263 : if (stat != null_pointer_node)
13443 0 : fin_label = gfc_build_label_decl (NULL_TREE);
13444 :
13445 263 : gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
13446 263 : coarray = from_expr->corank != 0;
13447 :
13448 263 : from_is_class = from_expr->ts.type == BT_CLASS;
13449 263 : from_is_scalar = from_expr->rank == 0 && !coarray;
13450 263 : if (to_expr->ts.type == BT_CLASS || from_is_scalar)
13451 : {
13452 163 : from_se.want_pointer = 1;
13453 163 : if (from_is_scalar)
13454 115 : gfc_conv_expr (&from_se, from_expr);
13455 : else
13456 48 : gfc_conv_expr_descriptor (&from_se, from_expr);
13457 163 : if (from_is_class)
13458 64 : from_tree = gfc_class_data_get (from_se.expr);
13459 : else
13460 : {
13461 99 : gfc_symbol *vtab;
13462 99 : from_tree = from_se.expr;
13463 :
13464 99 : if (to_expr->ts.type == BT_CLASS)
13465 : {
13466 36 : vtab = gfc_find_vtab (&from_expr->ts);
13467 36 : gcc_assert (vtab);
13468 36 : from_se.expr = gfc_get_symbol_decl (vtab);
13469 : }
13470 : }
13471 163 : gfc_add_block_to_block (&block, &from_se.pre);
13472 :
13473 163 : to_se.want_pointer = 1;
13474 163 : if (to_expr->rank == 0)
13475 115 : gfc_conv_expr (&to_se, to_expr);
13476 : else
13477 48 : gfc_conv_expr_descriptor (&to_se, to_expr);
13478 163 : if (to_expr->ts.type == BT_CLASS)
13479 100 : to_tree = gfc_class_data_get (to_se.expr);
13480 : else
13481 63 : to_tree = to_se.expr;
13482 163 : gfc_add_block_to_block (&block, &to_se.pre);
13483 :
13484 : /* Deallocate "to". */
13485 163 : if (to_expr->rank == 0)
13486 : {
13487 115 : tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
13488 : true, to_expr, to_expr->ts,
13489 : NULL_TREE, false, true,
13490 : errmsg, errmsg_len);
13491 115 : gfc_add_expr_to_block (&block, tmp);
13492 : }
13493 :
13494 163 : if (from_is_scalar)
13495 : {
13496 : /* Assign (_data) pointers. */
13497 115 : gfc_add_modify_loc (input_location, &block, to_tree,
13498 115 : fold_convert (TREE_TYPE (to_tree), from_tree));
13499 :
13500 : /* Set "from" to NULL. */
13501 115 : gfc_add_modify_loc (input_location, &block, from_tree,
13502 115 : fold_convert (TREE_TYPE (from_tree),
13503 : null_pointer_node));
13504 :
13505 115 : gfc_add_block_to_block (&block, &from_se.post);
13506 : }
13507 163 : gfc_add_block_to_block (&block, &to_se.post);
13508 :
13509 : /* Set _vptr. */
13510 163 : if (to_expr->ts.type == BT_CLASS)
13511 : {
13512 100 : gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
13513 100 : if (from_is_class)
13514 64 : gfc_reset_vptr (&block, from_expr);
13515 100 : if (UNLIMITED_POLY (to_expr))
13516 : {
13517 20 : tree to_len = gfc_class_len_get (to_se.class_container);
13518 20 : tmp = from_expr->ts.type == BT_CHARACTER && from_se.string_length
13519 20 : ? from_se.string_length
13520 : : size_zero_node;
13521 20 : gfc_add_modify_loc (input_location, &block, to_len,
13522 20 : fold_convert (TREE_TYPE (to_len), tmp));
13523 : }
13524 : }
13525 :
13526 163 : if (from_is_scalar)
13527 : {
13528 115 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13529 : {
13530 6 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13531 6 : fold_convert (TREE_TYPE (to_se.string_length),
13532 : from_se.string_length));
13533 6 : if (from_expr->ts.deferred)
13534 6 : gfc_add_modify_loc (
13535 : input_location, &block, from_se.string_length,
13536 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13537 : }
13538 115 : if (UNLIMITED_POLY (from_expr))
13539 2 : gfc_reset_len (&block, from_expr);
13540 :
13541 115 : return gfc_finish_block (&block);
13542 : }
13543 :
13544 48 : gfc_init_se (&to_se, NULL);
13545 48 : gfc_init_se (&from_se, NULL);
13546 : }
13547 :
13548 : /* Deallocate "to". */
13549 148 : if (from_expr->rank == 0)
13550 : {
13551 4 : to_se.want_coarray = 1;
13552 4 : from_se.want_coarray = 1;
13553 : }
13554 148 : gfc_conv_expr_descriptor (&to_se, to_expr);
13555 148 : gfc_conv_expr_descriptor (&from_se, from_expr);
13556 148 : gfc_add_block_to_block (&block, &to_se.pre);
13557 148 : gfc_add_block_to_block (&block, &from_se.pre);
13558 :
13559 : /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
13560 : is an image control "statement", cf. IR F08/0040 in 12-006A. */
13561 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13562 : {
13563 6 : tree cond;
13564 :
13565 6 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13566 : fin_label, true, to_expr,
13567 : GFC_CAF_COARRAY_DEALLOCATE_ONLY,
13568 : NULL_TREE, NULL_TREE,
13569 : gfc_conv_descriptor_token (to_se.expr),
13570 : true);
13571 6 : gfc_add_expr_to_block (&block, tmp);
13572 :
13573 6 : tmp = gfc_conv_descriptor_data_get (to_se.expr);
13574 6 : cond = fold_build2_loc (input_location, EQ_EXPR,
13575 : logical_type_node, tmp,
13576 6 : fold_convert (TREE_TYPE (tmp),
13577 : null_pointer_node));
13578 6 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
13579 : 3, null_pointer_node, null_pointer_node,
13580 : integer_zero_node);
13581 :
13582 6 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
13583 : tmp, build_empty_stmt (input_location));
13584 6 : gfc_add_expr_to_block (&block, tmp);
13585 6 : }
13586 : else
13587 : {
13588 142 : if (to_expr->ts.type == BT_DERIVED
13589 25 : && to_expr->ts.u.derived->attr.alloc_comp)
13590 : {
13591 19 : tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
13592 : to_se.expr, to_expr->rank);
13593 19 : gfc_add_expr_to_block (&block, tmp);
13594 : }
13595 :
13596 142 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13597 : fin_label, true, to_expr,
13598 : GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
13599 : NULL_TREE, NULL_TREE, true);
13600 142 : gfc_add_expr_to_block (&block, tmp);
13601 : }
13602 :
13603 : /* Copy the array descriptor data. */
13604 148 : gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
13605 :
13606 : /* Set "from" to NULL. */
13607 148 : tmp = gfc_conv_descriptor_data_get (from_se.expr);
13608 148 : gfc_add_modify_loc (input_location, &block, tmp,
13609 148 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
13610 :
13611 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13612 : {
13613 : /* Copy the array descriptor data has overwritten the to-token and cleared
13614 : from.data. Now also clear the from.token. */
13615 6 : gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr),
13616 : null_pointer_node);
13617 : }
13618 :
13619 148 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13620 : {
13621 7 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13622 7 : fold_convert (TREE_TYPE (to_se.string_length),
13623 : from_se.string_length));
13624 7 : if (from_expr->ts.deferred)
13625 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
13626 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13627 : }
13628 148 : if (fin_label)
13629 0 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
13630 :
13631 148 : gfc_add_block_to_block (&block, &to_se.post);
13632 148 : gfc_add_block_to_block (&block, &from_se.post);
13633 :
13634 148 : return gfc_finish_block (&block);
13635 : }
13636 :
13637 :
13638 : tree
13639 6920 : gfc_conv_intrinsic_subroutine (gfc_code *code)
13640 : {
13641 6920 : tree res;
13642 :
13643 6920 : gcc_assert (code->resolved_isym);
13644 :
13645 6920 : switch (code->resolved_isym->id)
13646 : {
13647 263 : case GFC_ISYM_MOVE_ALLOC:
13648 263 : res = conv_intrinsic_move_alloc (code);
13649 263 : break;
13650 :
13651 14 : case GFC_ISYM_ATOMIC_CAS:
13652 14 : res = conv_intrinsic_atomic_cas (code);
13653 14 : break;
13654 :
13655 95 : case GFC_ISYM_ATOMIC_ADD:
13656 95 : case GFC_ISYM_ATOMIC_AND:
13657 95 : case GFC_ISYM_ATOMIC_DEF:
13658 95 : case GFC_ISYM_ATOMIC_OR:
13659 95 : case GFC_ISYM_ATOMIC_XOR:
13660 95 : case GFC_ISYM_ATOMIC_FETCH_ADD:
13661 95 : case GFC_ISYM_ATOMIC_FETCH_AND:
13662 95 : case GFC_ISYM_ATOMIC_FETCH_OR:
13663 95 : case GFC_ISYM_ATOMIC_FETCH_XOR:
13664 95 : res = conv_intrinsic_atomic_op (code);
13665 95 : break;
13666 :
13667 176 : case GFC_ISYM_ATOMIC_REF:
13668 176 : res = conv_intrinsic_atomic_ref (code);
13669 176 : break;
13670 :
13671 105 : case GFC_ISYM_EVENT_QUERY:
13672 105 : res = conv_intrinsic_event_query (code);
13673 105 : break;
13674 :
13675 3303 : case GFC_ISYM_C_F_POINTER:
13676 3303 : case GFC_ISYM_C_F_PROCPOINTER:
13677 3303 : res = conv_isocbinding_subroutine (code);
13678 3303 : break;
13679 :
13680 60 : case GFC_ISYM_C_F_STRPOINTER:
13681 60 : res = conv_isocbinding_subroutine_strpointer (code);
13682 60 : break;
13683 :
13684 360 : case GFC_ISYM_CAF_SEND:
13685 360 : res = conv_caf_send_to_remote (code);
13686 360 : break;
13687 :
13688 140 : case GFC_ISYM_CAF_SENDGET:
13689 140 : res = conv_caf_sendget (code);
13690 140 : break;
13691 :
13692 88 : case GFC_ISYM_CO_BROADCAST:
13693 88 : case GFC_ISYM_CO_MIN:
13694 88 : case GFC_ISYM_CO_MAX:
13695 88 : case GFC_ISYM_CO_REDUCE:
13696 88 : case GFC_ISYM_CO_SUM:
13697 88 : res = conv_co_collective (code);
13698 88 : break;
13699 :
13700 10 : case GFC_ISYM_FREE:
13701 10 : res = conv_intrinsic_free (code);
13702 10 : break;
13703 :
13704 55 : case GFC_ISYM_FSTAT:
13705 55 : case GFC_ISYM_LSTAT:
13706 55 : case GFC_ISYM_STAT:
13707 55 : res = conv_intrinsic_fstat_lstat_stat_sub (code);
13708 55 : break;
13709 :
13710 90 : case GFC_ISYM_RANDOM_INIT:
13711 90 : res = conv_intrinsic_random_init (code);
13712 90 : break;
13713 :
13714 15 : case GFC_ISYM_KILL:
13715 15 : res = conv_intrinsic_kill_sub (code);
13716 15 : break;
13717 :
13718 : case GFC_ISYM_MVBITS:
13719 : res = NULL_TREE;
13720 : break;
13721 :
13722 196 : case GFC_ISYM_SYSTEM_CLOCK:
13723 196 : res = conv_intrinsic_system_clock (code);
13724 196 : break;
13725 :
13726 102 : case GFC_ISYM_SPLIT:
13727 102 : res = conv_intrinsic_split (code);
13728 102 : break;
13729 :
13730 : default:
13731 : res = NULL_TREE;
13732 : break;
13733 : }
13734 :
13735 6920 : return res;
13736 : }
13737 :
13738 : #include "gt-fortran-trans-intrinsic.h"
|
