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 11472 : builtin_decl_for_precision (enum built_in_function base_built_in,
146 : int precision)
147 : {
148 11472 : enum built_in_function i = END_BUILTINS;
149 :
150 11472 : gfc_intrinsic_map_t *m;
151 491199 : for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
152 : ;
153 :
154 11472 : if (precision == TYPE_PRECISION (float_type_node))
155 5832 : 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 11348 : return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
170 : }
171 :
172 :
173 : tree
174 10433 : gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
175 : int kind)
176 : {
177 10433 : int i = gfc_validate_kind (BT_REAL, kind, false);
178 :
179 10433 : 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 9528 : return builtin_decl_for_precision (double_built_in,
191 9528 : 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 82899 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
202 : tree *argarray, int nargs)
203 : {
204 82899 : gfc_actual_arglist *actual;
205 82899 : gfc_expr *e;
206 82899 : gfc_intrinsic_arg *formal;
207 82899 : gfc_se argse;
208 82899 : int curr_arg;
209 :
210 82899 : formal = expr->value.function.isym->formal;
211 82899 : actual = expr->value.function.actual;
212 :
213 186642 : for (curr_arg = 0; curr_arg < nargs; curr_arg++,
214 63911 : actual = actual->next,
215 103743 : formal = formal ? formal->next : NULL)
216 : {
217 103743 : gcc_assert (actual);
218 103743 : e = actual->expr;
219 : /* Skip omitted optional arguments. */
220 103743 : if (!e)
221 : {
222 31 : --curr_arg;
223 31 : continue;
224 : }
225 :
226 : /* Evaluate the parameter. This will substitute scalarized
227 : references automatically. */
228 103712 : gfc_init_se (&argse, se);
229 :
230 103712 : if (e->ts.type == BT_CHARACTER)
231 : {
232 9642 : gfc_conv_expr (&argse, e);
233 9642 : gfc_conv_string_parameter (&argse);
234 9642 : argarray[curr_arg++] = argse.string_length;
235 9642 : gcc_assert (curr_arg < nargs);
236 : }
237 : else
238 94070 : 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 103712 : if (e->expr_type == EXPR_VARIABLE
243 52795 : && 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 103712 : gfc_add_block_to_block (&se->pre, &argse.pre);
249 103712 : gfc_add_block_to_block (&se->post, &argse.post);
250 103712 : argarray[curr_arg] = argse.expr;
251 : }
252 82899 : }
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 57507 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
259 : {
260 57507 : int n = 0;
261 57507 : gfc_actual_arglist *actual;
262 :
263 130293 : for (actual = expr->value.function.actual; actual; actual = actual->next)
264 : {
265 72786 : if (!actual->expr)
266 6399 : continue;
267 :
268 66387 : if (actual->expr->ts.type == BT_CHARACTER)
269 4551 : n += 2;
270 : else
271 61836 : n++;
272 : }
273 :
274 57507 : 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 41281 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
283 : {
284 41281 : tree type;
285 41281 : tree *args;
286 41281 : int nargs;
287 :
288 41281 : nargs = gfc_intrinsic_argument_list_length (expr);
289 41281 : 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 41281 : type = gfc_typenode_for_spec (&expr->ts);
295 41281 : gcc_assert (expr->value.function.actual->expr);
296 41281 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
297 :
298 : /* Conversion between character kinds involves a call to a library
299 : function. */
300 41281 : 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 41033 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
337 41033 : && 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 41033 : 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 678216 : define_quad_builtin (const char *name, tree type, bool is_const)
595 : {
596 678216 : tree fndecl;
597 678216 : fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
598 : type);
599 :
600 : /* Mark the decl as external. */
601 678216 : DECL_EXTERNAL (fndecl) = 1;
602 678216 : TREE_PUBLIC (fndecl) = 1;
603 :
604 : /* Mark it __attribute__((const)). */
605 678216 : TREE_READONLY (fndecl) = is_const;
606 :
607 678216 : rest_of_decl_compilation (fndecl, 1, 0);
608 :
609 678216 : 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 46631240 : add_simd_flag_for_built_in (tree fndecl)
617 : {
618 46631240 : if (gfc_vectorized_builtins == NULL
619 18633380 : || fndecl == NULL_TREE)
620 38577830 : return;
621 :
622 8053410 : const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
623 8053410 : int *clauses = gfc_vectorized_builtins->get (name);
624 8053410 : if (clauses)
625 : {
626 5052508 : for (unsigned i = 0; i < 3; i++)
627 3789381 : if (*clauses & (1 << i))
628 : {
629 1263132 : gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
630 1263132 : tree omp_clause = NULL_TREE;
631 1263132 : if (simd_type == SIMD_NONE)
632 : ; /* No SIMD clause. */
633 : else
634 : {
635 1263132 : omp_clause_code code
636 : = (simd_type == SIMD_INBRANCH
637 1263132 : ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
638 1263132 : omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
639 1263132 : omp_clause = build_tree_list (NULL_TREE, omp_clause);
640 : }
641 :
642 1263132 : DECL_ATTRIBUTES (fndecl)
643 2526264 : = tree_cons (get_identifier ("omp declare simd"), omp_clause,
644 1263132 : 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 79036 : gfc_adjust_builtins (void)
654 : {
655 79036 : gfc_intrinsic_map_t *m;
656 4742160 : for (m = gfc_intrinsic_map;
657 4742160 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
658 : {
659 4663124 : add_simd_flag_for_built_in (m->real4_decl);
660 4663124 : add_simd_flag_for_built_in (m->complex4_decl);
661 4663124 : add_simd_flag_for_built_in (m->real8_decl);
662 4663124 : add_simd_flag_for_built_in (m->complex8_decl);
663 4663124 : add_simd_flag_for_built_in (m->real10_decl);
664 4663124 : add_simd_flag_for_built_in (m->complex10_decl);
665 4663124 : add_simd_flag_for_built_in (m->real16_decl);
666 4663124 : add_simd_flag_for_built_in (m->complex16_decl);
667 4663124 : add_simd_flag_for_built_in (m->real16_decl);
668 4663124 : add_simd_flag_for_built_in (m->complex16_decl);
669 : }
670 :
671 : /* Release all strings. */
672 79036 : if (gfc_vectorized_builtins != NULL)
673 : {
674 1705219 : for (hash_map<nofree_string_hash, int>::iterator it
675 31582 : = gfc_vectorized_builtins->begin ();
676 1736801 : it != gfc_vectorized_builtins->end (); ++it)
677 1705219 : free (const_cast<char *> ((*it).first));
678 :
679 63164 : delete gfc_vectorized_builtins;
680 31582 : gfc_vectorized_builtins = NULL;
681 : }
682 79036 : }
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 32296 : gfc_build_intrinsic_lib_fndecls (void)
689 : {
690 32296 : gfc_intrinsic_map_t *m;
691 32296 : tree quad_decls[END_BUILTINS + 1];
692 :
693 32296 : 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 32296 : tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
700 32296 : tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
701 :
702 32296 : memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
703 :
704 32296 : type = gfc_float128_type_node;
705 32296 : complex_type = gfc_complex_float128_type_node;
706 : /* type (*) (type) */
707 32296 : func_1 = build_function_type_list (type, type, NULL_TREE);
708 : /* int (*) (type) */
709 32296 : func_iround = build_function_type_list (integer_type_node,
710 : type, NULL_TREE);
711 : /* long (*) (type) */
712 32296 : func_lround = build_function_type_list (long_integer_type_node,
713 : type, NULL_TREE);
714 : /* long long (*) (type) */
715 32296 : func_llround = build_function_type_list (long_long_integer_type_node,
716 : type, NULL_TREE);
717 : /* type (*) (type, type) */
718 32296 : func_2 = build_function_type_list (type, type, type, NULL_TREE);
719 : /* type (*) (type, type, type) */
720 32296 : func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
721 : /* type (*) (type, &int) */
722 32296 : func_frexp
723 32296 : = build_function_type_list (type,
724 : type,
725 : build_pointer_type (integer_type_node),
726 : NULL_TREE);
727 : /* type (*) (type, int) */
728 32296 : func_scalbn = build_function_type_list (type,
729 : type, integer_type_node, NULL_TREE);
730 : /* type (*) (complex type) */
731 32296 : func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
732 : /* complex type (*) (complex type, complex type) */
733 32296 : func_cpow
734 32296 : = 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 32296 : quad_decls[BUILT_IN_SQRT]
762 32296 : = define_quad_builtin (gfc_real16_use_iec_60559
763 : ? "sqrtf128" : "sqrtq", func_1, true);
764 : }
765 :
766 : /* Add GCC builtin functions. */
767 1937760 : for (m = gfc_intrinsic_map;
768 1937760 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
769 : {
770 1905464 : if (m->float_built_in != END_BUILTINS)
771 1776280 : m->real4_decl = builtin_decl_explicit (m->float_built_in);
772 1905464 : if (m->complex_float_built_in != END_BUILTINS)
773 516736 : m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
774 1905464 : if (m->double_built_in != END_BUILTINS)
775 1776280 : m->real8_decl = builtin_decl_explicit (m->double_built_in);
776 1905464 : if (m->complex_double_built_in != END_BUILTINS)
777 516736 : m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
778 :
779 : /* If real(kind=10) exists, it is always long double. */
780 1905464 : if (m->long_double_built_in != END_BUILTINS)
781 1776280 : m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
782 1905464 : if (m->complex_long_double_built_in != END_BUILTINS)
783 516736 : m->complex10_decl
784 516736 : = builtin_decl_explicit (m->complex_long_double_built_in);
785 :
786 1905464 : 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 1905464 : 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 678216 : m->real16_decl = quad_decls[m->double_built_in];
800 : }
801 1227248 : 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 32296 : }
808 :
809 :
810 : /* Create a fndecl for a simple intrinsic library function. */
811 :
812 : static tree
813 4547 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
814 : {
815 4547 : tree type;
816 4547 : vec<tree, va_gc> *argtypes;
817 4547 : tree fndecl;
818 4547 : gfc_actual_arglist *actual;
819 4547 : tree *pdecl;
820 4547 : gfc_typespec *ts;
821 4547 : char name[GFC_MAX_SYMBOL_LEN + 3];
822 :
823 4547 : ts = &expr->ts;
824 4547 : if (ts->type == BT_REAL)
825 : {
826 3685 : 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 600 : case 10:
835 600 : pdecl = &m->real10_decl;
836 600 : break;
837 470 : case 16:
838 470 : pdecl = &m->real16_decl;
839 470 : 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 4547 : if (*pdecl)
870 : return *pdecl;
871 :
872 409 : if (m->libm_name)
873 : {
874 178 : int n = gfc_validate_kind (BT_REAL, ts->kind, false);
875 178 : 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 178 : 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 178 : 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 178 : else if (gfc_real_kinds[n].c_float128)
885 178 : snprintf (name, sizeof (name), "%s%s%s",
886 178 : ts->type == BT_COMPLEX ? "c" : "", m->name,
887 178 : 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 409 : argtypes = NULL;
899 838 : for (actual = expr->value.function.actual; actual; actual = actual->next)
900 : {
901 429 : type = gfc_typenode_for_spec (&actual->expr->ts);
902 429 : vec_safe_push (argtypes, type);
903 : }
904 1227 : type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
905 409 : fndecl = build_decl (input_location,
906 : FUNCTION_DECL, get_identifier (name), type);
907 :
908 : /* Mark the decl as external. */
909 409 : DECL_EXTERNAL (fndecl) = 1;
910 409 : TREE_PUBLIC (fndecl) = 1;
911 :
912 : /* Mark it __attribute__((const)), if possible. */
913 409 : TREE_READONLY (fndecl) = m->is_constant;
914 :
915 409 : rest_of_decl_compilation (fndecl, 1, 0);
916 :
917 409 : (*pdecl) = fndecl;
918 409 : return fndecl;
919 : }
920 :
921 :
922 : /* Convert an intrinsic function into an external or builtin call. */
923 :
924 : static void
925 3929 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
926 : {
927 3929 : gfc_intrinsic_map_t *m;
928 3929 : tree fndecl;
929 3929 : tree rettype;
930 3929 : tree *args;
931 3929 : unsigned int num_args;
932 3929 : gfc_isym_id id;
933 :
934 3929 : id = expr->value.function.isym->id;
935 : /* Find the entry for this function. */
936 82799 : for (m = gfc_intrinsic_map;
937 82799 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
938 : {
939 82799 : if (id == m->id)
940 : break;
941 : }
942 :
943 3929 : 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 3929 : num_args = gfc_intrinsic_argument_list_length (expr);
951 3929 : args = XALLOCAVEC (tree, num_args);
952 :
953 3929 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
954 3929 : fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
955 3929 : rettype = TREE_TYPE (TREE_TYPE (fndecl));
956 :
957 3929 : fndecl = build_addr (fndecl);
958 3929 : se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
959 3929 : }
960 :
961 :
962 : /* If bounds-checking is enabled, create code to verify at runtime that the
963 : string lengths for both expressions are the same (needed for e.g. MERGE).
964 : If bounds-checking is not enabled, does nothing. */
965 :
966 : void
967 1556 : gfc_trans_same_strlen_check (const char* intr_name, locus* where,
968 : tree a, tree b, stmtblock_t* target)
969 : {
970 1556 : tree cond;
971 1556 : tree name;
972 :
973 : /* If bounds-checking is disabled, do nothing. */
974 1556 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
975 : return;
976 :
977 : /* Compare the two string lengths. */
978 94 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
979 :
980 : /* Output the runtime-check. */
981 94 : name = gfc_build_cstring_const (intr_name);
982 94 : name = gfc_build_addr_expr (pchar_type_node, name);
983 94 : gfc_trans_runtime_check (true, false, cond, target, where,
984 : "Unequal character lengths (%ld/%ld) in %s",
985 : fold_convert (long_integer_type_node, a),
986 : fold_convert (long_integer_type_node, b), name);
987 : }
988 :
989 :
990 : /* The EXPONENT(X) intrinsic function is translated into
991 : int ret;
992 : return isfinite(X) ? (frexp (X, &ret) , ret) : huge
993 : so that if X is a NaN or infinity, the result is HUGE(0).
994 : */
995 :
996 : static void
997 228 : gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
998 : {
999 228 : tree arg, type, res, tmp, frexp, cond, huge;
1000 228 : int i;
1001 :
1002 456 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
1003 228 : expr->value.function.actual->expr->ts.kind);
1004 :
1005 228 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1006 228 : arg = gfc_evaluate_now (arg, &se->pre);
1007 :
1008 228 : i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1009 228 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1010 228 : cond = build_call_expr_loc (input_location,
1011 : builtin_decl_explicit (BUILT_IN_ISFINITE),
1012 : 1, arg);
1013 :
1014 228 : res = gfc_create_var (integer_type_node, NULL);
1015 228 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1016 : gfc_build_addr_expr (NULL_TREE, res));
1017 228 : tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
1018 : tmp, res);
1019 228 : se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1020 : cond, tmp, huge);
1021 :
1022 228 : type = gfc_typenode_for_spec (&expr->ts);
1023 228 : se->expr = fold_convert (type, se->expr);
1024 228 : }
1025 :
1026 :
1027 : static int caf_call_cnt = 0;
1028 :
1029 : static tree
1030 1510 : conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
1031 : gfc_expr *hash)
1032 : {
1033 1510 : char *name;
1034 1510 : gfc_se argse;
1035 1510 : gfc_expr func_index;
1036 1510 : gfc_symtree *index_st;
1037 1510 : tree func_index_tree;
1038 1510 : stmtblock_t blk;
1039 :
1040 : /* Need to get namespace where static variables are possible. */
1041 1510 : while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
1042 0 : ns = ns->parent;
1043 1510 : gcc_assert (ns);
1044 :
1045 1510 : name = xasprintf (pat, caf_call_cnt);
1046 1510 : gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
1047 1510 : free (name);
1048 :
1049 1510 : index_st->n.sym->attr.flavor = FL_VARIABLE;
1050 1510 : index_st->n.sym->attr.save = SAVE_EXPLICIT;
1051 1510 : index_st->n.sym->value
1052 1510 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1053 : &gfc_current_locus);
1054 1510 : mpz_set_si (index_st->n.sym->value->value.integer, -1);
1055 1510 : index_st->n.sym->ts.type = BT_INTEGER;
1056 1510 : index_st->n.sym->ts.kind = gfc_default_integer_kind;
1057 1510 : gfc_set_sym_referenced (index_st->n.sym);
1058 1510 : memset (&func_index, 0, sizeof (gfc_expr));
1059 1510 : gfc_clear_ts (&func_index.ts);
1060 1510 : func_index.expr_type = EXPR_VARIABLE;
1061 1510 : func_index.symtree = index_st;
1062 1510 : func_index.ts = index_st->n.sym->ts;
1063 1510 : gfc_commit_symbol (index_st->n.sym);
1064 :
1065 1510 : gfc_init_se (&argse, NULL);
1066 1510 : gfc_conv_expr (&argse, &func_index);
1067 1510 : gfc_add_block_to_block (block, &argse.pre);
1068 1510 : func_index_tree = argse.expr;
1069 :
1070 1510 : gfc_init_se (&argse, NULL);
1071 1510 : gfc_conv_expr (&argse, hash);
1072 :
1073 1510 : gfc_init_block (&blk);
1074 1510 : gfc_add_modify (&blk, func_index_tree,
1075 : build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1,
1076 : argse.expr));
1077 1510 : 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 1510 : return func_index_tree;
1086 : }
1087 :
1088 : static tree
1089 1510 : conv_caf_add_call_data (stmtblock_t *blk, gfc_namespace *ns, const char *pat,
1090 : gfc_symbol *data_sym, tree *data_size)
1091 : {
1092 1510 : char *name;
1093 1510 : gfc_symtree *data_st;
1094 1510 : gfc_constructor *con;
1095 1510 : gfc_expr data, data_init;
1096 1510 : gfc_se argse;
1097 1510 : tree data_tree;
1098 :
1099 1510 : memset (&data, 0, sizeof (gfc_expr));
1100 1510 : gfc_clear_ts (&data.ts);
1101 1510 : data.expr_type = EXPR_VARIABLE;
1102 1510 : name = xasprintf (pat, caf_call_cnt);
1103 1510 : gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false));
1104 1510 : free (name);
1105 1510 : data_st->n.sym->attr.flavor = FL_VARIABLE;
1106 1510 : data_st->n.sym->ts = data_sym->ts;
1107 1510 : data.symtree = data_st;
1108 1510 : gfc_set_sym_referenced (data.symtree->n.sym);
1109 1510 : data.ts = data_st->n.sym->ts;
1110 1510 : gfc_commit_symbol (data_st->n.sym);
1111 :
1112 1510 : memset (&data_init, 0, sizeof (gfc_expr));
1113 1510 : gfc_clear_ts (&data_init.ts);
1114 1510 : data_init.expr_type = EXPR_STRUCTURE;
1115 1510 : data_init.ts = data.ts;
1116 1826 : 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 1510 : 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 1400 : data_tree = build_zero_cst (pvoid_type_node);
1140 1400 : *data_size = build_zero_cst (size_type_node);
1141 : }
1142 :
1143 1510 : 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 243 : gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
1374 : {
1375 243 : gfc_expr *caf_expr, *hash, *present_fn;
1376 243 : gfc_symbol *add_data_sym;
1377 243 : tree fn_index, add_data_tree, add_data_size, caf_decl, image_index, token;
1378 :
1379 243 : gcc_assert (e->expr_type == EXPR_FUNCTION
1380 : && e->value.function.isym->id
1381 : == GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE);
1382 243 : caf_expr = e->value.function.actual->expr;
1383 243 : hash = e->value.function.actual->next->expr;
1384 243 : present_fn = e->value.function.actual->next->next->expr;
1385 243 : add_data_sym = present_fn->symtree->n.sym->formal->sym;
1386 :
1387 243 : fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns,
1388 : "__caf_present_on_remote_fn_index_%d", hash);
1389 243 : 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 243 : ++caf_call_cnt;
1393 :
1394 243 : caf_decl = gfc_get_tree_for_caf_expr (caf_expr);
1395 243 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1396 4 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1397 :
1398 243 : image_index = gfc_caf_get_image_index (&se->pre, caf_expr, caf_decl);
1399 243 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, caf_expr);
1400 :
1401 243 : se->expr
1402 243 : = 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 243 : }
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 : /* F2018:5.4.7(5): a subobject of a coarray is a coarray with the codimensions
1824 : of that coarray. Return a copy of E cut back to the reference carrying the
1825 : codimensions, so that the descriptor built for it holds the cobounds. */
1826 :
1827 : static gfc_expr *
1828 1324 : strip_subobject_of_coarray (gfc_expr *e)
1829 : {
1830 1324 : gfc_expr *coarray;
1831 1324 : gfc_ref *ref;
1832 1324 : gfc_typespec ts;
1833 :
1834 1324 : ts = e->symtree->n.sym->ts;
1835 1481 : for (ref = e->ref; ref; ref = ref->next)
1836 : {
1837 1481 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
1838 : break;
1839 157 : if (ref->type == REF_COMPONENT)
1840 157 : ts = ref->u.c.component->ts;
1841 : }
1842 :
1843 1324 : coarray = gfc_copy_expr (e);
1844 1324 : if (!ref || !ref->next)
1845 : return coarray;
1846 :
1847 82 : for (ref = coarray->ref; ref; ref = ref->next)
1848 82 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
1849 : break;
1850 :
1851 64 : gfc_free_ref_list (ref->next);
1852 64 : ref->next = NULL;
1853 64 : coarray->ts = ts;
1854 64 : gfc_expression_rank (coarray);
1855 :
1856 64 : return coarray;
1857 : }
1858 :
1859 :
1860 : static void
1861 1366 : trans_this_image (gfc_se * se, gfc_expr *expr)
1862 : {
1863 1366 : stmtblock_t loop;
1864 1366 : tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound,
1865 : ubound, extent, ml, team;
1866 1366 : gfc_expr *coarray;
1867 1366 : gfc_se argse;
1868 1366 : int rank, corank;
1869 :
1870 : /* The case -fcoarray=single is handled elsewhere. */
1871 1366 : gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
1872 :
1873 : /* Translate team, if present. */
1874 1366 : if (expr->value.function.actual->next->next->expr)
1875 : {
1876 18 : gfc_init_se (&argse, NULL);
1877 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr);
1878 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
1879 18 : gfc_add_block_to_block (&se->post, &argse.post);
1880 18 : team = fold_convert (pvoid_type_node, argse.expr);
1881 : }
1882 : else
1883 1348 : team = null_pointer_node;
1884 :
1885 : /* Argument-free version: THIS_IMAGE(). */
1886 1366 : if (expr->value.function.actual->expr == NULL)
1887 : {
1888 1036 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
1889 : team);
1890 1036 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1891 : tmp);
1892 1048 : return;
1893 : }
1894 :
1895 : /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
1896 :
1897 330 : type = gfc_get_int_type (gfc_default_integer_kind);
1898 :
1899 330 : coarray = strip_subobject_of_coarray (expr->value.function.actual->expr);
1900 330 : corank = coarray->corank;
1901 330 : rank = coarray->rank;
1902 :
1903 : /* Obtain the descriptor of the COARRAY. */
1904 330 : gfc_init_se (&argse, NULL);
1905 330 : argse.want_coarray = 1;
1906 330 : gfc_conv_expr_descriptor (&argse, coarray);
1907 330 : gfc_add_block_to_block (&se->pre, &argse.pre);
1908 330 : gfc_add_block_to_block (&se->post, &argse.post);
1909 330 : desc = argse.expr;
1910 330 : gfc_free_expr (coarray);
1911 :
1912 330 : if (se->ss)
1913 : {
1914 : /* Create an implicit second parameter from the loop variable. */
1915 82 : gcc_assert (!expr->value.function.actual->next->expr);
1916 82 : gcc_assert (corank > 0);
1917 82 : gcc_assert (se->loop->dimen == 1);
1918 82 : gcc_assert (se->ss->info->expr == expr);
1919 :
1920 82 : dim_arg = fold_convert_loc (input_location, gfc_array_dim_rank_type,
1921 : se->loop->loopvar[0]);
1922 82 : dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1923 : gfc_array_dim_rank_type, dim_arg,
1924 : gfc_rank_cst[1]);
1925 82 : gfc_advance_se_ss_chain (se);
1926 : }
1927 : else
1928 : {
1929 : /* Use the passed DIM= argument. */
1930 248 : gcc_assert (expr->value.function.actual->next->expr);
1931 248 : gfc_init_se (&argse, NULL);
1932 248 : gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1933 : gfc_array_dim_rank_type);
1934 248 : gfc_add_block_to_block (&se->pre, &argse.pre);
1935 248 : dim_arg = argse.expr;
1936 :
1937 248 : if (INTEGER_CST_P (dim_arg))
1938 : {
1939 132 : if (wi::ltu_p (wi::to_wide (dim_arg), 1)
1940 264 : || wi::gtu_p (wi::to_wide (dim_arg),
1941 132 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
1942 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
1943 0 : "dimension index", expr->value.function.isym->name,
1944 : &expr->where);
1945 : }
1946 116 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1947 : {
1948 0 : dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1949 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1950 : dim_arg, gfc_rank_cst[1]);
1951 0 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1952 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1953 : dim_arg, tmp);
1954 0 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1955 : logical_type_node, cond, tmp);
1956 0 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1957 : gfc_msg_fault);
1958 : }
1959 : }
1960 :
1961 : /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1962 : one always has a dim_arg argument.
1963 :
1964 : m = this_image() - 1
1965 : if (corank == 1)
1966 : {
1967 : sub(1) = m + lcobound(corank)
1968 : return;
1969 : }
1970 : i = rank
1971 : min_var = min (rank + corank - 2, rank + dim_arg - 1)
1972 : for (;;)
1973 : {
1974 : extent = gfc_extent(i)
1975 : ml = m
1976 : m = m/extent
1977 : if (i >= min_var)
1978 : goto exit_label
1979 : i++
1980 : }
1981 : exit_label:
1982 : sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1983 : : m + lcobound(corank)
1984 : */
1985 :
1986 : /* this_image () - 1. */
1987 330 : tmp
1988 330 : = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team);
1989 330 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
1990 : fold_convert (type, tmp), build_int_cst (type, 1));
1991 330 : if (corank == 1)
1992 : {
1993 : /* sub(1) = m + lcobound(corank). */
1994 12 : lbound = gfc_conv_descriptor_lbound_get (desc,
1995 12 : build_int_cst (TREE_TYPE (gfc_array_index_type),
1996 12 : corank+rank-1));
1997 12 : lbound = fold_convert (type, lbound);
1998 12 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1999 :
2000 12 : se->expr = tmp;
2001 12 : return;
2002 : }
2003 :
2004 318 : m = gfc_create_var (type, NULL);
2005 318 : ml = gfc_create_var (type, NULL);
2006 318 : loop_var = gfc_create_var (gfc_array_dim_rank_type, NULL);
2007 318 : min_var = gfc_create_var (gfc_array_dim_rank_type, NULL);
2008 :
2009 : /* m = this_image () - 1. */
2010 318 : gfc_add_modify (&se->pre, m, tmp);
2011 :
2012 : /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2013 318 : tmp = fold_build2_loc (input_location, PLUS_EXPR, signed_char_type_node,
2014 : fold_convert_loc (input_location,
2015 : signed_char_type_node, dim_arg),
2016 318 : build_int_cst (signed_char_type_node, rank - 1));
2017 318 : tmp = fold_convert_loc (input_location, gfc_array_dim_rank_type, tmp);
2018 636 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_dim_rank_type,
2019 318 : gfc_rank_cst[rank + corank - 2], tmp);
2020 318 : gfc_add_modify (&se->pre, min_var, tmp);
2021 :
2022 : /* i = rank. */
2023 318 : tmp = gfc_rank_cst[rank];
2024 318 : gfc_add_modify (&se->pre, loop_var, tmp);
2025 :
2026 318 : exit_label = gfc_build_label_decl (NULL_TREE);
2027 318 : TREE_USED (exit_label) = 1;
2028 :
2029 : /* Loop body. */
2030 318 : gfc_init_block (&loop);
2031 :
2032 : /* ml = m. */
2033 318 : gfc_add_modify (&loop, ml, m);
2034 :
2035 : /* extent = ... */
2036 318 : lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
2037 318 : ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
2038 318 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2039 318 : extent = fold_convert (type, extent);
2040 :
2041 : /* m = m/extent. */
2042 318 : gfc_add_modify (&loop, m,
2043 : fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2044 : m, extent));
2045 :
2046 : /* Exit condition: if (i >= min_var) goto exit_label. */
2047 318 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2048 : min_var);
2049 318 : tmp = build1_v (GOTO_EXPR, exit_label);
2050 318 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2051 : build_empty_stmt (input_location));
2052 318 : gfc_add_expr_to_block (&loop, tmp);
2053 :
2054 : /* Increment loop variable: i++. */
2055 318 : gfc_add_modify (&loop, loop_var,
2056 : fold_build2_loc (input_location, PLUS_EXPR,
2057 318 : TREE_TYPE (loop_var), loop_var,
2058 : gfc_rank_cst[1]));
2059 :
2060 : /* Making the loop... actually loop! */
2061 318 : tmp = gfc_finish_block (&loop);
2062 318 : tmp = build1_v (LOOP_EXPR, tmp);
2063 318 : gfc_add_expr_to_block (&se->pre, tmp);
2064 :
2065 : /* The exit label. */
2066 318 : tmp = build1_v (LABEL_EXPR, exit_label);
2067 318 : gfc_add_expr_to_block (&se->pre, tmp);
2068 :
2069 : /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2070 : : m + lcobound(corank) */
2071 :
2072 318 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2073 318 : build_int_cst (TREE_TYPE (dim_arg), corank));
2074 :
2075 636 : lbound = gfc_conv_descriptor_lbound_get (desc,
2076 : fold_build2_loc (input_location, PLUS_EXPR,
2077 318 : TREE_TYPE (dim_arg), dim_arg,
2078 318 : build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2079 318 : lbound = fold_convert (type, lbound);
2080 :
2081 318 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2082 : fold_build2_loc (input_location, MULT_EXPR, type,
2083 : m, extent));
2084 318 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2085 :
2086 318 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2087 : fold_build2_loc (input_location, PLUS_EXPR, type,
2088 : m, lbound));
2089 : }
2090 :
2091 :
2092 : /* Convert a call to image_status. */
2093 :
2094 : static void
2095 32 : conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2096 : {
2097 32 : unsigned int num_args;
2098 32 : tree *args, tmp;
2099 :
2100 32 : num_args = gfc_intrinsic_argument_list_length (expr);
2101 32 : args = XALLOCAVEC (tree, num_args);
2102 32 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2103 : /* In args[0] the number of the image the status is desired for has to be
2104 : given. */
2105 :
2106 32 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2107 : {
2108 1 : tree arg;
2109 1 : arg = gfc_evaluate_now (args[0], &se->pre);
2110 1 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2111 : fold_convert (integer_type_node, arg),
2112 : integer_one_node);
2113 1 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2114 : tmp, integer_zero_node,
2115 : build_int_cst (integer_type_node,
2116 : GFC_STAT_STOPPED_IMAGE));
2117 : }
2118 31 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2119 : /* The team is optional and therefore needs to be a pointer to the opaque
2120 : pointer. */
2121 35 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2122 : args[0],
2123 : num_args < 2
2124 : ? null_pointer_node
2125 4 : : gfc_build_addr_expr (NULL_TREE, args[1]));
2126 : else
2127 0 : gcc_unreachable ();
2128 :
2129 32 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2130 32 : }
2131 :
2132 : static void
2133 49 : conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2134 : {
2135 49 : unsigned int num_args;
2136 :
2137 49 : tree *args, tmp;
2138 :
2139 49 : num_args = gfc_intrinsic_argument_list_length (expr);
2140 49 : args = XALLOCAVEC (tree, num_args);
2141 49 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2142 :
2143 49 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2144 : /* Only the initial team exists, and its team number is -1. */
2145 26 : tmp = build_int_cst (integer_type_node, -1);
2146 23 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2147 23 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2148 23 : expr->value.function.actual->expr
2149 : ? args[0] : null_pointer_node);
2150 : else
2151 0 : gcc_unreachable ();
2152 :
2153 49 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2154 49 : }
2155 :
2156 :
2157 : static void
2158 257 : trans_image_index (gfc_se * se, gfc_expr *expr)
2159 : {
2160 257 : tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp,
2161 257 : invalid_bound, team = null_pointer_node, team_number = null_pointer_node;
2162 257 : gfc_expr *coarray;
2163 257 : gfc_se argse, subse;
2164 257 : int rank, corank, codim;
2165 :
2166 257 : type = gfc_get_int_type (gfc_default_integer_kind);
2167 :
2168 257 : coarray = strip_subobject_of_coarray (expr->value.function.actual->expr);
2169 257 : corank = coarray->corank;
2170 257 : rank = coarray->rank;
2171 :
2172 : /* Obtain the descriptor of the COARRAY. */
2173 257 : gfc_init_se (&argse, NULL);
2174 257 : argse.want_coarray = 1;
2175 257 : gfc_conv_expr_descriptor (&argse, coarray);
2176 257 : gfc_add_block_to_block (&se->pre, &argse.pre);
2177 257 : gfc_add_block_to_block (&se->post, &argse.post);
2178 257 : desc = argse.expr;
2179 257 : gfc_free_expr (coarray);
2180 :
2181 : /* Obtain a handle to the SUB argument. */
2182 257 : gfc_init_se (&subse, NULL);
2183 257 : gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2184 257 : gfc_add_block_to_block (&se->pre, &subse.pre);
2185 257 : gfc_add_block_to_block (&se->post, &subse.post);
2186 257 : subdesc = build_fold_indirect_ref_loc (input_location,
2187 : gfc_conv_descriptor_data_get (subse.expr));
2188 :
2189 257 : if (expr->value.function.actual->next->next->expr)
2190 : {
2191 27 : gfc_init_se (&argse, NULL);
2192 27 : gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr);
2193 27 : team = argse.expr;
2194 27 : gfc_add_block_to_block (&se->pre, &argse.pre);
2195 27 : gfc_add_block_to_block (&se->post, &argse.post);
2196 : }
2197 230 : else if (expr->value.function.actual->next->next->next->expr)
2198 : {
2199 25 : gfc_init_se (&argse, NULL);
2200 25 : gfc_conv_expr_val (&argse,
2201 25 : expr->value.function.actual->next->next->next->expr);
2202 25 : team_number = gfc_build_addr_expr (
2203 : NULL_TREE,
2204 : gfc_trans_force_lval (&argse.pre,
2205 : fold_convert (integer_type_node, argse.expr)));
2206 25 : gfc_add_block_to_block (&se->pre, &argse.pre);
2207 25 : gfc_add_block_to_block (&se->post, &argse.post);
2208 : }
2209 :
2210 : /* Fortran 2008 does not require that the values remain in the cobounds,
2211 : thus we need explicitly check this - and return 0 if they are exceeded. */
2212 :
2213 257 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2214 257 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2215 257 : invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2216 : fold_convert (gfc_array_index_type, tmp),
2217 : lbound);
2218 :
2219 513 : for (codim = corank + rank - 2; codim >= rank; codim--)
2220 : {
2221 256 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2222 256 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2223 256 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2224 256 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2225 : fold_convert (gfc_array_index_type, tmp),
2226 : lbound);
2227 256 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2228 : logical_type_node, invalid_bound, cond);
2229 256 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2230 : fold_convert (gfc_array_index_type, tmp),
2231 : ubound);
2232 256 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2233 : logical_type_node, invalid_bound, cond);
2234 : }
2235 :
2236 257 : invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2237 :
2238 : /* See Fortran 2008, C.10 for the following algorithm. */
2239 :
2240 : /* coindex = sub(corank) - lcobound(n). */
2241 257 : coindex = fold_convert (gfc_array_index_type,
2242 : gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2243 : NULL));
2244 257 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2245 257 : coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2246 : fold_convert (gfc_array_index_type, coindex),
2247 : lbound);
2248 :
2249 770 : for (codim = corank + rank - 2; codim >= rank; codim--)
2250 : {
2251 256 : tree extent, ubound;
2252 :
2253 : /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2254 256 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2255 256 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2256 256 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2257 :
2258 : /* coindex *= extent. */
2259 256 : coindex = fold_build2_loc (input_location, MULT_EXPR,
2260 : gfc_array_index_type, coindex, extent);
2261 :
2262 : /* coindex += sub(codim). */
2263 256 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2264 256 : coindex = fold_build2_loc (input_location, PLUS_EXPR,
2265 : gfc_array_index_type, coindex,
2266 : fold_convert (gfc_array_index_type, tmp));
2267 :
2268 : /* coindex -= lbound(codim). */
2269 256 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2270 256 : coindex = fold_build2_loc (input_location, MINUS_EXPR,
2271 : gfc_array_index_type, coindex, lbound);
2272 : }
2273 :
2274 257 : coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2275 : fold_convert(type, coindex),
2276 : build_int_cst (type, 1));
2277 :
2278 : /* Return 0 if "coindex" exceeds num_images(). */
2279 :
2280 257 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2281 126 : num_images = build_int_cst (type, 1);
2282 : else
2283 : {
2284 131 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2285 : team, team_number);
2286 131 : num_images = fold_convert (type, tmp);
2287 : }
2288 :
2289 257 : tmp = gfc_create_var (type, NULL);
2290 257 : gfc_add_modify (&se->pre, tmp, coindex);
2291 :
2292 257 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2293 : num_images);
2294 257 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2295 : cond,
2296 : fold_convert (logical_type_node, invalid_bound));
2297 257 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2298 : build_int_cst (type, 0), tmp);
2299 257 : }
2300 :
2301 : static void
2302 890 : trans_num_images (gfc_se * se, gfc_expr *expr)
2303 : {
2304 890 : tree tmp, team = null_pointer_node, team_number = null_pointer_node;
2305 890 : gfc_se argse;
2306 :
2307 890 : if (expr->value.function.actual->expr)
2308 : {
2309 18 : gfc_init_se (&argse, NULL);
2310 18 : gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2311 18 : team = argse.expr;
2312 18 : gfc_add_block_to_block (&se->pre, &argse.pre);
2313 18 : gfc_add_block_to_block (&se->post, &argse.post);
2314 : }
2315 872 : else if (expr->value.function.actual->next->expr)
2316 : {
2317 24 : gfc_init_se (&argse, NULL);
2318 24 : gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
2319 24 : team_number = gfc_build_addr_expr (
2320 : NULL_TREE,
2321 : gfc_trans_force_lval (&argse.pre,
2322 : fold_convert (integer_type_node, argse.expr)));
2323 24 : gfc_add_block_to_block (&se->pre, &argse.pre);
2324 24 : gfc_add_block_to_block (&se->post, &argse.post);
2325 : }
2326 :
2327 890 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2328 : team, team_number);
2329 890 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2330 890 : }
2331 :
2332 :
2333 : static void
2334 13376 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2335 : {
2336 13376 : gfc_se argse;
2337 :
2338 13376 : gfc_init_se (&argse, NULL);
2339 13376 : argse.data_not_needed = 1;
2340 13376 : argse.descriptor_only = 1;
2341 :
2342 13376 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2343 13376 : gfc_add_block_to_block (&se->pre, &argse.pre);
2344 13376 : gfc_add_block_to_block (&se->post, &argse.post);
2345 :
2346 13376 : se->expr = gfc_conv_descriptor_rank_get (argse.expr);
2347 13376 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2348 : se->expr);
2349 13376 : }
2350 :
2351 :
2352 : static void
2353 748 : gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2354 : {
2355 748 : gfc_expr *arg;
2356 748 : arg = expr->value.function.actual->expr;
2357 748 : gfc_conv_is_contiguous_expr (se, arg);
2358 748 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2359 748 : }
2360 :
2361 : /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2362 : plus it can be called directly. */
2363 :
2364 : void
2365 2098 : gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2366 : {
2367 2098 : gfc_ss *ss;
2368 2098 : gfc_se argse;
2369 2098 : tree desc, tmp, stride, extent, cond;
2370 2098 : int i;
2371 2098 : tree fncall0;
2372 2098 : gfc_array_spec *as;
2373 2098 : gfc_symbol *sym = NULL;
2374 :
2375 2098 : if (arg->ts.type == BT_CLASS)
2376 96 : gfc_add_class_array_ref (arg);
2377 :
2378 2098 : if (arg->expr_type == EXPR_VARIABLE)
2379 2062 : sym = arg->symtree->n.sym;
2380 :
2381 2098 : ss = gfc_walk_expr (arg);
2382 2098 : gcc_assert (ss != gfc_ss_terminator);
2383 2098 : gfc_init_se (&argse, NULL);
2384 2098 : argse.data_not_needed = 1;
2385 2098 : gfc_conv_expr_descriptor (&argse, arg);
2386 :
2387 2098 : as = gfc_get_full_arrayspec_from_expr (arg);
2388 :
2389 : /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2390 : Note in addition that zero-sized arrays don't count as contiguous. */
2391 :
2392 2098 : if (as && as->type == AS_ASSUMED_RANK)
2393 : {
2394 : /* Build the call to is_contiguous0. */
2395 250 : argse.want_pointer = 1;
2396 250 : gfc_conv_expr_descriptor (&argse, arg);
2397 250 : gfc_add_block_to_block (&se->pre, &argse.pre);
2398 250 : gfc_add_block_to_block (&se->post, &argse.post);
2399 250 : tree ptr = gfc_evaluate_now (argse.expr, &se->pre);
2400 250 : fncall0 = build_call_expr_loc (input_location,
2401 : gfor_fndecl_is_contiguous0, 1, ptr);
2402 250 : desc = build_fold_indirect_ref_loc (input_location, ptr);
2403 250 : se->expr = fncall0;
2404 250 : se->expr = convert (boolean_type_node, se->expr);
2405 250 : }
2406 : else
2407 : {
2408 1848 : gfc_add_block_to_block (&se->pre, &argse.pre);
2409 1848 : gfc_add_block_to_block (&se->post, &argse.post);
2410 1848 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2411 :
2412 1848 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2413 1848 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2414 1848 : stride, build_int_cst (TREE_TYPE (stride), 1));
2415 :
2416 2171 : for (i = 0; i < arg->rank - 1; i++)
2417 : {
2418 323 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2419 323 : extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2420 323 : extent = fold_build2_loc (input_location, MINUS_EXPR,
2421 : gfc_array_index_type, extent, tmp);
2422 323 : extent = fold_build2_loc (input_location, PLUS_EXPR,
2423 : gfc_array_index_type, extent,
2424 : gfc_index_one_node);
2425 323 : tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2426 323 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2427 : tmp, extent);
2428 323 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2429 323 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2430 : stride, tmp);
2431 323 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2432 : boolean_type_node, cond, tmp);
2433 : }
2434 1848 : se->expr = cond;
2435 : }
2436 :
2437 : /* An array that is addressed by the span of its descriptor needs to be
2438 : checked if that span differs from the element size. */
2439 827 : if (as && sym && !sym->attr.contiguous
2440 2925 : && (IS_POINTER (sym) || gfc_is_span_addressed_dummy (sym)))
2441 : {
2442 187 : tree span = gfc_conv_descriptor_span_get (desc);
2443 187 : tmp = fold_convert (TREE_TYPE (span),
2444 : gfc_conv_descriptor_elem_len_get (desc));
2445 187 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2446 : span, tmp);
2447 187 : se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2448 : boolean_type_node, cond,
2449 : convert (boolean_type_node, se->expr));
2450 : }
2451 :
2452 2098 : if (as && as->type == AS_ASSUMED_RANK)
2453 : {
2454 250 : tree rank = gfc_conv_descriptor_rank_get (desc);
2455 250 : tree scalar = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2456 : rank, gfc_rank_cst[0]);
2457 250 : se->expr = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2458 250 : TREE_TYPE (se->expr), scalar, se->expr);
2459 : }
2460 :
2461 2098 : gfc_free_ss_chain (ss);
2462 2098 : }
2463 :
2464 :
2465 : /* Evaluate a single upper or lower bound. */
2466 : /* TODO: bound intrinsic generates way too much unnecessary code. */
2467 :
2468 : static void
2469 16349 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2470 : {
2471 16349 : gfc_actual_arglist *arg;
2472 16349 : gfc_actual_arglist *arg2;
2473 16349 : tree desc;
2474 16349 : tree type;
2475 16349 : tree bound;
2476 16349 : tree tmp;
2477 16349 : tree cond, cond1;
2478 16349 : tree ubound;
2479 16349 : tree lbound;
2480 16349 : tree size;
2481 16349 : gfc_se argse;
2482 16349 : gfc_array_spec * as;
2483 16349 : bool assumed_rank_lb_one;
2484 :
2485 16349 : arg = expr->value.function.actual;
2486 16349 : arg2 = arg->next;
2487 :
2488 16349 : if (se->ss)
2489 : {
2490 : /* Create an implicit second parameter from the loop variable. */
2491 8016 : gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2492 8016 : gcc_assert (se->loop->dimen == 1);
2493 8016 : gcc_assert (se->ss->info->expr == expr);
2494 8016 : gfc_advance_se_ss_chain (se);
2495 8016 : bound = se->loop->loopvar[0];
2496 8016 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2497 : gfc_array_index_type, bound,
2498 : se->loop->from[0]);
2499 8016 : bound = fold_convert_loc (input_location, gfc_array_dim_rank_type,
2500 : bound);
2501 : }
2502 : else
2503 : {
2504 : /* use the passed argument. */
2505 8333 : gcc_assert (arg2->expr);
2506 8333 : gfc_init_se (&argse, NULL);
2507 8333 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_dim_rank_type);
2508 8333 : gfc_add_block_to_block (&se->pre, &argse.pre);
2509 8333 : bound = argse.expr;
2510 : /* Convert from one based to zero based. */
2511 8333 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2512 : gfc_array_dim_rank_type, bound,
2513 : gfc_rank_cst[1]);
2514 : }
2515 :
2516 : /* TODO: don't re-evaluate the descriptor on each iteration. */
2517 : /* Get a descriptor for the first parameter. */
2518 16349 : gfc_init_se (&argse, NULL);
2519 16349 : gfc_conv_expr_descriptor (&argse, arg->expr);
2520 16349 : gfc_add_block_to_block (&se->pre, &argse.pre);
2521 16349 : gfc_add_block_to_block (&se->post, &argse.post);
2522 :
2523 16349 : desc = argse.expr;
2524 :
2525 16349 : as = gfc_get_full_arrayspec_from_expr (arg->expr);
2526 :
2527 16349 : if (INTEGER_CST_P (bound))
2528 : {
2529 8213 : gcc_assert (op != GFC_ISYM_SHAPE);
2530 7976 : if (((!as || as->type != AS_ASSUMED_RANK)
2531 7305 : && wi::geu_p (wi::to_wide (bound),
2532 7305 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2533 16426 : || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2534 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2535 : "dimension index",
2536 : (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
2537 : &expr->where);
2538 : }
2539 :
2540 16349 : if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2541 : {
2542 9044 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2543 : {
2544 651 : bound = gfc_evaluate_now (bound, &se->pre);
2545 651 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2546 : bound, gfc_rank_cst[0]);
2547 651 : if (as && as->type == AS_ASSUMED_RANK)
2548 546 : tmp = gfc_conv_descriptor_rank_get (desc);
2549 : else
2550 105 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2551 651 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2552 : bound, tmp);
2553 651 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2554 : logical_type_node, cond, tmp);
2555 651 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2556 : gfc_msg_fault);
2557 : }
2558 : }
2559 :
2560 : /* Take care of the lbound shift for assumed-rank arrays that are
2561 : nonallocatable and nonpointers. Those have a lbound of 1. */
2562 15765 : assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2563 11229 : && ((arg->expr->ts.type != BT_CLASS
2564 1987 : && !arg->expr->symtree->n.sym->attr.allocatable
2565 1644 : && !arg->expr->symtree->n.sym->attr.pointer)
2566 920 : || (arg->expr->ts.type == BT_CLASS
2567 198 : && !CLASS_DATA (arg->expr)->attr.allocatable
2568 162 : && !CLASS_DATA (arg->expr)->attr.class_pointer));
2569 :
2570 16349 : ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2571 16349 : lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2572 16349 : size = fold_build2_loc (input_location, MINUS_EXPR,
2573 : gfc_array_index_type, ubound, lbound);
2574 16349 : size = fold_build2_loc (input_location, PLUS_EXPR,
2575 : gfc_array_index_type, size, gfc_index_one_node);
2576 :
2577 : /* 13.14.53: Result value for LBOUND
2578 :
2579 : Case (i): For an array section or for an array expression other than a
2580 : whole array or array structure component, LBOUND(ARRAY, DIM)
2581 : has the value 1. For a whole array or array structure
2582 : component, LBOUND(ARRAY, DIM) has the value:
2583 : (a) equal to the lower bound for subscript DIM of ARRAY if
2584 : dimension DIM of ARRAY does not have extent zero
2585 : or if ARRAY is an assumed-size array of rank DIM,
2586 : or (b) 1 otherwise.
2587 :
2588 : 13.14.113: Result value for UBOUND
2589 :
2590 : Case (i): For an array section or for an array expression other than a
2591 : whole array or array structure component, UBOUND(ARRAY, DIM)
2592 : has the value equal to the number of elements in the given
2593 : dimension; otherwise, it has a value equal to the upper bound
2594 : for subscript DIM of ARRAY if dimension DIM of ARRAY does
2595 : not have size zero and has value zero if dimension DIM has
2596 : size zero. */
2597 :
2598 16349 : if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
2599 556 : se->expr = gfc_index_one_node;
2600 15793 : else if (as)
2601 : {
2602 15209 : if (op == GFC_ISYM_UBOUND)
2603 : {
2604 5407 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2605 : size, gfc_index_zero_node);
2606 10186 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2607 : gfc_array_index_type, cond,
2608 : (assumed_rank_lb_one ? size : ubound),
2609 : gfc_index_zero_node);
2610 : }
2611 9802 : else if (op == GFC_ISYM_LBOUND)
2612 : {
2613 4931 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2614 : size, gfc_index_zero_node);
2615 4931 : if (as->type == AS_ASSUMED_SIZE)
2616 : {
2617 98 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2618 : logical_type_node, bound,
2619 98 : build_int_cst (TREE_TYPE (bound),
2620 98 : arg->expr->rank - 1));
2621 98 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2622 : logical_type_node, cond, cond1);
2623 : }
2624 4931 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2625 : gfc_array_index_type, cond,
2626 : lbound, gfc_index_one_node);
2627 : }
2628 4871 : else if (op == GFC_ISYM_SHAPE)
2629 4871 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2630 : gfc_array_index_type, size,
2631 : gfc_index_zero_node);
2632 : else
2633 0 : gcc_unreachable ();
2634 :
2635 : /* According to F2018 16.9.172, para 5, an assumed rank object,
2636 : argument associated with and assumed size array, has the ubound
2637 : of the final dimension set to -1 and UBOUND must return this.
2638 : Similarly for the SHAPE intrinsic. */
2639 15209 : if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
2640 : {
2641 835 : tree minus_one = build_int_cst (gfc_array_index_type, -1);
2642 835 : tree rank = gfc_conv_descriptor_rank_get (desc);
2643 835 : rank = fold_build2_loc (input_location, MINUS_EXPR,
2644 : gfc_array_dim_rank_type, rank,
2645 : gfc_rank_cst[1]);
2646 :
2647 : /* Fix the expression to stop it from becoming even more
2648 : complicated. */
2649 835 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
2650 :
2651 : /* Descriptors for assumed-size arrays have ubound = -1
2652 : in the last dimension. */
2653 835 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
2654 : logical_type_node, ubound, minus_one);
2655 835 : cond = fold_build2_loc (input_location, EQ_EXPR,
2656 : logical_type_node, bound, rank);
2657 835 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2658 : logical_type_node, cond, cond1);
2659 835 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2660 : gfc_array_index_type, cond,
2661 : minus_one, se->expr);
2662 : }
2663 : }
2664 : else /* as is null; this is an old-fashioned 1-based array. */
2665 : {
2666 584 : if (op != GFC_ISYM_LBOUND)
2667 : {
2668 482 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
2669 : gfc_array_index_type, size,
2670 : gfc_index_zero_node);
2671 : }
2672 : else
2673 102 : se->expr = gfc_index_one_node;
2674 : }
2675 :
2676 :
2677 16349 : type = gfc_typenode_for_spec (&expr->ts);
2678 16349 : se->expr = convert (type, se->expr);
2679 16349 : }
2680 :
2681 :
2682 : static void
2683 737 : conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2684 : {
2685 737 : gfc_actual_arglist *arg;
2686 737 : gfc_actual_arglist *arg2;
2687 737 : gfc_expr *coarray;
2688 737 : gfc_se argse;
2689 737 : tree bound, lbound, resbound, resbound2, desc, cond, tmp;
2690 737 : tree type;
2691 737 : int corank;
2692 :
2693 737 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2694 : || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2695 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE
2696 : || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2697 :
2698 737 : arg = expr->value.function.actual;
2699 737 : arg2 = arg->next;
2700 :
2701 737 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2702 :
2703 737 : coarray = strip_subobject_of_coarray (arg->expr);
2704 737 : corank = coarray->corank;
2705 :
2706 737 : gfc_init_se (&argse, NULL);
2707 737 : argse.want_coarray = 1;
2708 :
2709 737 : gfc_conv_expr_descriptor (&argse, coarray);
2710 737 : gfc_add_block_to_block (&se->pre, &argse.pre);
2711 737 : gfc_add_block_to_block (&se->post, &argse.post);
2712 737 : desc = argse.expr;
2713 :
2714 737 : if (se->ss)
2715 : {
2716 : /* Create an implicit second parameter from the loop variable. */
2717 297 : gcc_assert (!arg2->expr
2718 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE);
2719 297 : gcc_assert (corank > 0);
2720 297 : gcc_assert (se->loop->dimen == 1);
2721 297 : gcc_assert (se->ss->info->expr == expr);
2722 :
2723 297 : bound = fold_convert_loc (input_location, gfc_array_dim_rank_type,
2724 : se->loop->loopvar[0]);
2725 297 : tree rank = gfc_rank_cst[coarray->rank];
2726 297 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2727 : gfc_array_dim_rank_type, bound, rank);
2728 297 : gfc_advance_se_ss_chain (se);
2729 : }
2730 440 : else if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2731 0 : bound = gfc_rank_cst[1];
2732 : else
2733 : {
2734 440 : gcc_assert (arg2->expr);
2735 440 : gfc_init_se (&argse, NULL);
2736 440 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_dim_rank_type);
2737 440 : gfc_add_block_to_block (&se->pre, &argse.pre);
2738 440 : bound = argse.expr;
2739 :
2740 440 : if (INTEGER_CST_P (bound))
2741 : {
2742 346 : if (wi::ltu_p (wi::to_wide (bound), 1)
2743 692 : || wi::gtu_p (wi::to_wide (bound),
2744 346 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2745 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2746 0 : "dimension index", expr->value.function.isym->name,
2747 : &expr->where);
2748 : }
2749 94 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2750 : {
2751 36 : bound = gfc_evaluate_now (bound, &se->pre);
2752 36 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2753 : bound, gfc_rank_cst[1]);
2754 36 : tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2755 36 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2756 : bound, rank);
2757 36 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2758 : logical_type_node, cond, tmp);
2759 36 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2760 : gfc_msg_fault);
2761 : }
2762 :
2763 :
2764 : /* Subtract 1 to get to zero based and add dimensions. */
2765 440 : switch (coarray->rank)
2766 : {
2767 82 : case 0:
2768 82 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2769 : gfc_array_dim_rank_type, bound,
2770 : gfc_rank_cst[1]);
2771 : case 1:
2772 : break;
2773 38 : default:
2774 38 : {
2775 38 : tree rank = gfc_rank_cst[coarray->rank - 1];
2776 38 : bound = fold_build2_loc (input_location, PLUS_EXPR,
2777 : gfc_array_dim_rank_type, bound, rank);
2778 : }
2779 : }
2780 : }
2781 :
2782 737 : resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2783 :
2784 : /* COSHAPE needs the lower cobound and so it is stashed here before resbound
2785 : is overwritten. */
2786 737 : lbound = NULL_TREE;
2787 737 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2788 16 : lbound = resbound;
2789 :
2790 : /* Handle UCOBOUND with special handling of the last codimension. */
2791 737 : if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2792 465 : || expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2793 : {
2794 : /* Last codimension: For -fcoarray=single just return
2795 : the lcobound - otherwise add
2796 : ceiling (real (num_images ()) / real (size)) - 1
2797 : = (num_images () + size - 1) / size - 1
2798 : = (num_images - 1) / size(),
2799 : where size is the product of the extent of all but the last
2800 : codimension. */
2801 :
2802 288 : if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2803 : {
2804 80 : tree cosize;
2805 :
2806 80 : cosize = gfc_conv_descriptor_cosize (desc, coarray->rank, corank);
2807 80 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2808 : 2, null_pointer_node, null_pointer_node);
2809 80 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2810 : gfc_array_index_type,
2811 : fold_convert (gfc_array_index_type, tmp),
2812 : build_int_cst (gfc_array_index_type, 1));
2813 80 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2814 : gfc_array_index_type, tmp,
2815 : fold_convert (gfc_array_index_type, cosize));
2816 80 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2817 : gfc_array_index_type, resbound, tmp);
2818 80 : }
2819 208 : else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2820 : {
2821 : /* ubound = lbound + num_images() - 1. */
2822 56 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2823 : 2, null_pointer_node, null_pointer_node);
2824 56 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2825 : gfc_array_index_type,
2826 : fold_convert (gfc_array_index_type, tmp),
2827 : build_int_cst (gfc_array_index_type, 1));
2828 56 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
2829 : gfc_array_index_type, resbound, tmp);
2830 : }
2831 :
2832 288 : if (corank > 1)
2833 : {
2834 195 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2835 : bound,
2836 195 : build_int_cst (TREE_TYPE (bound),
2837 195 : coarray->rank + corank - 1));
2838 :
2839 195 : resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2840 195 : se->expr = fold_build3_loc (input_location, COND_EXPR,
2841 : gfc_array_index_type, cond,
2842 : resbound, resbound2);
2843 : }
2844 : else
2845 : se->expr = resbound;
2846 :
2847 : /* Get the coshape for this dimension. */
2848 288 : if (expr->value.function.isym->id == GFC_ISYM_COSHAPE)
2849 : {
2850 16 : gcc_assert (lbound != NULL_TREE);
2851 16 : se->expr = fold_build2_loc (input_location, MINUS_EXPR,
2852 : gfc_array_index_type,
2853 : se->expr, lbound);
2854 16 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2855 : gfc_array_index_type,
2856 : se->expr, gfc_index_one_node);
2857 : }
2858 : }
2859 : else
2860 449 : se->expr = resbound;
2861 :
2862 737 : type = gfc_typenode_for_spec (&expr->ts);
2863 737 : se->expr = convert (type, se->expr);
2864 :
2865 737 : gfc_free_expr (coarray);
2866 737 : }
2867 :
2868 :
2869 : static void
2870 2429 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2871 : {
2872 2429 : gfc_actual_arglist *array_arg;
2873 2429 : gfc_actual_arglist *dim_arg;
2874 2429 : gfc_se argse;
2875 2429 : tree desc, tmp;
2876 :
2877 2429 : array_arg = expr->value.function.actual;
2878 2429 : dim_arg = array_arg->next;
2879 :
2880 2429 : gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2881 :
2882 2429 : gfc_init_se (&argse, NULL);
2883 2429 : gfc_conv_expr_descriptor (&argse, array_arg->expr);
2884 2429 : gfc_add_block_to_block (&se->pre, &argse.pre);
2885 2429 : gfc_add_block_to_block (&se->post, &argse.post);
2886 2429 : desc = argse.expr;
2887 :
2888 2429 : gcc_assert (dim_arg->expr);
2889 2429 : gfc_init_se (&argse, NULL);
2890 2429 : gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2891 2429 : gfc_add_block_to_block (&se->pre, &argse.pre);
2892 2429 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2893 : argse.expr, gfc_index_one_node);
2894 2429 : se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2895 2429 : }
2896 :
2897 : static void
2898 8028 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2899 : {
2900 8028 : tree arg, cabs;
2901 :
2902 8028 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2903 :
2904 8028 : switch (expr->value.function.actual->expr->ts.type)
2905 : {
2906 7004 : case BT_INTEGER:
2907 7004 : case BT_REAL:
2908 7004 : se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2909 : arg);
2910 7004 : break;
2911 :
2912 1024 : case BT_COMPLEX:
2913 1024 : cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
2914 1024 : se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2915 1024 : break;
2916 :
2917 0 : default:
2918 0 : gcc_unreachable ();
2919 : }
2920 8028 : }
2921 :
2922 :
2923 : /* Create a complex value from one or two real components. */
2924 :
2925 : static void
2926 497 : gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2927 : {
2928 497 : tree real;
2929 497 : tree imag;
2930 497 : tree type;
2931 497 : tree *args;
2932 497 : unsigned int num_args;
2933 :
2934 497 : num_args = gfc_intrinsic_argument_list_length (expr);
2935 497 : args = XALLOCAVEC (tree, num_args);
2936 :
2937 497 : type = gfc_typenode_for_spec (&expr->ts);
2938 497 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2939 497 : real = convert (TREE_TYPE (type), args[0]);
2940 497 : if (both)
2941 453 : imag = convert (TREE_TYPE (type), args[1]);
2942 44 : else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
2943 : {
2944 30 : imag = fold_build1_loc (input_location, IMAGPART_EXPR,
2945 30 : TREE_TYPE (TREE_TYPE (args[0])), args[0]);
2946 30 : imag = convert (TREE_TYPE (type), imag);
2947 : }
2948 : else
2949 14 : imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
2950 :
2951 497 : se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
2952 497 : }
2953 :
2954 :
2955 : /* Remainder function MOD(A, P) = A - INT(A / P) * P
2956 : MODULO(A, P) = A - FLOOR (A / P) * P
2957 :
2958 : The obvious algorithms above are numerically instable for large
2959 : arguments, hence these intrinsics are instead implemented via calls
2960 : to the fmod family of functions. It is the responsibility of the
2961 : user to ensure that the second argument is non-zero. */
2962 :
2963 : static void
2964 3845 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
2965 : {
2966 3845 : tree type;
2967 3845 : tree tmp;
2968 3845 : tree test;
2969 3845 : tree test2;
2970 3845 : tree fmod;
2971 3845 : tree zero;
2972 3845 : tree args[2];
2973 :
2974 3845 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
2975 :
2976 3845 : switch (expr->ts.type)
2977 : {
2978 3692 : case BT_INTEGER:
2979 : /* Integer case is easy, we've got a builtin op. */
2980 3692 : type = TREE_TYPE (args[0]);
2981 :
2982 3692 : if (modulo)
2983 411 : se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
2984 : args[0], args[1]);
2985 : else
2986 3281 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2987 : args[0], args[1]);
2988 : break;
2989 :
2990 30 : case BT_UNSIGNED:
2991 : /* Even easier, we only need one. */
2992 30 : type = TREE_TYPE (args[0]);
2993 30 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
2994 : args[0], args[1]);
2995 30 : break;
2996 :
2997 123 : case BT_REAL:
2998 123 : fmod = NULL_TREE;
2999 : /* Check if we have a builtin fmod. */
3000 123 : fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
3001 :
3002 : /* The builtin should always be available. */
3003 123 : gcc_assert (fmod != NULL_TREE);
3004 :
3005 123 : tmp = build_addr (fmod);
3006 123 : se->expr = build_call_array_loc (input_location,
3007 123 : TREE_TYPE (TREE_TYPE (fmod)),
3008 : tmp, 2, args);
3009 123 : if (modulo == 0)
3010 123 : return;
3011 :
3012 25 : type = TREE_TYPE (args[0]);
3013 :
3014 25 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3015 25 : args[1] = gfc_evaluate_now (args[1], &se->pre);
3016 :
3017 : /* Definition:
3018 : modulo = arg - floor (arg/arg2) * arg2
3019 :
3020 : In order to calculate the result accurately, we use the fmod
3021 : function as follows.
3022 :
3023 : res = fmod (arg, arg2);
3024 : if (res)
3025 : {
3026 : if ((arg < 0) xor (arg2 < 0))
3027 : res += arg2;
3028 : }
3029 : else
3030 : res = copysign (0., arg2);
3031 :
3032 : => As two nested ternary exprs:
3033 :
3034 : res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3035 : : copysign (0., arg2);
3036 :
3037 : */
3038 :
3039 25 : zero = gfc_build_const (type, integer_zero_node);
3040 25 : tmp = gfc_evaluate_now (se->expr, &se->pre);
3041 25 : if (!flag_signed_zeros)
3042 : {
3043 1 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3044 : args[0], zero);
3045 1 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3046 : args[1], zero);
3047 1 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3048 : logical_type_node, test, test2);
3049 1 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3050 : tmp, zero);
3051 1 : test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3052 : logical_type_node, test, test2);
3053 1 : test = gfc_evaluate_now (test, &se->pre);
3054 1 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3055 : fold_build2_loc (input_location,
3056 : PLUS_EXPR,
3057 : type, tmp, args[1]),
3058 : tmp);
3059 : }
3060 : else
3061 : {
3062 24 : tree expr1, copysign, cscall;
3063 24 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3064 : expr->ts.kind);
3065 24 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3066 : args[0], zero);
3067 24 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3068 : args[1], zero);
3069 24 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3070 : logical_type_node, test, test2);
3071 24 : expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3072 : fold_build2_loc (input_location,
3073 : PLUS_EXPR,
3074 : type, tmp, args[1]),
3075 : tmp);
3076 24 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3077 : tmp, zero);
3078 24 : cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3079 : args[1]);
3080 24 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3081 : expr1, cscall);
3082 : }
3083 : return;
3084 :
3085 0 : default:
3086 0 : gcc_unreachable ();
3087 : }
3088 : }
3089 :
3090 : /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3091 : DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3092 : where the right shifts are logical (i.e. 0's are shifted in).
3093 : Because SHIFT_EXPR's want shifts strictly smaller than the integral
3094 : type width, we have to special-case both S == 0 and S == BITSIZE(J):
3095 : DSHIFTL(I,J,0) = I
3096 : DSHIFTL(I,J,BITSIZE) = J
3097 : DSHIFTR(I,J,0) = J
3098 : DSHIFTR(I,J,BITSIZE) = I. */
3099 :
3100 : static void
3101 132 : gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3102 : {
3103 132 : tree type, utype, stype, arg1, arg2, shift, res, left, right;
3104 132 : tree args[3], cond, tmp;
3105 132 : int bitsize;
3106 :
3107 132 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
3108 :
3109 132 : gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3110 132 : type = TREE_TYPE (args[0]);
3111 132 : bitsize = TYPE_PRECISION (type);
3112 132 : utype = unsigned_type_for (type);
3113 132 : stype = TREE_TYPE (args[2]);
3114 :
3115 132 : arg1 = gfc_evaluate_now (args[0], &se->pre);
3116 132 : arg2 = gfc_evaluate_now (args[1], &se->pre);
3117 132 : shift = gfc_evaluate_now (args[2], &se->pre);
3118 :
3119 : /* The generic case. */
3120 132 : tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3121 132 : build_int_cst (stype, bitsize), shift);
3122 198 : left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3123 : arg1, dshiftl ? shift : tmp);
3124 :
3125 198 : right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3126 : fold_convert (utype, arg2), dshiftl ? tmp : shift);
3127 132 : right = fold_convert (type, right);
3128 :
3129 132 : res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3130 :
3131 : /* Special cases. */
3132 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3133 : build_int_cst (stype, 0));
3134 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3135 : dshiftl ? arg1 : arg2, res);
3136 :
3137 132 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3138 132 : build_int_cst (stype, bitsize));
3139 198 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3140 : dshiftl ? arg2 : arg1, res);
3141 :
3142 132 : se->expr = res;
3143 132 : }
3144 :
3145 :
3146 : /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3147 :
3148 : static void
3149 96 : gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3150 : {
3151 96 : tree val;
3152 96 : tree tmp;
3153 96 : tree type;
3154 96 : tree zero;
3155 96 : tree args[2];
3156 :
3157 96 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3158 96 : type = TREE_TYPE (args[0]);
3159 :
3160 96 : val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3161 96 : val = gfc_evaluate_now (val, &se->pre);
3162 :
3163 96 : zero = gfc_build_const (type, integer_zero_node);
3164 96 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3165 96 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3166 96 : }
3167 :
3168 :
3169 : /* SIGN(A, B) is absolute value of A times sign of B.
3170 : The real value versions use library functions to ensure the correct
3171 : handling of negative zero. Integer case implemented as:
3172 : SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3173 : */
3174 :
3175 : static void
3176 423 : gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3177 : {
3178 423 : tree tmp;
3179 423 : tree type;
3180 423 : tree args[2];
3181 :
3182 423 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3183 423 : if (expr->ts.type == BT_REAL)
3184 : {
3185 161 : tree abs;
3186 :
3187 161 : tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3188 161 : abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3189 :
3190 : /* We explicitly have to ignore the minus sign. We do so by using
3191 : result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3192 161 : if (!flag_sign_zero
3193 197 : && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3194 : {
3195 12 : tree cond, zero;
3196 12 : zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3197 12 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3198 : args[1], zero);
3199 24 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3200 12 : TREE_TYPE (args[0]), cond,
3201 : build_call_expr_loc (input_location, abs, 1,
3202 : args[0]),
3203 : build_call_expr_loc (input_location, tmp, 2,
3204 : args[0], args[1]));
3205 : }
3206 : else
3207 149 : se->expr = build_call_expr_loc (input_location, tmp, 2,
3208 : args[0], args[1]);
3209 161 : return;
3210 : }
3211 :
3212 : /* Having excluded floating point types, we know we are now dealing
3213 : with signed integer types. */
3214 262 : type = TREE_TYPE (args[0]);
3215 :
3216 : /* Args[0] is used multiple times below. */
3217 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3218 :
3219 : /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3220 : the signs of A and B are the same, and of all ones if they differ. */
3221 262 : tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3222 262 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3223 262 : build_int_cst (type, TYPE_PRECISION (type) - 1));
3224 262 : tmp = gfc_evaluate_now (tmp, &se->pre);
3225 :
3226 : /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3227 : is all ones (i.e. -1). */
3228 262 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3229 : fold_build2_loc (input_location, PLUS_EXPR,
3230 : type, args[0], tmp), tmp);
3231 : }
3232 :
3233 :
3234 : /* Test for the presence of an optional argument. */
3235 :
3236 : static void
3237 5202 : gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3238 : {
3239 5202 : gfc_expr *arg;
3240 :
3241 5202 : arg = expr->value.function.actual->expr;
3242 5202 : gcc_assert (arg->expr_type == EXPR_VARIABLE);
3243 5202 : se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3244 5202 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3245 5202 : }
3246 :
3247 :
3248 : /* Calculate the double precision product of two single precision values. */
3249 :
3250 : static void
3251 13 : gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3252 : {
3253 13 : tree type;
3254 13 : tree args[2];
3255 :
3256 13 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3257 :
3258 : /* Convert the args to double precision before multiplying. */
3259 13 : type = gfc_typenode_for_spec (&expr->ts);
3260 13 : args[0] = convert (type, args[0]);
3261 13 : args[1] = convert (type, args[1]);
3262 13 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3263 : args[1]);
3264 13 : }
3265 :
3266 :
3267 : /* Return a length one character string containing an ascii character. */
3268 :
3269 : static void
3270 2020 : gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3271 : {
3272 2020 : tree arg[2];
3273 2020 : tree var;
3274 2020 : tree type;
3275 2020 : unsigned int num_args;
3276 :
3277 2020 : num_args = gfc_intrinsic_argument_list_length (expr);
3278 2020 : gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3279 :
3280 2020 : type = gfc_get_char_type (expr->ts.kind);
3281 2020 : var = gfc_create_var (type, "char");
3282 :
3283 2020 : arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3284 2020 : gfc_add_modify (&se->pre, var, arg[0]);
3285 2020 : se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3286 2020 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3287 2020 : }
3288 :
3289 :
3290 : static void
3291 0 : gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3292 : {
3293 0 : tree var;
3294 0 : tree len;
3295 0 : tree tmp;
3296 0 : tree cond;
3297 0 : tree fndecl;
3298 0 : tree *args;
3299 0 : unsigned int num_args;
3300 :
3301 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3302 0 : args = XALLOCAVEC (tree, num_args);
3303 :
3304 0 : var = gfc_create_var (pchar_type_node, "pstr");
3305 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3306 :
3307 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3308 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3309 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3310 :
3311 0 : fndecl = build_addr (gfor_fndecl_ctime);
3312 0 : tmp = build_call_array_loc (input_location,
3313 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3314 : fndecl, num_args, args);
3315 0 : gfc_add_expr_to_block (&se->pre, tmp);
3316 :
3317 : /* Free the temporary afterwards, if necessary. */
3318 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3319 0 : len, build_int_cst (TREE_TYPE (len), 0));
3320 0 : tmp = gfc_call_free (var);
3321 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3322 0 : gfc_add_expr_to_block (&se->post, tmp);
3323 :
3324 0 : se->expr = var;
3325 0 : se->string_length = len;
3326 0 : }
3327 :
3328 :
3329 : static void
3330 0 : gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3331 : {
3332 0 : tree var;
3333 0 : tree len;
3334 0 : tree tmp;
3335 0 : tree cond;
3336 0 : tree fndecl;
3337 0 : tree *args;
3338 0 : unsigned int num_args;
3339 :
3340 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3341 0 : args = XALLOCAVEC (tree, num_args);
3342 :
3343 0 : var = gfc_create_var (pchar_type_node, "pstr");
3344 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3345 :
3346 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3347 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3348 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3349 :
3350 0 : fndecl = build_addr (gfor_fndecl_fdate);
3351 0 : tmp = build_call_array_loc (input_location,
3352 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3353 : fndecl, num_args, args);
3354 0 : gfc_add_expr_to_block (&se->pre, tmp);
3355 :
3356 : /* Free the temporary afterwards, if necessary. */
3357 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3358 0 : len, build_int_cst (TREE_TYPE (len), 0));
3359 0 : tmp = gfc_call_free (var);
3360 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3361 0 : gfc_add_expr_to_block (&se->post, tmp);
3362 :
3363 0 : se->expr = var;
3364 0 : se->string_length = len;
3365 0 : }
3366 :
3367 :
3368 : /* Generate a direct call to free() for the FREE subroutine. */
3369 :
3370 : static tree
3371 10 : conv_intrinsic_free (gfc_code *code)
3372 : {
3373 10 : stmtblock_t block;
3374 10 : gfc_se argse;
3375 10 : tree arg, call;
3376 :
3377 10 : gfc_init_se (&argse, NULL);
3378 10 : gfc_conv_expr (&argse, code->ext.actual->expr);
3379 10 : arg = fold_convert (ptr_type_node, argse.expr);
3380 :
3381 10 : gfc_init_block (&block);
3382 10 : call = build_call_expr_loc (input_location,
3383 : builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3384 10 : gfc_add_expr_to_block (&block, call);
3385 10 : return gfc_finish_block (&block);
3386 : }
3387 :
3388 :
3389 : /* Call the RANDOM_INIT library subroutine with a hidden argument for
3390 : handling seeding on coarray images. */
3391 :
3392 : static tree
3393 90 : conv_intrinsic_random_init (gfc_code *code)
3394 : {
3395 90 : stmtblock_t block;
3396 90 : gfc_se se;
3397 90 : tree arg1, arg2, tmp;
3398 : /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3399 90 : tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3400 90 : ? logical_type_node
3401 90 : : gfc_get_logical_type (4);
3402 :
3403 : /* Make the function call. */
3404 90 : gfc_init_block (&block);
3405 90 : gfc_init_se (&se, NULL);
3406 :
3407 : /* Convert REPEATABLE to the desired LOGICAL entity. */
3408 90 : gfc_conv_expr (&se, code->ext.actual->expr);
3409 90 : gfc_add_block_to_block (&block, &se.pre);
3410 90 : arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3411 90 : gfc_add_block_to_block (&block, &se.post);
3412 :
3413 : /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3414 90 : gfc_conv_expr (&se, code->ext.actual->next->expr);
3415 90 : gfc_add_block_to_block (&block, &se.pre);
3416 90 : arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3417 90 : gfc_add_block_to_block (&block, &se.post);
3418 :
3419 90 : if (flag_coarray == GFC_FCOARRAY_LIB)
3420 : {
3421 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3422 : 2, arg1, arg2);
3423 : }
3424 : else
3425 : {
3426 : /* The ABI for libgfortran needs to be maintained, so a hidden
3427 : argument must be include if code is compiled with -fcoarray=single
3428 : or without the option. Set to 0. */
3429 90 : tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3430 90 : tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3431 : 3, arg1, arg2, arg3);
3432 : }
3433 :
3434 90 : gfc_add_expr_to_block (&block, tmp);
3435 :
3436 90 : return gfc_finish_block (&block);
3437 : }
3438 :
3439 :
3440 : /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3441 : conversions. */
3442 :
3443 : static tree
3444 196 : conv_intrinsic_system_clock (gfc_code *code)
3445 : {
3446 196 : stmtblock_t block;
3447 196 : gfc_se count_se, count_rate_se, count_max_se;
3448 196 : tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3449 196 : tree tmp;
3450 196 : int least;
3451 :
3452 196 : gfc_expr *count = code->ext.actual->expr;
3453 196 : gfc_expr *count_rate = code->ext.actual->next->expr;
3454 196 : gfc_expr *count_max = code->ext.actual->next->next->expr;
3455 :
3456 : /* Evaluate our arguments. */
3457 196 : if (count)
3458 : {
3459 196 : gfc_init_se (&count_se, NULL);
3460 196 : gfc_conv_expr (&count_se, count);
3461 : }
3462 :
3463 196 : if (count_rate)
3464 : {
3465 181 : gfc_init_se (&count_rate_se, NULL);
3466 181 : gfc_conv_expr (&count_rate_se, count_rate);
3467 : }
3468 :
3469 196 : if (count_max)
3470 : {
3471 180 : gfc_init_se (&count_max_se, NULL);
3472 180 : gfc_conv_expr (&count_max_se, count_max);
3473 : }
3474 :
3475 : /* Find the smallest kind found of the arguments. */
3476 196 : least = 16;
3477 196 : least = (count && count->ts.kind < least) ? count->ts.kind : least;
3478 196 : least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3479 : : least;
3480 196 : least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3481 : : least;
3482 :
3483 : /* Prepare temporary variables. */
3484 :
3485 196 : if (count)
3486 : {
3487 196 : if (least >= 8)
3488 18 : arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3489 178 : else if (least == 4)
3490 154 : arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3491 24 : else if (count->ts.kind == 1)
3492 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3493 : count->ts.kind);
3494 : else
3495 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3496 : count->ts.kind);
3497 : }
3498 :
3499 196 : if (count_rate)
3500 : {
3501 181 : if (least >= 8)
3502 18 : arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3503 163 : else if (least == 4)
3504 139 : arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3505 : else
3506 24 : arg2 = integer_zero_node;
3507 : }
3508 :
3509 196 : if (count_max)
3510 : {
3511 180 : if (least >= 8)
3512 18 : arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3513 162 : else if (least == 4)
3514 138 : arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3515 : else
3516 24 : arg3 = integer_zero_node;
3517 : }
3518 :
3519 : /* Make the function call. */
3520 196 : gfc_init_block (&block);
3521 :
3522 196 : if (least <= 2)
3523 : {
3524 24 : if (least == 1)
3525 : {
3526 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3527 : : null_pointer_node;
3528 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3529 : : null_pointer_node;
3530 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3531 : : null_pointer_node;
3532 : }
3533 :
3534 24 : if (least == 2)
3535 : {
3536 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3537 : : null_pointer_node;
3538 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3539 : : null_pointer_node;
3540 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3541 : : null_pointer_node;
3542 : }
3543 : }
3544 : else
3545 : {
3546 172 : if (least == 4)
3547 : {
3548 585 : tmp = build_call_expr_loc (input_location,
3549 : gfor_fndecl_system_clock4, 3,
3550 154 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3551 : : null_pointer_node,
3552 139 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3553 : : null_pointer_node,
3554 138 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3555 : : null_pointer_node);
3556 154 : gfc_add_expr_to_block (&block, tmp);
3557 : }
3558 : /* Handle kind>=8, 10, or 16 arguments */
3559 172 : if (least >= 8)
3560 : {
3561 72 : tmp = build_call_expr_loc (input_location,
3562 : gfor_fndecl_system_clock8, 3,
3563 18 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3564 : : null_pointer_node,
3565 18 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3566 : : null_pointer_node,
3567 18 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3568 : : null_pointer_node);
3569 18 : gfc_add_expr_to_block (&block, tmp);
3570 : }
3571 : }
3572 :
3573 : /* And store values back if needed. */
3574 196 : if (arg1 && arg1 != count_se.expr)
3575 196 : gfc_add_modify (&block, count_se.expr,
3576 196 : fold_convert (TREE_TYPE (count_se.expr), arg1));
3577 196 : if (arg2 && arg2 != count_rate_se.expr)
3578 181 : gfc_add_modify (&block, count_rate_se.expr,
3579 181 : fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3580 196 : if (arg3 && arg3 != count_max_se.expr)
3581 180 : gfc_add_modify (&block, count_max_se.expr,
3582 180 : fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3583 :
3584 196 : return gfc_finish_block (&block);
3585 : }
3586 :
3587 : static tree
3588 102 : conv_intrinsic_split (gfc_code *code)
3589 : {
3590 102 : stmtblock_t block, post_block;
3591 102 : gfc_se se;
3592 102 : gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
3593 102 : tree string, string_len;
3594 102 : tree set, set_len;
3595 102 : tree pos, pos_for_call;
3596 102 : tree back;
3597 102 : tree fndecl, call;
3598 :
3599 102 : string_expr = code->ext.actual->expr;
3600 102 : set_expr = code->ext.actual->next->expr;
3601 102 : pos_expr = code->ext.actual->next->next->expr;
3602 102 : back_expr = code->ext.actual->next->next->next->expr;
3603 :
3604 102 : gfc_start_block (&block);
3605 102 : gfc_init_block (&post_block);
3606 :
3607 102 : gfc_init_se (&se, NULL);
3608 102 : gfc_conv_expr (&se, string_expr);
3609 102 : gfc_conv_string_parameter (&se);
3610 102 : gfc_add_block_to_block (&block, &se.pre);
3611 102 : gfc_add_block_to_block (&post_block, &se.post);
3612 102 : string = se.expr;
3613 102 : string_len = se.string_length;
3614 :
3615 102 : gfc_init_se (&se, NULL);
3616 102 : gfc_conv_expr (&se, set_expr);
3617 102 : gfc_conv_string_parameter (&se);
3618 102 : gfc_add_block_to_block (&block, &se.pre);
3619 102 : gfc_add_block_to_block (&post_block, &se.post);
3620 102 : set = se.expr;
3621 102 : set_len = se.string_length;
3622 :
3623 102 : gfc_init_se (&se, NULL);
3624 102 : gfc_conv_expr (&se, pos_expr);
3625 102 : gfc_add_block_to_block (&block, &se.pre);
3626 102 : gfc_add_block_to_block (&post_block, &se.post);
3627 102 : pos = se.expr;
3628 102 : pos_for_call = fold_convert (gfc_charlen_type_node, pos);
3629 :
3630 102 : if (back_expr)
3631 : {
3632 48 : gfc_init_se (&se, NULL);
3633 48 : gfc_conv_expr (&se, back_expr);
3634 48 : gfc_add_block_to_block (&block, &se.pre);
3635 48 : gfc_add_block_to_block (&post_block, &se.post);
3636 48 : back = se.expr;
3637 : }
3638 : else
3639 54 : back = logical_false_node;
3640 :
3641 102 : if (string_expr->ts.kind == 1)
3642 66 : fndecl = gfor_fndecl_string_split;
3643 36 : else if (string_expr->ts.kind == 4)
3644 36 : fndecl = gfor_fndecl_string_split_char4;
3645 : else
3646 0 : gcc_unreachable ();
3647 :
3648 102 : call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
3649 : set_len, set, pos_for_call, back);
3650 102 : gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
3651 :
3652 102 : gfc_add_block_to_block (&block, &post_block);
3653 102 : return gfc_finish_block (&block);
3654 : }
3655 :
3656 : /* Return a character string containing the tty name. */
3657 :
3658 : static void
3659 0 : gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3660 : {
3661 0 : tree var;
3662 0 : tree len;
3663 0 : tree tmp;
3664 0 : tree cond;
3665 0 : tree fndecl;
3666 0 : tree *args;
3667 0 : unsigned int num_args;
3668 :
3669 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3670 0 : args = XALLOCAVEC (tree, num_args);
3671 :
3672 0 : var = gfc_create_var (pchar_type_node, "pstr");
3673 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3674 :
3675 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3676 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3677 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3678 :
3679 0 : fndecl = build_addr (gfor_fndecl_ttynam);
3680 0 : tmp = build_call_array_loc (input_location,
3681 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3682 : fndecl, num_args, args);
3683 0 : gfc_add_expr_to_block (&se->pre, tmp);
3684 :
3685 : /* Free the temporary afterwards, if necessary. */
3686 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3687 0 : len, build_int_cst (TREE_TYPE (len), 0));
3688 0 : tmp = gfc_call_free (var);
3689 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3690 0 : gfc_add_expr_to_block (&se->post, tmp);
3691 :
3692 0 : se->expr = var;
3693 0 : se->string_length = len;
3694 0 : }
3695 :
3696 :
3697 : /* Get the minimum/maximum value of all the parameters.
3698 : minmax (a1, a2, a3, ...)
3699 : {
3700 : mvar = a1;
3701 : mvar = COMP (mvar, a2)
3702 : mvar = COMP (mvar, a3)
3703 : ...
3704 : return mvar;
3705 : }
3706 : Where COMP is MIN/MAX_EXPR for integral types or when we don't
3707 : care about NaNs, or IFN_FMIN/MAX when the target has support for
3708 : fast NaN-honouring min/max. When neither holds expand a sequence
3709 : of explicit comparisons. */
3710 :
3711 : /* TODO: Mismatching types can occur when specific names are used.
3712 : These should be handled during resolution. */
3713 : static void
3714 1367 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3715 : {
3716 1367 : tree tmp;
3717 1367 : tree mvar;
3718 1367 : tree val;
3719 1367 : tree *args;
3720 1367 : tree type;
3721 1367 : tree argtype;
3722 1367 : gfc_actual_arglist *argexpr;
3723 1367 : unsigned int i, nargs;
3724 :
3725 1367 : nargs = gfc_intrinsic_argument_list_length (expr);
3726 1367 : args = XALLOCAVEC (tree, nargs);
3727 :
3728 1367 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3729 1367 : type = gfc_typenode_for_spec (&expr->ts);
3730 :
3731 : /* Only evaluate the argument once. */
3732 1367 : if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3733 370 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3734 :
3735 : /* Determine suitable type of temporary, as a GNU extension allows
3736 : different argument kinds. */
3737 1367 : argtype = TREE_TYPE (args[0]);
3738 1367 : argexpr = expr->value.function.actual;
3739 2953 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3740 : {
3741 1586 : tree tmptype = TREE_TYPE (args[i]);
3742 1586 : if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
3743 1 : argtype = tmptype;
3744 : }
3745 1367 : mvar = gfc_create_var (argtype, "M");
3746 1367 : gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
3747 :
3748 1367 : argexpr = expr->value.function.actual;
3749 2953 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
3750 : {
3751 1586 : tree cond = NULL_TREE;
3752 1586 : val = args[i];
3753 :
3754 : /* Handle absent optional arguments by ignoring the comparison. */
3755 1586 : if (argexpr->expr->expr_type == EXPR_VARIABLE
3756 920 : && argexpr->expr->symtree->n.sym->attr.optional
3757 45 : && INDIRECT_REF_P (val))
3758 : {
3759 84 : cond = fold_build2_loc (input_location,
3760 : NE_EXPR, logical_type_node,
3761 42 : TREE_OPERAND (val, 0),
3762 42 : build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3763 : }
3764 1544 : else if (!VAR_P (val) && !TREE_CONSTANT (val))
3765 : /* Only evaluate the argument once. */
3766 599 : val = gfc_evaluate_now (val, &se->pre);
3767 :
3768 1586 : tree calc;
3769 : /* For floating point types, the question is what MAX(a, NaN) or
3770 : MIN(a, NaN) should return (where "a" is a normal number).
3771 : There are valid use case for returning either one, but the
3772 : Fortran standard doesn't specify which one should be chosen.
3773 : Also, there is no consensus among other tested compilers. In
3774 : short, it's a mess. So lets just do whatever is fastest. */
3775 1586 : tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
3776 1586 : calc = fold_build2_loc (input_location, code, argtype,
3777 : convert (argtype, val), mvar);
3778 1586 : tmp = build2_v (MODIFY_EXPR, mvar, calc);
3779 :
3780 1586 : if (cond != NULL_TREE)
3781 42 : tmp = build3_v (COND_EXPR, cond, tmp,
3782 : build_empty_stmt (input_location));
3783 1586 : gfc_add_expr_to_block (&se->pre, tmp);
3784 : }
3785 1367 : se->expr = convert (type, mvar);
3786 1367 : }
3787 :
3788 :
3789 : /* Generate library calls for MIN and MAX intrinsics for character
3790 : variables. */
3791 : static void
3792 282 : gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3793 : {
3794 282 : tree *args;
3795 282 : tree var, len, fndecl, tmp, cond, function;
3796 282 : unsigned int nargs;
3797 :
3798 282 : nargs = gfc_intrinsic_argument_list_length (expr);
3799 282 : args = XALLOCAVEC (tree, nargs + 4);
3800 282 : gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3801 :
3802 : /* Create the result variables. */
3803 282 : len = gfc_create_var (gfc_charlen_type_node, "len");
3804 282 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
3805 282 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3806 282 : args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3807 282 : args[2] = build_int_cst (integer_type_node, op);
3808 282 : args[3] = build_int_cst (integer_type_node, nargs / 2);
3809 :
3810 282 : if (expr->ts.kind == 1)
3811 210 : function = gfor_fndecl_string_minmax;
3812 72 : else if (expr->ts.kind == 4)
3813 72 : function = gfor_fndecl_string_minmax_char4;
3814 : else
3815 0 : gcc_unreachable ();
3816 :
3817 : /* Make the function call. */
3818 282 : fndecl = build_addr (function);
3819 282 : tmp = build_call_array_loc (input_location,
3820 282 : TREE_TYPE (TREE_TYPE (function)), fndecl,
3821 : nargs + 4, args);
3822 282 : gfc_add_expr_to_block (&se->pre, tmp);
3823 :
3824 : /* Free the temporary afterwards, if necessary. */
3825 282 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3826 282 : len, build_int_cst (TREE_TYPE (len), 0));
3827 282 : tmp = gfc_call_free (var);
3828 282 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3829 282 : gfc_add_expr_to_block (&se->post, tmp);
3830 :
3831 282 : se->expr = var;
3832 282 : se->string_length = len;
3833 282 : }
3834 :
3835 :
3836 : /* Create a symbol node for this intrinsic. The symbol from the frontend
3837 : has the generic name. */
3838 :
3839 : static gfc_symbol *
3840 11363 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3841 : {
3842 11363 : gfc_symbol *sym;
3843 :
3844 : /* TODO: Add symbols for intrinsic function to the global namespace. */
3845 11363 : gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3846 11363 : sym = gfc_new_symbol (expr->value.function.name, NULL);
3847 :
3848 11363 : sym->ts = expr->ts;
3849 11363 : if (sym->ts.type == BT_CHARACTER)
3850 1784 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3851 11363 : sym->attr.external = 1;
3852 11363 : sym->attr.function = 1;
3853 11363 : sym->attr.always_explicit = 1;
3854 11363 : sym->attr.proc = PROC_INTRINSIC;
3855 11363 : sym->attr.flavor = FL_PROCEDURE;
3856 11363 : sym->result = sym;
3857 11363 : if (expr->rank > 0)
3858 : {
3859 9933 : sym->attr.dimension = 1;
3860 9933 : sym->as = gfc_get_array_spec ();
3861 9933 : sym->as->type = AS_ASSUMED_SHAPE;
3862 9933 : sym->as->rank = expr->rank;
3863 : }
3864 :
3865 11363 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3866 : ignore_optional ? expr->value.function.actual
3867 : : NULL);
3868 :
3869 11363 : return sym;
3870 : }
3871 :
3872 : /* Remove empty actual arguments. */
3873 :
3874 : static void
3875 8277 : remove_empty_actual_arguments (gfc_actual_arglist **ap)
3876 : {
3877 44456 : while (*ap)
3878 : {
3879 36179 : if ((*ap)->expr == NULL)
3880 : {
3881 11076 : gfc_actual_arglist *r = *ap;
3882 11076 : *ap = r->next;
3883 11076 : r->next = NULL;
3884 11076 : gfc_free_actual_arglist (r);
3885 : }
3886 : else
3887 25103 : ap = &((*ap)->next);
3888 : }
3889 8277 : }
3890 :
3891 : #define MAX_SPEC_ARG 12
3892 :
3893 : /* Make up an fn spec that's right for intrinsic functions that we
3894 : want to call. */
3895 :
3896 : static char *
3897 1939 : intrinsic_fnspec (gfc_expr *expr)
3898 : {
3899 1939 : static char fnspec_buf[MAX_SPEC_ARG*2+1];
3900 1939 : char *fp;
3901 1939 : int i;
3902 1939 : int num_char_args;
3903 :
3904 : #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
3905 :
3906 : /* Set the fndecl. */
3907 1939 : fp = fnspec_buf;
3908 : /* Function return value. FIXME: Check if the second letter could
3909 : be something other than a space, for further optimization. */
3910 1939 : ADD_CHAR ('.');
3911 1939 : if (expr->rank == 0)
3912 : {
3913 238 : if (expr->ts.type == BT_CHARACTER)
3914 : {
3915 84 : ADD_CHAR ('w'); /* Address of character. */
3916 84 : ADD_CHAR ('.'); /* Length of character. */
3917 : }
3918 : }
3919 : else
3920 1701 : ADD_CHAR ('w'); /* Return value is a descriptor. */
3921 :
3922 1939 : num_char_args = 0;
3923 10224 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
3924 : {
3925 8285 : if (a->expr == NULL)
3926 2565 : continue;
3927 :
3928 5720 : if (a->name && strcmp (a->name,"%VAL") == 0)
3929 1300 : ADD_CHAR ('.');
3930 : else
3931 : {
3932 4420 : if (a->expr->rank > 0)
3933 2575 : ADD_CHAR ('r');
3934 : else
3935 1845 : ADD_CHAR ('R');
3936 : }
3937 5720 : num_char_args += a->expr->ts.type == BT_CHARACTER;
3938 5720 : gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
3939 : }
3940 :
3941 2743 : for (i = 0; i < num_char_args; i++)
3942 804 : ADD_CHAR ('.');
3943 :
3944 1939 : *fp = '\0';
3945 1939 : return fnspec_buf;
3946 : }
3947 :
3948 : #undef MAX_SPEC_ARG
3949 : #undef ADD_CHAR
3950 :
3951 : /* Generate the right symbol for the specific intrinsic function and
3952 : modify the expr accordingly. This assumes that absent optional
3953 : arguments should be removed. */
3954 :
3955 : gfc_symbol *
3956 8277 : specific_intrinsic_symbol (gfc_expr *expr)
3957 : {
3958 8277 : gfc_symbol *sym;
3959 :
3960 8277 : sym = gfc_find_intrinsic_symbol (expr);
3961 8277 : if (sym == NULL)
3962 : {
3963 1939 : sym = gfc_get_intrinsic_function_symbol (expr);
3964 1939 : sym->ts = expr->ts;
3965 1939 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
3966 240 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
3967 :
3968 1939 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3969 : expr->value.function.actual, true);
3970 1939 : sym->backend_decl
3971 1939 : = gfc_get_extern_function_decl (sym, expr->value.function.actual,
3972 1939 : intrinsic_fnspec (expr));
3973 : }
3974 :
3975 8277 : remove_empty_actual_arguments (&(expr->value.function.actual));
3976 :
3977 8277 : return sym;
3978 : }
3979 :
3980 : /* Generate a call to an external intrinsic function. FIXME: So far,
3981 : this only works for functions which are called with well-defined
3982 : types; CSHIFT and friends will come later. */
3983 :
3984 : static void
3985 13761 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3986 : {
3987 13761 : gfc_symbol *sym;
3988 13761 : vec<tree, va_gc> *append_args;
3989 13761 : bool specific_symbol;
3990 :
3991 13761 : gcc_assert (!se->ss || se->ss->info->expr == expr);
3992 :
3993 13761 : if (se->ss)
3994 11769 : gcc_assert (expr->rank > 0);
3995 : else
3996 1992 : gcc_assert (expr->rank == 0);
3997 :
3998 13761 : switch (expr->value.function.isym->id)
3999 : {
4000 : case GFC_ISYM_ANY:
4001 : case GFC_ISYM_ALL:
4002 : case GFC_ISYM_FINDLOC:
4003 : case GFC_ISYM_MAXLOC:
4004 : case GFC_ISYM_MINLOC:
4005 : case GFC_ISYM_MAXVAL:
4006 : case GFC_ISYM_MINVAL:
4007 : case GFC_ISYM_NORM2:
4008 : case GFC_ISYM_PRODUCT:
4009 : case GFC_ISYM_SUM:
4010 : specific_symbol = true;
4011 : break;
4012 5484 : default:
4013 5484 : specific_symbol = false;
4014 : }
4015 :
4016 13761 : if (specific_symbol)
4017 : {
4018 : /* Need to copy here because specific_intrinsic_symbol modifies
4019 : expr to omit the absent optional arguments. */
4020 8277 : expr = gfc_copy_expr (expr);
4021 8277 : sym = specific_intrinsic_symbol (expr);
4022 : }
4023 : else
4024 5484 : sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
4025 :
4026 : /* Calls to libgfortran_matmul need to be appended special arguments,
4027 : to be able to call the BLAS ?gemm functions if required and possible. */
4028 13761 : append_args = NULL;
4029 13761 : if (expr->value.function.isym->id == GFC_ISYM_MATMUL
4030 860 : && !expr->external_blas
4031 822 : && sym->ts.type != BT_LOGICAL)
4032 : {
4033 806 : tree cint = gfc_get_int_type (gfc_c_int_kind);
4034 :
4035 806 : if (flag_external_blas
4036 0 : && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
4037 0 : && (sym->ts.kind == 4 || sym->ts.kind == 8))
4038 : {
4039 0 : tree gemm_fndecl;
4040 :
4041 0 : if (sym->ts.type == BT_REAL)
4042 : {
4043 0 : if (sym->ts.kind == 4)
4044 0 : gemm_fndecl = gfor_fndecl_sgemm;
4045 : else
4046 0 : gemm_fndecl = gfor_fndecl_dgemm;
4047 : }
4048 : else
4049 : {
4050 0 : if (sym->ts.kind == 4)
4051 0 : gemm_fndecl = gfor_fndecl_cgemm;
4052 : else
4053 0 : gemm_fndecl = gfor_fndecl_zgemm;
4054 : }
4055 :
4056 0 : vec_alloc (append_args, 3);
4057 0 : append_args->quick_push (build_int_cst (cint, 1));
4058 0 : append_args->quick_push (build_int_cst (cint,
4059 0 : flag_blas_matmul_limit));
4060 0 : append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
4061 : gemm_fndecl));
4062 0 : }
4063 : else
4064 : {
4065 806 : vec_alloc (append_args, 3);
4066 806 : append_args->quick_push (build_int_cst (cint, 0));
4067 806 : append_args->quick_push (build_int_cst (cint, 0));
4068 806 : append_args->quick_push (null_pointer_node);
4069 : }
4070 : }
4071 : /* Non-character scalar reduce returns a pointer to a result of size set by
4072 : the element size of 'array'. Setting 'sym' allocatable ensures that the
4073 : result is deallocated at the appropriate time. */
4074 12955 : else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
4075 108 : && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
4076 102 : sym->attr.allocatable = 1;
4077 :
4078 :
4079 13761 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4080 : append_args);
4081 :
4082 13761 : if (specific_symbol)
4083 8277 : gfc_free_expr (expr);
4084 : else
4085 5484 : gfc_free_symbol (sym);
4086 13761 : }
4087 :
4088 : /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4089 : Implemented as
4090 : any(a)
4091 : {
4092 : forall (i=...)
4093 : if (a[i] != 0)
4094 : return 1
4095 : end forall
4096 : return 0
4097 : }
4098 : all(a)
4099 : {
4100 : forall (i=...)
4101 : if (a[i] == 0)
4102 : return 0
4103 : end forall
4104 : return 1
4105 : }
4106 : */
4107 : static void
4108 39165 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4109 : {
4110 39165 : tree resvar;
4111 39165 : stmtblock_t block;
4112 39165 : stmtblock_t body;
4113 39165 : tree type;
4114 39165 : tree tmp;
4115 39165 : tree found;
4116 39165 : gfc_loopinfo loop;
4117 39165 : gfc_actual_arglist *actual;
4118 39165 : gfc_ss *arrayss;
4119 39165 : gfc_se arrayse;
4120 39165 : tree exit_label;
4121 :
4122 39165 : if (se->ss)
4123 : {
4124 0 : gfc_conv_intrinsic_funcall (se, expr);
4125 0 : return;
4126 : }
4127 :
4128 39165 : actual = expr->value.function.actual;
4129 39165 : type = gfc_typenode_for_spec (&expr->ts);
4130 : /* Initialize the result. */
4131 39165 : resvar = gfc_create_var (type, "test");
4132 39165 : if (op == EQ_EXPR)
4133 432 : tmp = convert (type, boolean_true_node);
4134 : else
4135 38733 : tmp = convert (type, boolean_false_node);
4136 39165 : gfc_add_modify (&se->pre, resvar, tmp);
4137 :
4138 : /* Walk the arguments. */
4139 39165 : arrayss = gfc_walk_expr (actual->expr);
4140 39165 : gcc_assert (arrayss != gfc_ss_terminator);
4141 :
4142 : /* Initialize the scalarizer. */
4143 39165 : gfc_init_loopinfo (&loop);
4144 39165 : exit_label = gfc_build_label_decl (NULL_TREE);
4145 39165 : TREE_USED (exit_label) = 1;
4146 39165 : gfc_add_ss_to_loop (&loop, arrayss);
4147 :
4148 : /* Initialize the loop. */
4149 39165 : gfc_conv_ss_startstride (&loop);
4150 39165 : gfc_conv_loop_setup (&loop, &expr->where);
4151 :
4152 39165 : gfc_mark_ss_chain_used (arrayss, 1);
4153 : /* Generate the loop body. */
4154 39165 : gfc_start_scalarized_body (&loop, &body);
4155 :
4156 : /* If the condition matches then set the return value. */
4157 39165 : gfc_start_block (&block);
4158 39165 : if (op == EQ_EXPR)
4159 432 : tmp = convert (type, boolean_false_node);
4160 : else
4161 38733 : tmp = convert (type, boolean_true_node);
4162 39165 : gfc_add_modify (&block, resvar, tmp);
4163 :
4164 : /* And break out of the loop. */
4165 39165 : tmp = build1_v (GOTO_EXPR, exit_label);
4166 39165 : gfc_add_expr_to_block (&block, tmp);
4167 :
4168 39165 : found = gfc_finish_block (&block);
4169 :
4170 : /* Check this element. */
4171 39165 : gfc_init_se (&arrayse, NULL);
4172 39165 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4173 39165 : arrayse.ss = arrayss;
4174 39165 : gfc_conv_expr_val (&arrayse, actual->expr);
4175 :
4176 39165 : gfc_add_block_to_block (&body, &arrayse.pre);
4177 39165 : tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4178 39165 : build_int_cst (TREE_TYPE (arrayse.expr), 0));
4179 39165 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4180 39165 : gfc_add_expr_to_block (&body, tmp);
4181 39165 : gfc_add_block_to_block (&body, &arrayse.post);
4182 :
4183 39165 : gfc_trans_scalarizing_loops (&loop, &body);
4184 :
4185 : /* Add the exit label. */
4186 39165 : tmp = build1_v (LABEL_EXPR, exit_label);
4187 39165 : gfc_add_expr_to_block (&loop.pre, tmp);
4188 :
4189 39165 : gfc_add_block_to_block (&se->pre, &loop.pre);
4190 39165 : gfc_add_block_to_block (&se->pre, &loop.post);
4191 39165 : gfc_cleanup_loop (&loop);
4192 :
4193 39165 : se->expr = resvar;
4194 : }
4195 :
4196 :
4197 : /* Generate the constant 180 / pi, which is used in the conversion
4198 : of acosd(), asind(), atand(), atan2d(). */
4199 :
4200 : static tree
4201 408 : rad2deg (int kind)
4202 : {
4203 408 : tree retval;
4204 408 : mpfr_t pi, t0;
4205 :
4206 408 : gfc_set_model_kind (kind);
4207 408 : mpfr_init (pi);
4208 408 : mpfr_init (t0);
4209 408 : mpfr_set_si (t0, 180, GFC_RND_MODE);
4210 408 : mpfr_const_pi (pi, GFC_RND_MODE);
4211 408 : mpfr_div (t0, t0, pi, GFC_RND_MODE);
4212 408 : retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4213 408 : mpfr_clear (t0);
4214 408 : mpfr_clear (pi);
4215 408 : return retval;
4216 : }
4217 :
4218 :
4219 : static gfc_intrinsic_map_t *
4220 618 : gfc_lookup_intrinsic (gfc_isym_id id)
4221 : {
4222 618 : gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4223 11514 : for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4224 11514 : if (id == m->id)
4225 : break;
4226 618 : gcc_assert (id == m->id);
4227 618 : return m;
4228 : }
4229 :
4230 :
4231 : /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4232 : ASIND(x) is translated into ASIN(x) * 180 / pi.
4233 : ATAND(x) is translated into ATAN(x) * 180 / pi. */
4234 :
4235 : static void
4236 270 : gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4237 : {
4238 270 : tree arg;
4239 270 : tree atrigd;
4240 270 : tree type;
4241 270 : gfc_intrinsic_map_t *m;
4242 :
4243 270 : type = gfc_typenode_for_spec (&expr->ts);
4244 :
4245 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4246 :
4247 270 : switch (id)
4248 : {
4249 90 : case GFC_ISYM_ACOSD:
4250 90 : m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
4251 90 : break;
4252 90 : case GFC_ISYM_ASIND:
4253 90 : m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
4254 90 : break;
4255 90 : case GFC_ISYM_ATAND:
4256 90 : m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
4257 90 : break;
4258 0 : default:
4259 0 : gcc_unreachable ();
4260 : }
4261 270 : atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4262 270 : atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4263 :
4264 270 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4265 : fold_convert (type, rad2deg (expr->ts.kind)));
4266 270 : }
4267 :
4268 :
4269 : /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4270 : COS(X) / SIN(X) for COMPLEX argument. */
4271 :
4272 : static void
4273 102 : gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4274 : {
4275 102 : gfc_intrinsic_map_t *m;
4276 102 : tree arg;
4277 102 : tree type;
4278 :
4279 102 : type = gfc_typenode_for_spec (&expr->ts);
4280 102 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4281 :
4282 102 : if (expr->ts.type == BT_REAL)
4283 : {
4284 102 : tree tan;
4285 102 : tree tmp;
4286 102 : mpfr_t pio2;
4287 :
4288 : /* Create pi/2. */
4289 102 : gfc_set_model_kind (expr->ts.kind);
4290 102 : mpfr_init (pio2);
4291 102 : mpfr_const_pi (pio2, GFC_RND_MODE);
4292 102 : mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4293 102 : tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4294 102 : mpfr_clear (pio2);
4295 :
4296 : /* Find tan builtin function. */
4297 102 : m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
4298 102 : tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4299 102 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4300 102 : tan = build_call_expr_loc (input_location, tan, 1, tmp);
4301 102 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4302 : }
4303 : else
4304 : {
4305 0 : tree sin;
4306 0 : tree cos;
4307 :
4308 : /* Find cos builtin function. */
4309 0 : m = gfc_lookup_intrinsic (GFC_ISYM_COS);
4310 0 : cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4311 0 : cos = build_call_expr_loc (input_location, cos, 1, arg);
4312 :
4313 : /* Find sin builtin function. */
4314 0 : m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
4315 0 : sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4316 0 : sin = build_call_expr_loc (input_location, sin, 1, arg);
4317 :
4318 : /* Divide cos by sin. */
4319 0 : se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4320 : }
4321 102 : }
4322 :
4323 :
4324 : /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4325 :
4326 : static void
4327 108 : gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4328 : {
4329 108 : tree arg;
4330 108 : tree type;
4331 108 : tree ninety_tree;
4332 108 : mpfr_t ninety;
4333 :
4334 108 : type = gfc_typenode_for_spec (&expr->ts);
4335 108 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4336 :
4337 108 : gfc_set_model_kind (expr->ts.kind);
4338 :
4339 : /* Build the tree for x + 90. */
4340 108 : mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4341 108 : ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4342 108 : arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4343 108 : mpfr_clear (ninety);
4344 :
4345 : /* Find tand. */
4346 108 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
4347 108 : tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4348 108 : tand = build_call_expr_loc (input_location, tand, 1, arg);
4349 :
4350 108 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4351 108 : }
4352 :
4353 :
4354 : /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4355 :
4356 : static void
4357 138 : gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4358 : {
4359 138 : tree args[2];
4360 138 : tree atan2d;
4361 138 : tree type;
4362 :
4363 138 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
4364 138 : type = TREE_TYPE (args[0]);
4365 :
4366 138 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
4367 138 : atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4368 138 : atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4369 :
4370 138 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4371 : rad2deg (expr->ts.kind));
4372 138 : }
4373 :
4374 :
4375 : /* COUNT(A) = Number of true elements in A. */
4376 : static void
4377 143 : gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4378 : {
4379 143 : tree resvar;
4380 143 : tree type;
4381 143 : stmtblock_t body;
4382 143 : tree tmp;
4383 143 : gfc_loopinfo loop;
4384 143 : gfc_actual_arglist *actual;
4385 143 : gfc_ss *arrayss;
4386 143 : gfc_se arrayse;
4387 :
4388 143 : if (se->ss)
4389 : {
4390 0 : gfc_conv_intrinsic_funcall (se, expr);
4391 0 : return;
4392 : }
4393 :
4394 143 : actual = expr->value.function.actual;
4395 :
4396 143 : type = gfc_typenode_for_spec (&expr->ts);
4397 : /* Initialize the result. */
4398 143 : resvar = gfc_create_var (type, "count");
4399 143 : gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4400 :
4401 : /* Walk the arguments. */
4402 143 : arrayss = gfc_walk_expr (actual->expr);
4403 143 : gcc_assert (arrayss != gfc_ss_terminator);
4404 :
4405 : /* Initialize the scalarizer. */
4406 143 : gfc_init_loopinfo (&loop);
4407 143 : gfc_add_ss_to_loop (&loop, arrayss);
4408 :
4409 : /* Initialize the loop. */
4410 143 : gfc_conv_ss_startstride (&loop);
4411 143 : gfc_conv_loop_setup (&loop, &expr->where);
4412 :
4413 143 : gfc_mark_ss_chain_used (arrayss, 1);
4414 : /* Generate the loop body. */
4415 143 : gfc_start_scalarized_body (&loop, &body);
4416 :
4417 143 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4418 143 : resvar, build_int_cst (TREE_TYPE (resvar), 1));
4419 143 : tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4420 :
4421 143 : gfc_init_se (&arrayse, NULL);
4422 143 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4423 143 : arrayse.ss = arrayss;
4424 143 : gfc_conv_expr_val (&arrayse, actual->expr);
4425 143 : tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4426 : build_empty_stmt (input_location));
4427 :
4428 143 : gfc_add_block_to_block (&body, &arrayse.pre);
4429 143 : gfc_add_expr_to_block (&body, tmp);
4430 143 : gfc_add_block_to_block (&body, &arrayse.post);
4431 :
4432 143 : gfc_trans_scalarizing_loops (&loop, &body);
4433 :
4434 143 : gfc_add_block_to_block (&se->pre, &loop.pre);
4435 143 : gfc_add_block_to_block (&se->pre, &loop.post);
4436 143 : gfc_cleanup_loop (&loop);
4437 :
4438 143 : se->expr = resvar;
4439 : }
4440 :
4441 :
4442 : /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4443 : struct and return the corresponding loopinfo. */
4444 :
4445 : static gfc_loopinfo *
4446 3374 : enter_nested_loop (gfc_se *se)
4447 : {
4448 3374 : se->ss = se->ss->nested_ss;
4449 3374 : gcc_assert (se->ss == se->ss->loop->ss);
4450 :
4451 3374 : return se->ss->loop;
4452 : }
4453 :
4454 : /* Build the condition for a mask, which may be optional. */
4455 :
4456 : static tree
4457 12763 : conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4458 : bool optional_mask)
4459 : {
4460 12763 : tree present;
4461 12763 : tree type;
4462 :
4463 12763 : if (optional_mask)
4464 : {
4465 206 : type = TREE_TYPE (maskse->expr);
4466 206 : present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4467 206 : present = convert (type, present);
4468 206 : present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4469 : present);
4470 206 : return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4471 206 : type, present, maskse->expr);
4472 : }
4473 : else
4474 12557 : return maskse->expr;
4475 : }
4476 :
4477 : /* Inline implementation of the sum and product intrinsics. */
4478 : static void
4479 2527 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4480 : bool norm2)
4481 : {
4482 2527 : tree resvar;
4483 2527 : tree scale = NULL_TREE;
4484 2527 : tree type;
4485 2527 : stmtblock_t body;
4486 2527 : stmtblock_t block;
4487 2527 : tree tmp;
4488 2527 : gfc_loopinfo loop, *ploop;
4489 2527 : gfc_actual_arglist *arg_array, *arg_mask;
4490 2527 : gfc_ss *arrayss = NULL;
4491 2527 : gfc_ss *maskss = NULL;
4492 2527 : gfc_se arrayse;
4493 2527 : gfc_se maskse;
4494 2527 : gfc_se *parent_se;
4495 2527 : gfc_expr *arrayexpr;
4496 2527 : gfc_expr *maskexpr;
4497 2527 : bool optional_mask;
4498 :
4499 2527 : if (expr->rank > 0)
4500 : {
4501 578 : gcc_assert (gfc_inline_intrinsic_function_p (expr));
4502 : parent_se = se;
4503 : }
4504 : else
4505 : parent_se = NULL;
4506 :
4507 2527 : type = gfc_typenode_for_spec (&expr->ts);
4508 : /* Initialize the result. */
4509 2527 : resvar = gfc_create_var (type, "val");
4510 2527 : if (norm2)
4511 : {
4512 : /* result = 0.0;
4513 : scale = 1.0. */
4514 68 : scale = gfc_create_var (type, "scale");
4515 68 : gfc_add_modify (&se->pre, scale,
4516 : gfc_build_const (type, integer_one_node));
4517 68 : tmp = gfc_build_const (type, integer_zero_node);
4518 : }
4519 2459 : else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4520 2041 : tmp = gfc_build_const (type, integer_zero_node);
4521 418 : else if (op == NE_EXPR)
4522 : /* PARITY. */
4523 36 : tmp = convert (type, boolean_false_node);
4524 382 : else if (op == BIT_AND_EXPR)
4525 24 : tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4526 : type, integer_one_node));
4527 : else
4528 358 : tmp = gfc_build_const (type, integer_one_node);
4529 :
4530 2527 : gfc_add_modify (&se->pre, resvar, tmp);
4531 :
4532 2527 : arg_array = expr->value.function.actual;
4533 :
4534 2527 : arrayexpr = arg_array->expr;
4535 :
4536 2527 : if (op == NE_EXPR || norm2)
4537 : {
4538 : /* PARITY and NORM2. */
4539 : maskexpr = NULL;
4540 : optional_mask = false;
4541 : }
4542 : else
4543 : {
4544 2423 : arg_mask = arg_array->next->next;
4545 2423 : gcc_assert (arg_mask != NULL);
4546 2423 : maskexpr = arg_mask->expr;
4547 371 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4548 266 : && maskexpr->symtree->n.sym->attr.dummy
4549 2441 : && maskexpr->symtree->n.sym->attr.optional;
4550 : }
4551 :
4552 2527 : if (expr->rank == 0)
4553 : {
4554 : /* Walk the arguments. */
4555 1949 : arrayss = gfc_walk_expr (arrayexpr);
4556 1949 : gcc_assert (arrayss != gfc_ss_terminator);
4557 :
4558 1949 : if (maskexpr && maskexpr->rank > 0)
4559 : {
4560 223 : maskss = gfc_walk_expr (maskexpr);
4561 223 : gcc_assert (maskss != gfc_ss_terminator);
4562 : }
4563 : else
4564 : maskss = NULL;
4565 :
4566 : /* Initialize the scalarizer. */
4567 1949 : gfc_init_loopinfo (&loop);
4568 :
4569 : /* We add the mask first because the number of iterations is
4570 : taken from the last ss, and this breaks if an absent
4571 : optional argument is used for mask. */
4572 :
4573 1949 : if (maskexpr && maskexpr->rank > 0)
4574 223 : gfc_add_ss_to_loop (&loop, maskss);
4575 1949 : gfc_add_ss_to_loop (&loop, arrayss);
4576 :
4577 : /* Initialize the loop. */
4578 1949 : gfc_conv_ss_startstride (&loop);
4579 1949 : gfc_conv_loop_setup (&loop, &expr->where);
4580 :
4581 1949 : if (maskexpr && maskexpr->rank > 0)
4582 223 : gfc_mark_ss_chain_used (maskss, 1);
4583 1949 : gfc_mark_ss_chain_used (arrayss, 1);
4584 :
4585 1949 : ploop = &loop;
4586 : }
4587 : else
4588 : /* All the work has been done in the parent loops. */
4589 578 : ploop = enter_nested_loop (se);
4590 :
4591 2527 : gcc_assert (ploop);
4592 :
4593 : /* Generate the loop body. */
4594 2527 : gfc_start_scalarized_body (ploop, &body);
4595 :
4596 : /* If we have a mask, only add this element if the mask is set. */
4597 2527 : if (maskexpr && maskexpr->rank > 0)
4598 : {
4599 307 : gfc_init_se (&maskse, parent_se);
4600 307 : gfc_copy_loopinfo_to_se (&maskse, ploop);
4601 307 : if (expr->rank == 0)
4602 223 : maskse.ss = maskss;
4603 307 : gfc_conv_expr_val (&maskse, maskexpr);
4604 307 : gfc_add_block_to_block (&body, &maskse.pre);
4605 :
4606 307 : gfc_start_block (&block);
4607 : }
4608 : else
4609 2220 : gfc_init_block (&block);
4610 :
4611 : /* Do the actual summation/product. */
4612 2527 : gfc_init_se (&arrayse, parent_se);
4613 2527 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
4614 2527 : if (expr->rank == 0)
4615 1949 : arrayse.ss = arrayss;
4616 2527 : gfc_conv_expr_val (&arrayse, arrayexpr);
4617 2527 : gfc_add_block_to_block (&block, &arrayse.pre);
4618 :
4619 2527 : if (norm2)
4620 : {
4621 : /* if (x (i) != 0.0)
4622 : {
4623 : absX = abs(x(i))
4624 : if (absX > scale)
4625 : {
4626 : val = scale/absX;
4627 : result = 1.0 + result * val * val;
4628 : scale = absX;
4629 : }
4630 : else
4631 : {
4632 : val = absX/scale;
4633 : result += val * val;
4634 : }
4635 : } */
4636 68 : tree res1, res2, cond, absX, val;
4637 68 : stmtblock_t ifblock1, ifblock2, ifblock3;
4638 :
4639 68 : gfc_init_block (&ifblock1);
4640 :
4641 68 : absX = gfc_create_var (type, "absX");
4642 68 : gfc_add_modify (&ifblock1, absX,
4643 : fold_build1_loc (input_location, ABS_EXPR, type,
4644 : arrayse.expr));
4645 68 : val = gfc_create_var (type, "val");
4646 68 : gfc_add_expr_to_block (&ifblock1, val);
4647 :
4648 68 : gfc_init_block (&ifblock2);
4649 68 : gfc_add_modify (&ifblock2, val,
4650 : fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4651 : absX));
4652 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4653 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4654 68 : res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4655 : gfc_build_const (type, integer_one_node));
4656 68 : gfc_add_modify (&ifblock2, resvar, res1);
4657 68 : gfc_add_modify (&ifblock2, scale, absX);
4658 68 : res1 = gfc_finish_block (&ifblock2);
4659 :
4660 68 : gfc_init_block (&ifblock3);
4661 68 : gfc_add_modify (&ifblock3, val,
4662 : fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4663 : scale));
4664 68 : res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4665 68 : res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4666 68 : gfc_add_modify (&ifblock3, resvar, res2);
4667 68 : res2 = gfc_finish_block (&ifblock3);
4668 :
4669 68 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4670 : absX, scale);
4671 68 : tmp = build3_v (COND_EXPR, cond, res1, res2);
4672 68 : gfc_add_expr_to_block (&ifblock1, tmp);
4673 68 : tmp = gfc_finish_block (&ifblock1);
4674 :
4675 68 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4676 : arrayse.expr,
4677 : gfc_build_const (type, integer_zero_node));
4678 :
4679 68 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4680 68 : gfc_add_expr_to_block (&block, tmp);
4681 : }
4682 : else
4683 : {
4684 2459 : tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4685 2459 : gfc_add_modify (&block, resvar, tmp);
4686 : }
4687 :
4688 2527 : gfc_add_block_to_block (&block, &arrayse.post);
4689 :
4690 2527 : if (maskexpr && maskexpr->rank > 0)
4691 : {
4692 : /* We enclose the above in if (mask) {...} . If the mask is an
4693 : optional argument, generate
4694 : IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4695 307 : tree ifmask;
4696 307 : tmp = gfc_finish_block (&block);
4697 307 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4698 307 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4699 : build_empty_stmt (input_location));
4700 307 : }
4701 : else
4702 2220 : tmp = gfc_finish_block (&block);
4703 2527 : gfc_add_expr_to_block (&body, tmp);
4704 :
4705 2527 : gfc_trans_scalarizing_loops (ploop, &body);
4706 :
4707 : /* For a scalar mask, enclose the loop in an if statement. */
4708 2527 : if (maskexpr && maskexpr->rank == 0)
4709 : {
4710 64 : gfc_init_block (&block);
4711 64 : gfc_add_block_to_block (&block, &ploop->pre);
4712 64 : gfc_add_block_to_block (&block, &ploop->post);
4713 64 : tmp = gfc_finish_block (&block);
4714 :
4715 64 : if (expr->rank > 0)
4716 : {
4717 34 : tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4718 : build_empty_stmt (input_location));
4719 34 : gfc_advance_se_ss_chain (se);
4720 : }
4721 : else
4722 : {
4723 30 : tree ifmask;
4724 :
4725 30 : gcc_assert (expr->rank == 0);
4726 30 : gfc_init_se (&maskse, NULL);
4727 30 : gfc_conv_expr_val (&maskse, maskexpr);
4728 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4729 30 : tmp = build3_v (COND_EXPR, ifmask, tmp,
4730 : build_empty_stmt (input_location));
4731 : }
4732 :
4733 64 : gfc_add_expr_to_block (&block, tmp);
4734 64 : gfc_add_block_to_block (&se->pre, &block);
4735 64 : gcc_assert (se->post.head == NULL);
4736 : }
4737 : else
4738 : {
4739 2463 : gfc_add_block_to_block (&se->pre, &ploop->pre);
4740 2463 : gfc_add_block_to_block (&se->pre, &ploop->post);
4741 : }
4742 :
4743 2527 : if (expr->rank == 0)
4744 1949 : gfc_cleanup_loop (ploop);
4745 :
4746 2527 : if (norm2)
4747 : {
4748 : /* result = scale * sqrt(result). */
4749 68 : tree sqrt;
4750 68 : sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4751 68 : resvar = build_call_expr_loc (input_location,
4752 : sqrt, 1, resvar);
4753 68 : resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4754 : }
4755 :
4756 2527 : se->expr = resvar;
4757 2527 : }
4758 :
4759 :
4760 : /* Inline implementation of the dot_product intrinsic. This function
4761 : is based on gfc_conv_intrinsic_arith (the previous function). */
4762 : static void
4763 113 : gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4764 : {
4765 113 : tree resvar;
4766 113 : tree type;
4767 113 : stmtblock_t body;
4768 113 : stmtblock_t block;
4769 113 : tree tmp;
4770 113 : gfc_loopinfo loop;
4771 113 : gfc_actual_arglist *actual;
4772 113 : gfc_ss *arrayss1, *arrayss2;
4773 113 : gfc_se arrayse1, arrayse2;
4774 113 : gfc_expr *arrayexpr1, *arrayexpr2;
4775 :
4776 113 : type = gfc_typenode_for_spec (&expr->ts);
4777 :
4778 : /* Initialize the result. */
4779 113 : resvar = gfc_create_var (type, "val");
4780 113 : if (expr->ts.type == BT_LOGICAL)
4781 30 : tmp = build_int_cst (type, 0);
4782 : else
4783 83 : tmp = gfc_build_const (type, integer_zero_node);
4784 :
4785 113 : gfc_add_modify (&se->pre, resvar, tmp);
4786 :
4787 : /* Walk argument #1. */
4788 113 : actual = expr->value.function.actual;
4789 113 : arrayexpr1 = actual->expr;
4790 113 : arrayss1 = gfc_walk_expr (arrayexpr1);
4791 113 : gcc_assert (arrayss1 != gfc_ss_terminator);
4792 :
4793 : /* Walk argument #2. */
4794 113 : actual = actual->next;
4795 113 : arrayexpr2 = actual->expr;
4796 113 : arrayss2 = gfc_walk_expr (arrayexpr2);
4797 113 : gcc_assert (arrayss2 != gfc_ss_terminator);
4798 :
4799 : /* Initialize the scalarizer. */
4800 113 : gfc_init_loopinfo (&loop);
4801 113 : gfc_add_ss_to_loop (&loop, arrayss1);
4802 113 : gfc_add_ss_to_loop (&loop, arrayss2);
4803 :
4804 : /* Initialize the loop. */
4805 113 : gfc_conv_ss_startstride (&loop);
4806 113 : gfc_conv_loop_setup (&loop, &expr->where);
4807 :
4808 113 : gfc_mark_ss_chain_used (arrayss1, 1);
4809 113 : gfc_mark_ss_chain_used (arrayss2, 1);
4810 :
4811 : /* Generate the loop body. */
4812 113 : gfc_start_scalarized_body (&loop, &body);
4813 113 : gfc_init_block (&block);
4814 :
4815 : /* Make the tree expression for [conjg(]array1[)]. */
4816 113 : gfc_init_se (&arrayse1, NULL);
4817 113 : gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4818 113 : arrayse1.ss = arrayss1;
4819 113 : gfc_conv_expr_val (&arrayse1, arrayexpr1);
4820 113 : if (expr->ts.type == BT_COMPLEX)
4821 9 : arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4822 : arrayse1.expr);
4823 113 : gfc_add_block_to_block (&block, &arrayse1.pre);
4824 :
4825 : /* Make the tree expression for array2. */
4826 113 : gfc_init_se (&arrayse2, NULL);
4827 113 : gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4828 113 : arrayse2.ss = arrayss2;
4829 113 : gfc_conv_expr_val (&arrayse2, arrayexpr2);
4830 113 : gfc_add_block_to_block (&block, &arrayse2.pre);
4831 :
4832 : /* Do the actual product and sum. */
4833 113 : if (expr->ts.type == BT_LOGICAL)
4834 : {
4835 30 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4836 : arrayse1.expr, arrayse2.expr);
4837 30 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4838 : }
4839 : else
4840 : {
4841 83 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4842 : arrayse2.expr);
4843 83 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4844 : }
4845 113 : gfc_add_modify (&block, resvar, tmp);
4846 :
4847 : /* Finish up the loop block and the loop. */
4848 113 : tmp = gfc_finish_block (&block);
4849 113 : gfc_add_expr_to_block (&body, tmp);
4850 :
4851 113 : gfc_trans_scalarizing_loops (&loop, &body);
4852 113 : gfc_add_block_to_block (&se->pre, &loop.pre);
4853 113 : gfc_add_block_to_block (&se->pre, &loop.post);
4854 113 : gfc_cleanup_loop (&loop);
4855 :
4856 113 : se->expr = resvar;
4857 113 : }
4858 :
4859 :
4860 : /* Tells whether the expression E is a reference to an optional variable whose
4861 : presence is not known at compile time. Those are variable references without
4862 : subreference; if there is a subreference, we can assume the variable is
4863 : present. We have to special case full arrays, which we represent with a fake
4864 : "full" reference, and class descriptors for which a reference to data is not
4865 : really a subreference. */
4866 :
4867 : bool
4868 14613 : maybe_absent_optional_variable (gfc_expr *e)
4869 : {
4870 14613 : if (!(e && e->expr_type == EXPR_VARIABLE))
4871 : return false;
4872 :
4873 1716 : gfc_symbol *sym = e->symtree->n.sym;
4874 1716 : if (!sym->attr.optional)
4875 : return false;
4876 :
4877 224 : gfc_ref *ref = e->ref;
4878 224 : if (ref == nullptr)
4879 : return true;
4880 :
4881 20 : if (ref->type == REF_ARRAY
4882 20 : && ref->u.ar.type == AR_FULL
4883 20 : && ref->next == nullptr)
4884 : return true;
4885 :
4886 0 : if (!(sym->ts.type == BT_CLASS
4887 0 : && ref->type == REF_COMPONENT
4888 0 : && ref->u.c.component == CLASS_DATA (sym)))
4889 : return false;
4890 :
4891 0 : gfc_ref *next_ref = ref->next;
4892 0 : if (next_ref == nullptr)
4893 : return true;
4894 :
4895 0 : if (next_ref->type == REF_ARRAY
4896 0 : && next_ref->u.ar.type == AR_FULL
4897 0 : && next_ref->next == nullptr)
4898 0 : return true;
4899 :
4900 : return false;
4901 : }
4902 :
4903 :
4904 : /* Emit code for minloc or maxloc intrinsic. There are many different cases
4905 : we need to handle. For performance reasons we sometimes create two
4906 : loops instead of one, where the second one is much simpler.
4907 : Examples for minloc intrinsic:
4908 : A: Result is scalar.
4909 : 1) Array mask is used and NaNs need to be supported:
4910 : limit = Infinity;
4911 : pos = 0;
4912 : S = from;
4913 : while (S <= to) {
4914 : if (mask[S]) {
4915 : if (pos == 0) pos = S + (1 - from);
4916 : if (a[S] <= limit) {
4917 : limit = a[S];
4918 : pos = S + (1 - from);
4919 : goto lab1;
4920 : }
4921 : }
4922 : S++;
4923 : }
4924 : goto lab2;
4925 : lab1:;
4926 : while (S <= to) {
4927 : if (mask[S])
4928 : if (a[S] < limit) {
4929 : limit = a[S];
4930 : pos = S + (1 - from);
4931 : }
4932 : S++;
4933 : }
4934 : lab2:;
4935 : 2) NaNs need to be supported, but it is known at compile time or cheaply
4936 : at runtime whether array is nonempty or not:
4937 : limit = Infinity;
4938 : pos = 0;
4939 : S = from;
4940 : while (S <= to) {
4941 : if (a[S] <= limit) {
4942 : limit = a[S];
4943 : pos = S + (1 - from);
4944 : goto lab1;
4945 : }
4946 : S++;
4947 : }
4948 : if (from <= to) pos = 1;
4949 : goto lab2;
4950 : lab1:;
4951 : while (S <= to) {
4952 : if (a[S] < limit) {
4953 : limit = a[S];
4954 : pos = S + (1 - from);
4955 : }
4956 : S++;
4957 : }
4958 : lab2:;
4959 : 3) NaNs aren't supported, array mask is used:
4960 : limit = infinities_supported ? Infinity : huge (limit);
4961 : pos = 0;
4962 : S = from;
4963 : while (S <= to) {
4964 : if (mask[S]) {
4965 : limit = a[S];
4966 : pos = S + (1 - from);
4967 : goto lab1;
4968 : }
4969 : S++;
4970 : }
4971 : goto lab2;
4972 : lab1:;
4973 : while (S <= to) {
4974 : if (mask[S])
4975 : if (a[S] < limit) {
4976 : limit = a[S];
4977 : pos = S + (1 - from);
4978 : }
4979 : S++;
4980 : }
4981 : lab2:;
4982 : 4) Same without array mask:
4983 : limit = infinities_supported ? Infinity : huge (limit);
4984 : pos = (from <= to) ? 1 : 0;
4985 : S = from;
4986 : while (S <= to) {
4987 : if (a[S] < limit) {
4988 : limit = a[S];
4989 : pos = S + (1 - from);
4990 : }
4991 : S++;
4992 : }
4993 : B: Array result, non-CHARACTER type, DIM absent
4994 : Generate similar code as in the scalar case, using a collection of
4995 : variables (one per dimension) instead of a single variable as result.
4996 : Picking only cases 1) and 4) with ARRAY of rank 2, the generated code
4997 : becomes:
4998 : 1) Array mask is used and NaNs need to be supported:
4999 : limit = Infinity;
5000 : pos0 = 0;
5001 : pos1 = 0;
5002 : S1 = from1;
5003 : second_loop_entry = false;
5004 : while (S1 <= to1) {
5005 : S0 = from0;
5006 : while (s0 <= to0 {
5007 : if (mask[S1][S0]) {
5008 : if (pos0 == 0) {
5009 : pos0 = S0 + (1 - from0);
5010 : pos1 = S1 + (1 - from1);
5011 : }
5012 : if (a[S1][S0] <= limit) {
5013 : limit = a[S1][S0];
5014 : pos0 = S0 + (1 - from0);
5015 : pos1 = S1 + (1 - from1);
5016 : second_loop_entry = true;
5017 : goto lab1;
5018 : }
5019 : }
5020 : S0++;
5021 : }
5022 : S1++;
5023 : }
5024 : goto lab2;
5025 : lab1:;
5026 : S1 = second_loop_entry ? S1 : from1;
5027 : while (S1 <= to1) {
5028 : S0 = second_loop_entry ? S0 : from0;
5029 : while (S0 <= to0) {
5030 : if (mask[S1][S0])
5031 : if (a[S1][S0] < limit) {
5032 : limit = a[S1][S0];
5033 : pos0 = S + (1 - from0);
5034 : pos1 = S + (1 - from1);
5035 : }
5036 : second_loop_entry = false;
5037 : S0++;
5038 : }
5039 : S1++;
5040 : }
5041 : lab2:;
5042 : result = { pos0, pos1 };
5043 : ...
5044 : 4) NANs aren't supported, no array mask.
5045 : limit = infinities_supported ? Infinity : huge (limit);
5046 : pos0 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
5047 : pos1 = (from0 <= to0 && from1 <= to1) ? 1 : 0;
5048 : S1 = from1;
5049 : while (S1 <= to1) {
5050 : S0 = from0;
5051 : while (S0 <= to0) {
5052 : if (a[S1][S0] < limit) {
5053 : limit = a[S1][S0];
5054 : pos0 = S + (1 - from0);
5055 : pos1 = S + (1 - from1);
5056 : }
5057 : S0++;
5058 : }
5059 : S1++;
5060 : }
5061 : result = { pos0, pos1 };
5062 : C: Otherwise, a call is generated.
5063 : For 2) and 4), if mask is scalar, this all goes into a conditional,
5064 : setting pos = 0; in the else branch.
5065 :
5066 : Since we now also support the BACK argument, instead of using
5067 : if (a[S] < limit), we now use
5068 :
5069 : if (back)
5070 : cond = a[S] <= limit;
5071 : else
5072 : cond = a[S] < limit;
5073 : if (cond) {
5074 : ....
5075 :
5076 : The optimizer is smart enough to move the condition out of the loop.
5077 : They are now marked as unlikely too for further speedup. */
5078 :
5079 : static void
5080 18898 : gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5081 : {
5082 18898 : stmtblock_t body;
5083 18898 : stmtblock_t block;
5084 18898 : stmtblock_t ifblock;
5085 18898 : stmtblock_t elseblock;
5086 18898 : tree limit;
5087 18898 : tree type;
5088 18898 : tree tmp;
5089 18898 : tree cond;
5090 18898 : tree elsetmp;
5091 18898 : tree ifbody;
5092 18898 : tree offset[GFC_MAX_DIMENSIONS];
5093 18898 : tree nonempty;
5094 18898 : tree lab1, lab2;
5095 18898 : tree b_if, b_else;
5096 18898 : tree back;
5097 18898 : gfc_loopinfo loop, *ploop;
5098 18898 : gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg;
5099 18898 : gfc_actual_arglist *back_arg;
5100 18898 : gfc_ss *arrayss = nullptr;
5101 18898 : gfc_ss *maskss = nullptr;
5102 18898 : gfc_ss *orig_ss = nullptr;
5103 18898 : gfc_se arrayse;
5104 18898 : gfc_se maskse;
5105 18898 : gfc_se nested_se;
5106 18898 : gfc_se *base_se;
5107 18898 : gfc_expr *arrayexpr;
5108 18898 : gfc_expr *maskexpr;
5109 18898 : gfc_expr *backexpr;
5110 18898 : gfc_se backse;
5111 18898 : tree pos[GFC_MAX_DIMENSIONS];
5112 18898 : tree idx[GFC_MAX_DIMENSIONS];
5113 18898 : tree result_var = NULL_TREE;
5114 18898 : int n;
5115 18898 : bool optional_mask;
5116 :
5117 18898 : array_arg = expr->value.function.actual;
5118 18898 : dim_arg = array_arg->next;
5119 18898 : mask_arg = dim_arg->next;
5120 18898 : kind_arg = mask_arg->next;
5121 18898 : back_arg = kind_arg->next;
5122 :
5123 18898 : bool dim_present = dim_arg->expr != nullptr;
5124 18898 : bool nested_loop = dim_present && expr->rank > 0;
5125 :
5126 : /* Remove kind. */
5127 18898 : if (kind_arg->expr)
5128 : {
5129 2240 : gfc_free_expr (kind_arg->expr);
5130 2240 : kind_arg->expr = NULL;
5131 : }
5132 :
5133 : /* Pass BACK argument by value. */
5134 18898 : back_arg->name = "%VAL";
5135 :
5136 18898 : if (se->ss)
5137 : {
5138 14732 : if (se->ss->info->useflags)
5139 : {
5140 7671 : if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
5141 : {
5142 : /* The code generating and initializing the result array has been
5143 : generated already before the scalarization loop, either with a
5144 : library function call or with inline code; now we can just use
5145 : the result. */
5146 4875 : gfc_conv_tmp_array_ref (se);
5147 13822 : return;
5148 : }
5149 : }
5150 7061 : else if (!gfc_inline_intrinsic_function_p (expr))
5151 : {
5152 3780 : gfc_conv_intrinsic_funcall (se, expr);
5153 3780 : return;
5154 : }
5155 : }
5156 :
5157 10243 : arrayexpr = array_arg->expr;
5158 :
5159 : /* Special case for character maxloc. Remove unneeded "dim" actual
5160 : argument, then call a library function. */
5161 :
5162 10243 : if (arrayexpr->ts.type == BT_CHARACTER)
5163 : {
5164 292 : gcc_assert (expr->rank == 0);
5165 :
5166 292 : if (dim_arg->expr)
5167 : {
5168 292 : gfc_free_expr (dim_arg->expr);
5169 292 : dim_arg->expr = NULL;
5170 : }
5171 292 : gfc_conv_intrinsic_funcall (se, expr);
5172 292 : return;
5173 : }
5174 :
5175 9951 : type = gfc_typenode_for_spec (&expr->ts);
5176 :
5177 9951 : if (expr->rank > 0 && !dim_present)
5178 : {
5179 3281 : gfc_array_spec as;
5180 3281 : memset (&as, 0, sizeof (as));
5181 :
5182 3281 : as.rank = 1;
5183 3281 : as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
5184 : &arrayexpr->where,
5185 : HOST_WIDE_INT_1);
5186 6562 : as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind,
5187 : &arrayexpr->where,
5188 3281 : arrayexpr->rank);
5189 :
5190 3281 : tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
5191 :
5192 3281 : result_var = gfc_create_var (array, "loc_result");
5193 : }
5194 :
5195 7155 : const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
5196 :
5197 : /* Initialize the result. */
5198 22177 : for (int i = 0; i < reduction_dimensions; i++)
5199 : {
5200 12226 : pos[i] = gfc_create_var (gfc_array_index_type,
5201 : gfc_get_string ("pos%d", i));
5202 12226 : offset[i] = gfc_create_var (gfc_array_index_type,
5203 : gfc_get_string ("offset%d", i));
5204 12226 : idx[i] = gfc_create_var (gfc_array_index_type,
5205 : gfc_get_string ("idx%d", i));
5206 : }
5207 :
5208 9951 : maskexpr = mask_arg->expr;
5209 6518 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5210 5329 : && maskexpr->symtree->n.sym->attr.dummy
5211 10116 : && maskexpr->symtree->n.sym->attr.optional;
5212 9951 : backexpr = back_arg->expr;
5213 :
5214 17106 : gfc_init_se (&backse, nested_loop ? se : nullptr);
5215 9951 : if (backexpr == nullptr)
5216 0 : back = logical_false_node;
5217 9951 : else if (maybe_absent_optional_variable (backexpr))
5218 : {
5219 : /* This should have been checked already by
5220 : maybe_absent_optional_variable. */
5221 184 : gcc_checking_assert (backexpr->expr_type == EXPR_VARIABLE);
5222 :
5223 184 : gfc_conv_expr (&backse, backexpr);
5224 184 : tree present = gfc_conv_expr_present (backexpr->symtree->n.sym, false);
5225 184 : back = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5226 : logical_type_node, present, backse.expr);
5227 : }
5228 : else
5229 : {
5230 9767 : gfc_conv_expr (&backse, backexpr);
5231 9767 : back = backse.expr;
5232 : }
5233 9951 : gfc_add_block_to_block (&se->pre, &backse.pre);
5234 9951 : back = gfc_evaluate_now_loc (input_location, back, &se->pre);
5235 9951 : gfc_add_block_to_block (&se->pre, &backse.post);
5236 :
5237 9951 : if (nested_loop)
5238 : {
5239 2796 : gfc_init_se (&nested_se, se);
5240 2796 : base_se = &nested_se;
5241 : }
5242 : else
5243 : {
5244 : /* Walk the arguments. */
5245 7155 : arrayss = gfc_walk_expr (arrayexpr);
5246 7155 : gcc_assert (arrayss != gfc_ss_terminator);
5247 :
5248 7155 : if (maskexpr && maskexpr->rank != 0)
5249 : {
5250 2700 : maskss = gfc_walk_expr (maskexpr);
5251 2700 : gcc_assert (maskss != gfc_ss_terminator);
5252 : }
5253 :
5254 : base_se = nullptr;
5255 : }
5256 :
5257 18091 : nonempty = nullptr;
5258 7448 : if (!(maskexpr && maskexpr->rank > 0))
5259 : {
5260 6077 : mpz_t asize;
5261 6077 : bool reduction_size_known;
5262 :
5263 6077 : if (dim_present)
5264 : {
5265 4032 : int reduction_dim;
5266 4032 : if (dim_arg->expr->expr_type == EXPR_CONSTANT)
5267 4030 : reduction_dim = mpz_get_si (dim_arg->expr->value.integer) - 1;
5268 2 : else if (arrayexpr->rank == 1)
5269 : reduction_dim = 0;
5270 : else
5271 0 : gcc_unreachable ();
5272 4032 : reduction_size_known = gfc_array_dimen_size (arrayexpr, reduction_dim,
5273 : &asize);
5274 : }
5275 : else
5276 2045 : reduction_size_known = gfc_array_size (arrayexpr, &asize);
5277 :
5278 6077 : if (reduction_size_known)
5279 : {
5280 4482 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5281 4482 : mpz_clear (asize);
5282 4482 : nonempty = fold_build2_loc (input_location, GT_EXPR,
5283 : logical_type_node, nonempty,
5284 : gfc_index_zero_node);
5285 : }
5286 6077 : maskss = NULL;
5287 : }
5288 :
5289 9951 : limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5290 9951 : switch (arrayexpr->ts.type)
5291 : {
5292 3898 : case BT_REAL:
5293 3898 : tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5294 3898 : break;
5295 :
5296 6029 : case BT_INTEGER:
5297 6029 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5298 6029 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5299 : arrayexpr->ts.kind);
5300 6029 : break;
5301 :
5302 24 : case BT_UNSIGNED:
5303 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
5304 24 : if (op == GT_EXPR)
5305 : {
5306 12 : tmp = gfc_get_unsigned_type (arrayexpr->ts.kind);
5307 12 : tmp = build_int_cst (tmp, 0);
5308 : }
5309 : else
5310 : {
5311 12 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5312 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
5313 : expr->ts.kind);
5314 : }
5315 : break;
5316 :
5317 0 : default:
5318 0 : gcc_unreachable ();
5319 : }
5320 :
5321 : /* We start with the most negative possible value for MAXLOC, and the most
5322 : positive possible value for MINLOC. The most negative possible value is
5323 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5324 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
5325 : with above. */
5326 9951 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
5327 4724 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5328 4724 : if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5329 2914 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5330 2914 : build_int_cst (TREE_TYPE (tmp), 1));
5331 :
5332 9951 : gfc_add_modify (&se->pre, limit, tmp);
5333 :
5334 : /* If we are in a case where we generate two sets of loops, the second one
5335 : should continue where the first stopped instead of restarting from the
5336 : beginning. So nested loops in the second set should have a partial range
5337 : on the first iteration, but they should start from the beginning and span
5338 : their full range on the following iterations. So we use conditionals in
5339 : the loops lower bounds, and use the following variable in those
5340 : conditionals to decide whether to use the original loop bound or to use
5341 : the index at which the loop from the first set stopped. */
5342 9951 : tree second_loop_entry = gfc_create_var (logical_type_node,
5343 : "second_loop_entry");
5344 9951 : gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
5345 :
5346 9951 : if (nested_loop)
5347 : {
5348 2796 : ploop = enter_nested_loop (&nested_se);
5349 2796 : orig_ss = nested_se.ss;
5350 2796 : ploop->temp_dim = 1;
5351 : }
5352 : else
5353 : {
5354 : /* Initialize the scalarizer. */
5355 7155 : gfc_init_loopinfo (&loop);
5356 :
5357 : /* We add the mask first because the number of iterations is taken
5358 : from the last ss, and this breaks if an absent optional argument
5359 : is used for mask. */
5360 :
5361 7155 : if (maskss)
5362 2700 : gfc_add_ss_to_loop (&loop, maskss);
5363 :
5364 7155 : gfc_add_ss_to_loop (&loop, arrayss);
5365 :
5366 : /* Initialize the loop. */
5367 7155 : gfc_conv_ss_startstride (&loop);
5368 :
5369 : /* The code generated can have more than one loop in sequence (see the
5370 : comment at the function header). This doesn't work well with the
5371 : scalarizer, which changes arrays' offset when the scalarization loops
5372 : are generated (see gfc_trans_preloop_setup). Fortunately, we can use
5373 : the scalarizer temporary code to handle multiple loops. Thus, we set
5374 : temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
5375 : we use gfc_trans_scalarized_loop_boundary even later to restore
5376 : offset. */
5377 7155 : loop.temp_dim = loop.dimen;
5378 7155 : gfc_conv_loop_setup (&loop, &expr->where);
5379 :
5380 7155 : ploop = &loop;
5381 : }
5382 :
5383 9951 : gcc_assert (reduction_dimensions == ploop->dimen);
5384 :
5385 9951 : if (nonempty == NULL && !(maskexpr && maskexpr->rank > 0))
5386 : {
5387 1595 : nonempty = logical_true_node;
5388 :
5389 3697 : for (int i = 0; i < ploop->dimen; i++)
5390 : {
5391 2102 : if (!(ploop->from[i] && ploop->to[i]))
5392 : {
5393 : nonempty = NULL;
5394 : break;
5395 : }
5396 :
5397 2102 : tree tmp = fold_build2_loc (input_location, LE_EXPR,
5398 : logical_type_node, ploop->from[i],
5399 : ploop->to[i]);
5400 :
5401 2102 : nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5402 : logical_type_node, nonempty, tmp);
5403 : }
5404 : }
5405 :
5406 11546 : lab1 = NULL;
5407 11546 : lab2 = NULL;
5408 : /* Initialize the position to zero, following Fortran 2003. We are free
5409 : to do this because Fortran 95 allows the result of an entirely false
5410 : mask to be processor dependent. If we know at compile time the array
5411 : is non-empty and no MASK is used, we can initialize to 1 to simplify
5412 : the inner loop. */
5413 9951 : if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5414 : {
5415 3748 : tree init = fold_build3_loc (input_location, COND_EXPR,
5416 : gfc_array_index_type, nonempty,
5417 : gfc_index_one_node,
5418 : gfc_index_zero_node);
5419 12178 : for (int i = 0; i < ploop->dimen; i++)
5420 4682 : gfc_add_modify (&ploop->pre, pos[i], init);
5421 : }
5422 : else
5423 : {
5424 13747 : for (int i = 0; i < ploop->dimen; i++)
5425 7544 : gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node);
5426 6203 : lab1 = gfc_build_label_decl (NULL_TREE);
5427 6203 : TREE_USED (lab1) = 1;
5428 6203 : lab2 = gfc_build_label_decl (NULL_TREE);
5429 6203 : TREE_USED (lab2) = 1;
5430 : }
5431 :
5432 : /* An offset must be added to the loop
5433 : counter to obtain the required position. */
5434 22177 : for (int i = 0; i < ploop->dimen; i++)
5435 : {
5436 12226 : gcc_assert (ploop->from[i]);
5437 :
5438 12226 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5439 : gfc_index_one_node, ploop->from[i]);
5440 12226 : gfc_add_modify (&ploop->pre, offset[i], tmp);
5441 : }
5442 :
5443 9951 : if (!nested_loop)
5444 : {
5445 9965 : gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5446 7155 : if (maskss)
5447 2700 : gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5448 : }
5449 :
5450 : /* Generate the loop body. */
5451 9951 : gfc_start_scalarized_body (ploop, &body);
5452 :
5453 : /* If we have a mask, only check this element if the mask is set. */
5454 9951 : if (maskexpr && maskexpr->rank > 0)
5455 : {
5456 3874 : gfc_init_se (&maskse, base_se);
5457 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5458 3874 : if (!nested_loop)
5459 2700 : maskse.ss = maskss;
5460 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5461 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5462 :
5463 3874 : gfc_start_block (&block);
5464 : }
5465 : else
5466 6077 : gfc_init_block (&block);
5467 :
5468 : /* Compare with the current limit. */
5469 9951 : gfc_init_se (&arrayse, base_se);
5470 9951 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5471 9951 : if (!nested_loop)
5472 7155 : arrayse.ss = arrayss;
5473 9951 : gfc_conv_expr_val (&arrayse, arrayexpr);
5474 9951 : gfc_add_block_to_block (&block, &arrayse.pre);
5475 :
5476 : /* We do the following if this is a more extreme value. */
5477 9951 : gfc_start_block (&ifblock);
5478 :
5479 : /* Assign the value to the limit... */
5480 9951 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5481 :
5482 9951 : if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5483 : {
5484 1569 : stmtblock_t ifblock2;
5485 1569 : tree ifbody2;
5486 :
5487 1569 : gfc_start_block (&ifblock2);
5488 5008 : for (int i = 0; i < ploop->dimen; i++)
5489 : {
5490 1870 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5491 : ploop->loopvar[i], offset[i]);
5492 1870 : gfc_add_modify (&ifblock2, pos[i], tmp);
5493 : }
5494 1569 : ifbody2 = gfc_finish_block (&ifblock2);
5495 :
5496 1569 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5497 : pos[0], gfc_index_zero_node);
5498 1569 : tmp = build3_v (COND_EXPR, cond, ifbody2,
5499 : build_empty_stmt (input_location));
5500 1569 : gfc_add_expr_to_block (&block, tmp);
5501 : }
5502 :
5503 22177 : for (int i = 0; i < ploop->dimen; i++)
5504 : {
5505 12226 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5506 : ploop->loopvar[i], offset[i]);
5507 12226 : gfc_add_modify (&ifblock, pos[i], tmp);
5508 12226 : gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
5509 : }
5510 :
5511 9951 : gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
5512 :
5513 9951 : if (lab1)
5514 6203 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5515 :
5516 9951 : ifbody = gfc_finish_block (&ifblock);
5517 :
5518 9951 : if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5519 : {
5520 7646 : if (lab1)
5521 5998 : cond = fold_build2_loc (input_location,
5522 : op == GT_EXPR ? GE_EXPR : LE_EXPR,
5523 : logical_type_node, arrayse.expr, limit);
5524 : else
5525 : {
5526 3748 : tree ifbody2, elsebody2;
5527 :
5528 : /* We switch to > or >= depending on the value of the BACK argument. */
5529 3748 : cond = gfc_create_var (logical_type_node, "cond");
5530 :
5531 3748 : gfc_start_block (&ifblock);
5532 5641 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5533 : logical_type_node, arrayse.expr, limit);
5534 :
5535 3748 : gfc_add_modify (&ifblock, cond, b_if);
5536 3748 : ifbody2 = gfc_finish_block (&ifblock);
5537 :
5538 3748 : gfc_start_block (&elseblock);
5539 3748 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5540 : arrayse.expr, limit);
5541 :
5542 3748 : gfc_add_modify (&elseblock, cond, b_else);
5543 3748 : elsebody2 = gfc_finish_block (&elseblock);
5544 :
5545 3748 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5546 : back, ifbody2, elsebody2);
5547 :
5548 3748 : gfc_add_expr_to_block (&block, tmp);
5549 : }
5550 :
5551 7646 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5552 7646 : ifbody = build3_v (COND_EXPR, cond, ifbody,
5553 : build_empty_stmt (input_location));
5554 : }
5555 9951 : gfc_add_expr_to_block (&block, ifbody);
5556 :
5557 9951 : if (maskexpr && maskexpr->rank > 0)
5558 : {
5559 : /* We enclose the above in if (mask) {...}. If the mask is an
5560 : optional argument, generate IF (.NOT. PRESENT(MASK)
5561 : .OR. MASK(I)). */
5562 :
5563 3874 : tree ifmask;
5564 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5565 3874 : tmp = gfc_finish_block (&block);
5566 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5567 : build_empty_stmt (input_location));
5568 3874 : }
5569 : else
5570 6077 : tmp = gfc_finish_block (&block);
5571 9951 : gfc_add_expr_to_block (&body, tmp);
5572 :
5573 9951 : if (lab1)
5574 : {
5575 13747 : for (int i = 0; i < ploop->dimen; i++)
5576 7544 : ploop->from[i] = fold_build3_loc (input_location, COND_EXPR,
5577 7544 : TREE_TYPE (ploop->from[i]),
5578 : second_loop_entry, idx[i],
5579 : ploop->from[i]);
5580 :
5581 6203 : gfc_trans_scalarized_loop_boundary (ploop, &body);
5582 :
5583 6203 : if (nested_loop)
5584 : {
5585 : /* The first loop already advanced the parent se'ss chain, so clear
5586 : the parent now to avoid doing it a second time, making the chain
5587 : out of sync. */
5588 1858 : nested_se.parent = nullptr;
5589 1858 : nested_se.ss = orig_ss;
5590 : }
5591 :
5592 6203 : stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1];
5593 :
5594 6203 : if (HONOR_NANS (DECL_MODE (limit)))
5595 : {
5596 3898 : if (nonempty != NULL)
5597 : {
5598 2329 : stmtblock_t init_block;
5599 2329 : gfc_init_block (&init_block);
5600 :
5601 7558 : for (int i = 0; i < ploop->dimen; i++)
5602 2900 : gfc_add_modify (&init_block, pos[i], gfc_index_one_node);
5603 :
5604 2329 : tree ifbody = gfc_finish_block (&init_block);
5605 2329 : tmp = build3_v (COND_EXPR, nonempty, ifbody,
5606 : build_empty_stmt (input_location));
5607 2329 : gfc_add_expr_to_block (outer_block, tmp);
5608 : }
5609 : }
5610 :
5611 6203 : gfc_add_expr_to_block (outer_block, build1_v (GOTO_EXPR, lab2));
5612 6203 : gfc_add_expr_to_block (outer_block, build1_v (LABEL_EXPR, lab1));
5613 :
5614 : /* If we have a mask, only check this element if the mask is set. */
5615 6203 : if (maskexpr && maskexpr->rank > 0)
5616 : {
5617 3874 : gfc_init_se (&maskse, base_se);
5618 3874 : gfc_copy_loopinfo_to_se (&maskse, ploop);
5619 3874 : if (!nested_loop)
5620 2700 : maskse.ss = maskss;
5621 3874 : gfc_conv_expr_val (&maskse, maskexpr);
5622 3874 : gfc_add_block_to_block (&body, &maskse.pre);
5623 :
5624 3874 : gfc_start_block (&block);
5625 : }
5626 : else
5627 2329 : gfc_init_block (&block);
5628 :
5629 : /* Compare with the current limit. */
5630 6203 : gfc_init_se (&arrayse, base_se);
5631 6203 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
5632 6203 : if (!nested_loop)
5633 4345 : arrayse.ss = arrayss;
5634 6203 : gfc_conv_expr_val (&arrayse, arrayexpr);
5635 6203 : gfc_add_block_to_block (&block, &arrayse.pre);
5636 :
5637 : /* We do the following if this is a more extreme value. */
5638 6203 : gfc_start_block (&ifblock);
5639 :
5640 : /* Assign the value to the limit... */
5641 6203 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5642 :
5643 19950 : for (int i = 0; i < ploop->dimen; i++)
5644 : {
5645 7544 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
5646 : ploop->loopvar[i], offset[i]);
5647 7544 : gfc_add_modify (&ifblock, pos[i], tmp);
5648 : }
5649 :
5650 6203 : ifbody = gfc_finish_block (&ifblock);
5651 :
5652 : /* We switch to > or >= depending on the value of the BACK argument. */
5653 6203 : {
5654 6203 : tree ifbody2, elsebody2;
5655 :
5656 6203 : cond = gfc_create_var (logical_type_node, "cond");
5657 :
5658 6203 : gfc_start_block (&ifblock);
5659 9537 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5660 : logical_type_node, arrayse.expr, limit);
5661 :
5662 6203 : gfc_add_modify (&ifblock, cond, b_if);
5663 6203 : ifbody2 = gfc_finish_block (&ifblock);
5664 :
5665 6203 : gfc_start_block (&elseblock);
5666 6203 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5667 : arrayse.expr, limit);
5668 :
5669 6203 : gfc_add_modify (&elseblock, cond, b_else);
5670 6203 : elsebody2 = gfc_finish_block (&elseblock);
5671 :
5672 6203 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5673 : back, ifbody2, elsebody2);
5674 : }
5675 :
5676 6203 : gfc_add_expr_to_block (&block, tmp);
5677 6203 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5678 6203 : tmp = build3_v (COND_EXPR, cond, ifbody,
5679 : build_empty_stmt (input_location));
5680 :
5681 6203 : gfc_add_expr_to_block (&block, tmp);
5682 :
5683 6203 : if (maskexpr && maskexpr->rank > 0)
5684 : {
5685 : /* We enclose the above in if (mask) {...}. If the mask is
5686 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5687 : .OR. MASK(I)).*/
5688 :
5689 3874 : tree ifmask;
5690 3874 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5691 3874 : tmp = gfc_finish_block (&block);
5692 3874 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5693 : build_empty_stmt (input_location));
5694 3874 : }
5695 : else
5696 2329 : tmp = gfc_finish_block (&block);
5697 :
5698 6203 : gfc_add_expr_to_block (&body, tmp);
5699 6203 : gfc_add_modify (&body, second_loop_entry, logical_false_node);
5700 : }
5701 :
5702 9951 : gfc_trans_scalarizing_loops (ploop, &body);
5703 :
5704 9951 : if (lab2)
5705 6203 : gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2));
5706 :
5707 : /* For a scalar mask, enclose the loop in an if statement. */
5708 9951 : if (maskexpr && maskexpr->rank == 0)
5709 : {
5710 2644 : tree ifmask;
5711 :
5712 2644 : gfc_init_se (&maskse, nested_loop ? se : nullptr);
5713 2644 : gfc_conv_expr_val (&maskse, maskexpr);
5714 2644 : gfc_add_block_to_block (&se->pre, &maskse.pre);
5715 2644 : gfc_init_block (&block);
5716 2644 : gfc_add_block_to_block (&block, &ploop->pre);
5717 2644 : gfc_add_block_to_block (&block, &ploop->post);
5718 2644 : tmp = gfc_finish_block (&block);
5719 :
5720 : /* For the else part of the scalar mask, just initialize
5721 : the pos variable the same way as above. */
5722 :
5723 2644 : gfc_init_block (&elseblock);
5724 8224 : for (int i = 0; i < ploop->dimen; i++)
5725 2936 : gfc_add_modify (&elseblock, pos[i], gfc_index_zero_node);
5726 2644 : elsetmp = gfc_finish_block (&elseblock);
5727 2644 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5728 2644 : tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5729 2644 : gfc_add_expr_to_block (&block, tmp);
5730 2644 : gfc_add_block_to_block (&se->pre, &block);
5731 2644 : }
5732 : else
5733 : {
5734 7307 : gfc_add_block_to_block (&se->pre, &ploop->pre);
5735 7307 : gfc_add_block_to_block (&se->pre, &ploop->post);
5736 : }
5737 :
5738 9951 : if (!nested_loop)
5739 7155 : gfc_cleanup_loop (&loop);
5740 :
5741 9951 : if (!dim_present)
5742 : {
5743 8837 : for (int i = 0; i < arrayexpr->rank; i++)
5744 : {
5745 5556 : tree res_idx = build_int_cst (gfc_array_index_type, i);
5746 5556 : tree res_arr_ref = gfc_build_array_ref (result_var, res_idx,
5747 : NULL_TREE, true);
5748 :
5749 5556 : tree value = convert (type, pos[i]);
5750 5556 : gfc_add_modify (&se->pre, res_arr_ref, value);
5751 : }
5752 :
5753 3281 : se->expr = result_var;
5754 : }
5755 : else
5756 6670 : se->expr = convert (type, pos[0]);
5757 : }
5758 :
5759 : /* Emit code for findloc. */
5760 :
5761 : static void
5762 1332 : gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5763 : {
5764 1332 : gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5765 : *kind_arg, *back_arg;
5766 1332 : gfc_expr *value_expr;
5767 1332 : int ikind;
5768 1332 : tree resvar;
5769 1332 : stmtblock_t block;
5770 1332 : stmtblock_t body;
5771 1332 : stmtblock_t loopblock;
5772 1332 : tree type;
5773 1332 : tree tmp;
5774 1332 : tree found;
5775 1332 : tree forward_branch = NULL_TREE;
5776 1332 : tree back_branch;
5777 1332 : gfc_loopinfo loop;
5778 1332 : gfc_ss *arrayss;
5779 1332 : gfc_ss *maskss;
5780 1332 : gfc_se arrayse;
5781 1332 : gfc_se valuese;
5782 1332 : gfc_se maskse;
5783 1332 : gfc_se backse;
5784 1332 : tree exit_label;
5785 1332 : gfc_expr *maskexpr;
5786 1332 : tree offset;
5787 1332 : int i;
5788 1332 : bool optional_mask;
5789 :
5790 1332 : array_arg = expr->value.function.actual;
5791 1332 : value_arg = array_arg->next;
5792 1332 : dim_arg = value_arg->next;
5793 1332 : mask_arg = dim_arg->next;
5794 1332 : kind_arg = mask_arg->next;
5795 1332 : back_arg = kind_arg->next;
5796 :
5797 : /* Remove kind and set ikind. */
5798 1332 : if (kind_arg->expr)
5799 : {
5800 0 : ikind = mpz_get_si (kind_arg->expr->value.integer);
5801 0 : gfc_free_expr (kind_arg->expr);
5802 0 : kind_arg->expr = NULL;
5803 : }
5804 : else
5805 1332 : ikind = gfc_default_integer_kind;
5806 :
5807 1332 : value_expr = value_arg->expr;
5808 :
5809 : /* Unless it's a string, pass VALUE by value. */
5810 1332 : if (value_expr->ts.type != BT_CHARACTER)
5811 732 : value_arg->name = "%VAL";
5812 :
5813 : /* Pass BACK argument by value. */
5814 1332 : back_arg->name = "%VAL";
5815 :
5816 : /* Call the library if we have a character function or if
5817 : rank > 0. */
5818 1332 : if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5819 : {
5820 1200 : se->ignore_optional = 1;
5821 1200 : if (expr->rank == 0)
5822 : {
5823 : /* Remove dim argument. */
5824 84 : gfc_free_expr (dim_arg->expr);
5825 84 : dim_arg->expr = NULL;
5826 : }
5827 1200 : gfc_conv_intrinsic_funcall (se, expr);
5828 1200 : return;
5829 : }
5830 :
5831 132 : type = gfc_get_int_type (ikind);
5832 :
5833 : /* Initialize the result. */
5834 132 : resvar = gfc_create_var (gfc_array_index_type, "pos");
5835 132 : gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5836 132 : offset = gfc_create_var (gfc_array_index_type, "offset");
5837 :
5838 132 : maskexpr = mask_arg->expr;
5839 72 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5840 60 : && maskexpr->symtree->n.sym->attr.dummy
5841 144 : && maskexpr->symtree->n.sym->attr.optional;
5842 :
5843 : /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5844 :
5845 396 : for (i = 0 ; i < 2; i++)
5846 : {
5847 : /* Walk the arguments. */
5848 264 : arrayss = gfc_walk_expr (array_arg->expr);
5849 264 : gcc_assert (arrayss != gfc_ss_terminator);
5850 :
5851 264 : if (maskexpr && maskexpr->rank != 0)
5852 : {
5853 84 : maskss = gfc_walk_expr (maskexpr);
5854 84 : gcc_assert (maskss != gfc_ss_terminator);
5855 : }
5856 : else
5857 : maskss = NULL;
5858 :
5859 : /* Initialize the scalarizer. */
5860 264 : gfc_init_loopinfo (&loop);
5861 264 : exit_label = gfc_build_label_decl (NULL_TREE);
5862 264 : TREE_USED (exit_label) = 1;
5863 :
5864 : /* We add the mask first because the number of iterations is
5865 : taken from the last ss, and this breaks if an absent
5866 : optional argument is used for mask. */
5867 :
5868 264 : if (maskss)
5869 84 : gfc_add_ss_to_loop (&loop, maskss);
5870 264 : gfc_add_ss_to_loop (&loop, arrayss);
5871 :
5872 : /* Initialize the loop. */
5873 264 : gfc_conv_ss_startstride (&loop);
5874 264 : gfc_conv_loop_setup (&loop, &expr->where);
5875 :
5876 : /* Calculate the offset. */
5877 264 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5878 : gfc_index_one_node, loop.from[0]);
5879 264 : gfc_add_modify (&loop.pre, offset, tmp);
5880 :
5881 264 : gfc_mark_ss_chain_used (arrayss, 1);
5882 264 : if (maskss)
5883 84 : gfc_mark_ss_chain_used (maskss, 1);
5884 :
5885 : /* The first loop is for BACK=.true. */
5886 264 : if (i == 0)
5887 132 : loop.reverse[0] = GFC_REVERSE_SET;
5888 :
5889 : /* Generate the loop body. */
5890 264 : gfc_start_scalarized_body (&loop, &body);
5891 :
5892 : /* If we have an array mask, only add the element if it is
5893 : set. */
5894 264 : if (maskss)
5895 : {
5896 84 : gfc_init_se (&maskse, NULL);
5897 84 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5898 84 : maskse.ss = maskss;
5899 84 : gfc_conv_expr_val (&maskse, maskexpr);
5900 84 : gfc_add_block_to_block (&body, &maskse.pre);
5901 : }
5902 :
5903 : /* If the condition matches then set the return value. */
5904 264 : gfc_start_block (&block);
5905 :
5906 : /* Add the offset. */
5907 264 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5908 264 : TREE_TYPE (resvar),
5909 : loop.loopvar[0], offset);
5910 264 : gfc_add_modify (&block, resvar, tmp);
5911 : /* And break out of the loop. */
5912 264 : tmp = build1_v (GOTO_EXPR, exit_label);
5913 264 : gfc_add_expr_to_block (&block, tmp);
5914 :
5915 264 : found = gfc_finish_block (&block);
5916 :
5917 : /* Check this element. */
5918 264 : gfc_init_se (&arrayse, NULL);
5919 264 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5920 264 : arrayse.ss = arrayss;
5921 264 : gfc_conv_expr_val (&arrayse, array_arg->expr);
5922 264 : gfc_add_block_to_block (&body, &arrayse.pre);
5923 :
5924 264 : gfc_init_se (&valuese, NULL);
5925 264 : gfc_conv_expr_val (&valuese, value_arg->expr);
5926 264 : gfc_add_block_to_block (&body, &valuese.pre);
5927 :
5928 264 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5929 : arrayse.expr, valuese.expr);
5930 :
5931 264 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5932 264 : if (maskss)
5933 : {
5934 : /* We enclose the above in if (mask) {...}. If the mask is
5935 : an optional argument, generate IF (.NOT. PRESENT(MASK)
5936 : .OR. MASK(I)). */
5937 :
5938 84 : tree ifmask;
5939 84 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5940 84 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5941 : build_empty_stmt (input_location));
5942 : }
5943 :
5944 264 : gfc_add_expr_to_block (&body, tmp);
5945 264 : gfc_add_block_to_block (&body, &arrayse.post);
5946 :
5947 264 : gfc_trans_scalarizing_loops (&loop, &body);
5948 :
5949 : /* Add the exit label. */
5950 264 : tmp = build1_v (LABEL_EXPR, exit_label);
5951 264 : gfc_add_expr_to_block (&loop.pre, tmp);
5952 264 : gfc_start_block (&loopblock);
5953 264 : gfc_add_block_to_block (&loopblock, &loop.pre);
5954 264 : gfc_add_block_to_block (&loopblock, &loop.post);
5955 264 : if (i == 0)
5956 132 : forward_branch = gfc_finish_block (&loopblock);
5957 : else
5958 132 : back_branch = gfc_finish_block (&loopblock);
5959 :
5960 264 : gfc_cleanup_loop (&loop);
5961 : }
5962 :
5963 : /* Enclose the two loops in an IF statement. */
5964 :
5965 132 : gfc_init_se (&backse, NULL);
5966 132 : gfc_conv_expr_val (&backse, back_arg->expr);
5967 132 : gfc_add_block_to_block (&se->pre, &backse.pre);
5968 132 : tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5969 :
5970 : /* For a scalar mask, enclose the loop in an if statement. */
5971 132 : if (maskexpr && maskss == NULL)
5972 : {
5973 30 : tree ifmask;
5974 30 : tree if_stmt;
5975 :
5976 30 : gfc_init_se (&maskse, NULL);
5977 30 : gfc_conv_expr_val (&maskse, maskexpr);
5978 30 : gfc_init_block (&block);
5979 30 : gfc_add_expr_to_block (&block, maskse.expr);
5980 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5981 30 : if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5982 : build_empty_stmt (input_location));
5983 30 : gfc_add_expr_to_block (&block, if_stmt);
5984 30 : tmp = gfc_finish_block (&block);
5985 : }
5986 :
5987 132 : gfc_add_expr_to_block (&se->pre, tmp);
5988 132 : se->expr = convert (type, resvar);
5989 :
5990 : }
5991 :
5992 : /* Emit code for fstat, lstat and stat intrinsic subroutines. */
5993 :
5994 : static tree
5995 55 : conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code)
5996 : {
5997 55 : stmtblock_t block;
5998 55 : gfc_se se, se_stat;
5999 55 : tree unit = NULL_TREE;
6000 55 : tree name = NULL_TREE;
6001 55 : tree slen = NULL_TREE;
6002 55 : tree vals;
6003 55 : tree arg3 = NULL_TREE;
6004 55 : tree stat = NULL_TREE ;
6005 55 : tree present = NULL_TREE;
6006 55 : tree tmp;
6007 55 : int kind;
6008 :
6009 55 : gfc_init_block (&block);
6010 55 : gfc_init_se (&se, NULL);
6011 :
6012 55 : switch (code->resolved_isym->id)
6013 : {
6014 21 : case GFC_ISYM_FSTAT:
6015 : /* Deal with the UNIT argument. */
6016 21 : gfc_conv_expr (&se, code->ext.actual->expr);
6017 21 : gfc_add_block_to_block (&block, &se.pre);
6018 21 : unit = gfc_evaluate_now (se.expr, &block);
6019 21 : unit = gfc_build_addr_expr (NULL_TREE, unit);
6020 21 : gfc_add_block_to_block (&block, &se.post);
6021 21 : break;
6022 :
6023 34 : case GFC_ISYM_LSTAT:
6024 34 : case GFC_ISYM_STAT:
6025 : /* Deal with the NAME argument. */
6026 34 : gfc_conv_expr (&se, code->ext.actual->expr);
6027 34 : gfc_conv_string_parameter (&se);
6028 34 : gfc_add_block_to_block (&block, &se.pre);
6029 34 : name = se.expr;
6030 34 : slen = se.string_length;
6031 34 : gfc_add_block_to_block (&block, &se.post);
6032 34 : break;
6033 :
6034 0 : default:
6035 0 : gcc_unreachable ();
6036 : }
6037 :
6038 : /* Deal with the VALUES argument. */
6039 55 : gfc_init_se (&se, NULL);
6040 55 : gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr);
6041 55 : vals = gfc_build_addr_expr (NULL_TREE, se.expr);
6042 55 : gfc_add_block_to_block (&block, &se.pre);
6043 55 : gfc_add_block_to_block (&block, &se.post);
6044 55 : kind = code->ext.actual->next->expr->ts.kind;
6045 :
6046 : /* Deal with an optional STATUS. */
6047 55 : if (code->ext.actual->next->next->expr)
6048 : {
6049 45 : gfc_init_se (&se_stat, NULL);
6050 45 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
6051 45 : stat = gfc_create_var (gfc_get_int_type (kind), "_stat");
6052 45 : arg3 = gfc_build_addr_expr (NULL_TREE, stat);
6053 :
6054 : /* Handle case of status being an optional dummy. */
6055 45 : gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym;
6056 45 : if (sym->attr.dummy && sym->attr.optional)
6057 : {
6058 6 : present = gfc_conv_expr_present (sym);
6059 12 : arg3 = fold_build3_loc (input_location, COND_EXPR,
6060 6 : TREE_TYPE (arg3), present, arg3,
6061 6 : fold_convert (TREE_TYPE (arg3),
6062 : null_pointer_node));
6063 : }
6064 : }
6065 :
6066 : /* Call library function depending on KIND of VALUES argument. */
6067 55 : switch (code->resolved_isym->id)
6068 : {
6069 21 : case GFC_ISYM_FSTAT:
6070 21 : tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub);
6071 : break;
6072 14 : case GFC_ISYM_LSTAT:
6073 14 : tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub);
6074 : break;
6075 20 : case GFC_ISYM_STAT:
6076 20 : tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub);
6077 : break;
6078 0 : default:
6079 0 : gcc_unreachable ();
6080 : }
6081 :
6082 55 : if (code->resolved_isym->id == GFC_ISYM_FSTAT)
6083 21 : tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals,
6084 : stat ? arg3 : null_pointer_node);
6085 : else
6086 34 : tmp = build_call_expr_loc (input_location, tmp, 4, name, vals,
6087 : stat ? arg3 : null_pointer_node, slen);
6088 55 : gfc_add_expr_to_block (&block, tmp);
6089 :
6090 : /* Handle kind conversion of status. */
6091 55 : if (stat && stat != se_stat.expr)
6092 : {
6093 45 : stmtblock_t block2;
6094 :
6095 45 : gfc_init_block (&block2);
6096 45 : gfc_add_modify (&block2, se_stat.expr,
6097 45 : fold_convert (TREE_TYPE (se_stat.expr), stat));
6098 :
6099 45 : if (present)
6100 : {
6101 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2),
6102 : build_empty_stmt (input_location));
6103 6 : gfc_add_expr_to_block (&block, tmp);
6104 : }
6105 : else
6106 39 : gfc_add_block_to_block (&block, &block2);
6107 : }
6108 :
6109 55 : return gfc_finish_block (&block);
6110 : }
6111 :
6112 : /* Emit code for minval or maxval intrinsic. There are many different cases
6113 : we need to handle. For performance reasons we sometimes create two
6114 : loops instead of one, where the second one is much simpler.
6115 : Examples for minval intrinsic:
6116 : 1) Result is an array, a call is generated
6117 : 2) Array mask is used and NaNs need to be supported, rank 1:
6118 : limit = Infinity;
6119 : nonempty = false;
6120 : S = from;
6121 : while (S <= to) {
6122 : if (mask[S]) {
6123 : nonempty = true;
6124 : if (a[S] <= limit) {
6125 : limit = a[S];
6126 : S++;
6127 : goto lab;
6128 : }
6129 : else
6130 : S++;
6131 : }
6132 : }
6133 : limit = nonempty ? NaN : huge (limit);
6134 : lab:
6135 : while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6136 : 3) NaNs need to be supported, but it is known at compile time or cheaply
6137 : at runtime whether array is nonempty or not, rank 1:
6138 : limit = Infinity;
6139 : S = from;
6140 : while (S <= to) {
6141 : if (a[S] <= limit) {
6142 : limit = a[S];
6143 : S++;
6144 : goto lab;
6145 : }
6146 : else
6147 : S++;
6148 : }
6149 : limit = (from <= to) ? NaN : huge (limit);
6150 : lab:
6151 : while (S <= to) { limit = min (a[S], limit); S++; }
6152 : 4) Array mask is used and NaNs need to be supported, rank > 1:
6153 : limit = Infinity;
6154 : nonempty = false;
6155 : fast = false;
6156 : S1 = from1;
6157 : while (S1 <= to1) {
6158 : S2 = from2;
6159 : while (S2 <= to2) {
6160 : if (mask[S1][S2]) {
6161 : if (fast) limit = min (a[S1][S2], limit);
6162 : else {
6163 : nonempty = true;
6164 : if (a[S1][S2] <= limit) {
6165 : limit = a[S1][S2];
6166 : fast = true;
6167 : }
6168 : }
6169 : }
6170 : S2++;
6171 : }
6172 : S1++;
6173 : }
6174 : if (!fast)
6175 : limit = nonempty ? NaN : huge (limit);
6176 : 5) NaNs need to be supported, but it is known at compile time or cheaply
6177 : at runtime whether array is nonempty or not, rank > 1:
6178 : limit = Infinity;
6179 : fast = false;
6180 : S1 = from1;
6181 : while (S1 <= to1) {
6182 : S2 = from2;
6183 : while (S2 <= to2) {
6184 : if (fast) limit = min (a[S1][S2], limit);
6185 : else {
6186 : if (a[S1][S2] <= limit) {
6187 : limit = a[S1][S2];
6188 : fast = true;
6189 : }
6190 : }
6191 : S2++;
6192 : }
6193 : S1++;
6194 : }
6195 : if (!fast)
6196 : limit = (nonempty_array) ? NaN : huge (limit);
6197 : 6) NaNs aren't supported, but infinities are. Array mask is used:
6198 : limit = Infinity;
6199 : nonempty = false;
6200 : S = from;
6201 : while (S <= to) {
6202 : if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6203 : S++;
6204 : }
6205 : limit = nonempty ? limit : huge (limit);
6206 : 7) Same without array mask:
6207 : limit = Infinity;
6208 : S = from;
6209 : while (S <= to) { limit = min (a[S], limit); S++; }
6210 : limit = (from <= to) ? limit : huge (limit);
6211 : 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6212 : limit = huge (limit);
6213 : S = from;
6214 : while (S <= to) { limit = min (a[S], limit); S++); }
6215 : (or
6216 : while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6217 : with array mask instead).
6218 : For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6219 : setting limit = huge (limit); in the else branch. */
6220 :
6221 : static void
6222 2417 : gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6223 : {
6224 2417 : tree limit;
6225 2417 : tree type;
6226 2417 : tree tmp;
6227 2417 : tree ifbody;
6228 2417 : tree nonempty;
6229 2417 : tree nonempty_var;
6230 2417 : tree lab;
6231 2417 : tree fast;
6232 2417 : tree huge_cst = NULL, nan_cst = NULL;
6233 2417 : stmtblock_t body;
6234 2417 : stmtblock_t block, block2;
6235 2417 : gfc_loopinfo loop;
6236 2417 : gfc_actual_arglist *actual;
6237 2417 : gfc_ss *arrayss;
6238 2417 : gfc_ss *maskss;
6239 2417 : gfc_se arrayse;
6240 2417 : gfc_se maskse;
6241 2417 : gfc_expr *arrayexpr;
6242 2417 : gfc_expr *maskexpr;
6243 2417 : int n;
6244 2417 : bool optional_mask;
6245 :
6246 2417 : if (se->ss)
6247 : {
6248 0 : gfc_conv_intrinsic_funcall (se, expr);
6249 186 : return;
6250 : }
6251 :
6252 2417 : actual = expr->value.function.actual;
6253 2417 : arrayexpr = actual->expr;
6254 :
6255 2417 : if (arrayexpr->ts.type == BT_CHARACTER)
6256 : {
6257 186 : gfc_actual_arglist *dim = actual->next;
6258 186 : if (expr->rank == 0 && dim->expr != 0)
6259 : {
6260 6 : gfc_free_expr (dim->expr);
6261 6 : dim->expr = NULL;
6262 : }
6263 186 : gfc_conv_intrinsic_funcall (se, expr);
6264 186 : return;
6265 : }
6266 :
6267 2231 : type = gfc_typenode_for_spec (&expr->ts);
6268 : /* Initialize the result. */
6269 2231 : limit = gfc_create_var (type, "limit");
6270 2231 : n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6271 2231 : switch (expr->ts.type)
6272 : {
6273 1245 : case BT_REAL:
6274 1245 : huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6275 : expr->ts.kind, 0);
6276 1245 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6277 : {
6278 1241 : REAL_VALUE_TYPE real;
6279 1241 : real_inf (&real);
6280 1241 : tmp = build_real (type, real);
6281 : }
6282 : else
6283 : tmp = huge_cst;
6284 1245 : if (HONOR_NANS (DECL_MODE (limit)))
6285 1241 : nan_cst = gfc_build_nan (type, "");
6286 : break;
6287 :
6288 956 : case BT_INTEGER:
6289 956 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6290 956 : break;
6291 :
6292 30 : case BT_UNSIGNED:
6293 : /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */
6294 30 : if (op == GT_EXPR)
6295 18 : tmp = build_int_cst (type, 0);
6296 : else
6297 12 : tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge,
6298 : expr->ts.kind);
6299 : break;
6300 :
6301 0 : default:
6302 0 : gcc_unreachable ();
6303 : }
6304 :
6305 : /* We start with the most negative possible value for MAXVAL, and the most
6306 : positive possible value for MINVAL. The most negative possible value is
6307 : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6308 : possible value is HUGE in both cases. BT_UNSIGNED has already been dealt
6309 : with above. */
6310 2231 : if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED)
6311 : {
6312 987 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6313 987 : if (huge_cst)
6314 560 : huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6315 560 : TREE_TYPE (huge_cst), huge_cst);
6316 : }
6317 :
6318 1005 : if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6319 427 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6320 : tmp, build_int_cst (type, 1));
6321 :
6322 2231 : gfc_add_modify (&se->pre, limit, tmp);
6323 :
6324 : /* Walk the arguments. */
6325 2231 : arrayss = gfc_walk_expr (arrayexpr);
6326 2231 : gcc_assert (arrayss != gfc_ss_terminator);
6327 :
6328 2231 : actual = actual->next->next;
6329 2231 : gcc_assert (actual);
6330 2231 : maskexpr = actual->expr;
6331 1572 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6332 1560 : && maskexpr->symtree->n.sym->attr.dummy
6333 2243 : && maskexpr->symtree->n.sym->attr.optional;
6334 2777 : nonempty = NULL;
6335 1572 : if (maskexpr && maskexpr->rank != 0)
6336 : {
6337 1026 : maskss = gfc_walk_expr (maskexpr);
6338 1026 : gcc_assert (maskss != gfc_ss_terminator);
6339 : }
6340 : else
6341 : {
6342 1205 : mpz_t asize;
6343 1205 : if (gfc_array_size (arrayexpr, &asize))
6344 : {
6345 678 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6346 678 : mpz_clear (asize);
6347 678 : nonempty = fold_build2_loc (input_location, GT_EXPR,
6348 : logical_type_node, nonempty,
6349 : gfc_index_zero_node);
6350 : }
6351 1205 : maskss = NULL;
6352 : }
6353 :
6354 : /* Initialize the scalarizer. */
6355 2231 : gfc_init_loopinfo (&loop);
6356 :
6357 : /* We add the mask first because the number of iterations is taken
6358 : from the last ss, and this breaks if an absent optional argument
6359 : is used for mask. */
6360 :
6361 2231 : if (maskss)
6362 1026 : gfc_add_ss_to_loop (&loop, maskss);
6363 2231 : gfc_add_ss_to_loop (&loop, arrayss);
6364 :
6365 : /* Initialize the loop. */
6366 2231 : gfc_conv_ss_startstride (&loop);
6367 :
6368 : /* The code generated can have more than one loop in sequence (see the
6369 : comment at the function header). This doesn't work well with the
6370 : scalarizer, which changes arrays' offset when the scalarization loops
6371 : are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6372 : are currently inlined in the scalar case only. As there is no dependency
6373 : to care about in that case, there is no temporary, so that we can use the
6374 : scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6375 : here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6376 : gfc_trans_scalarized_loop_boundary even later to restore offset.
6377 : TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6378 : should eventually go away. We could either create two loops properly,
6379 : or find another way to save/restore the array offsets between the two
6380 : loops (without conflicting with temporary management), or use a single
6381 : loop minmaxval implementation. See PR 31067. */
6382 2231 : loop.temp_dim = loop.dimen;
6383 2231 : gfc_conv_loop_setup (&loop, &expr->where);
6384 :
6385 2231 : if (nonempty == NULL && maskss == NULL
6386 527 : && loop.dimen == 1 && loop.from[0] && loop.to[0])
6387 491 : nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6388 : loop.from[0], loop.to[0]);
6389 2231 : nonempty_var = NULL;
6390 2231 : if (nonempty == NULL
6391 2231 : && (HONOR_INFINITIES (DECL_MODE (limit))
6392 480 : || HONOR_NANS (DECL_MODE (limit))))
6393 : {
6394 582 : nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6395 582 : gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6396 582 : nonempty = nonempty_var;
6397 : }
6398 2231 : lab = NULL;
6399 2231 : fast = NULL;
6400 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6401 : {
6402 1241 : if (loop.dimen == 1)
6403 : {
6404 821 : lab = gfc_build_label_decl (NULL_TREE);
6405 821 : TREE_USED (lab) = 1;
6406 : }
6407 : else
6408 : {
6409 420 : fast = gfc_create_var (logical_type_node, "fast");
6410 420 : gfc_add_modify (&se->pre, fast, logical_false_node);
6411 : }
6412 : }
6413 :
6414 2231 : gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6415 2231 : if (maskss)
6416 1704 : gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6417 : /* Generate the loop body. */
6418 2231 : gfc_start_scalarized_body (&loop, &body);
6419 :
6420 : /* If we have a mask, only add this element if the mask is set. */
6421 2231 : if (maskss)
6422 : {
6423 1026 : gfc_init_se (&maskse, NULL);
6424 1026 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6425 1026 : maskse.ss = maskss;
6426 1026 : gfc_conv_expr_val (&maskse, maskexpr);
6427 1026 : gfc_add_block_to_block (&body, &maskse.pre);
6428 :
6429 1026 : gfc_start_block (&block);
6430 : }
6431 : else
6432 1205 : gfc_init_block (&block);
6433 :
6434 : /* Compare with the current limit. */
6435 2231 : gfc_init_se (&arrayse, NULL);
6436 2231 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6437 2231 : arrayse.ss = arrayss;
6438 2231 : gfc_conv_expr_val (&arrayse, arrayexpr);
6439 2231 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6440 2231 : gfc_add_block_to_block (&block, &arrayse.pre);
6441 :
6442 2231 : gfc_init_block (&block2);
6443 :
6444 2231 : if (nonempty_var)
6445 582 : gfc_add_modify (&block2, nonempty_var, logical_true_node);
6446 :
6447 2231 : if (HONOR_NANS (DECL_MODE (limit)))
6448 : {
6449 1922 : tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6450 : logical_type_node, arrayse.expr, limit);
6451 1241 : if (lab)
6452 : {
6453 821 : stmtblock_t ifblock;
6454 821 : tree inc_loop;
6455 821 : inc_loop = fold_build2_loc (input_location, PLUS_EXPR,
6456 821 : TREE_TYPE (loop.loopvar[0]),
6457 : loop.loopvar[0], gfc_index_one_node);
6458 821 : gfc_init_block (&ifblock);
6459 821 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6460 821 : gfc_add_modify (&ifblock, loop.loopvar[0], inc_loop);
6461 821 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab));
6462 821 : ifbody = gfc_finish_block (&ifblock);
6463 : }
6464 : else
6465 : {
6466 420 : stmtblock_t ifblock;
6467 :
6468 420 : gfc_init_block (&ifblock);
6469 420 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6470 420 : gfc_add_modify (&ifblock, fast, logical_true_node);
6471 420 : ifbody = gfc_finish_block (&ifblock);
6472 : }
6473 1241 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6474 : build_empty_stmt (input_location));
6475 1241 : gfc_add_expr_to_block (&block2, tmp);
6476 : }
6477 : else
6478 : {
6479 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6480 : signed zeros. */
6481 1535 : tmp = fold_build2_loc (input_location,
6482 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6483 : type, arrayse.expr, limit);
6484 990 : gfc_add_modify (&block2, limit, tmp);
6485 : }
6486 :
6487 2231 : if (fast)
6488 : {
6489 420 : tree elsebody = gfc_finish_block (&block2);
6490 :
6491 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6492 : signed zeros. */
6493 420 : if (HONOR_NANS (DECL_MODE (limit)))
6494 : {
6495 420 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6496 : arrayse.expr, limit);
6497 420 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6498 420 : ifbody = build3_v (COND_EXPR, tmp, ifbody,
6499 : build_empty_stmt (input_location));
6500 : }
6501 : else
6502 : {
6503 0 : tmp = fold_build2_loc (input_location,
6504 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6505 : type, arrayse.expr, limit);
6506 0 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6507 : }
6508 420 : tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6509 420 : gfc_add_expr_to_block (&block, tmp);
6510 : }
6511 : else
6512 1811 : gfc_add_block_to_block (&block, &block2);
6513 :
6514 2231 : gfc_add_block_to_block (&block, &arrayse.post);
6515 :
6516 2231 : tmp = gfc_finish_block (&block);
6517 2231 : if (maskss)
6518 : {
6519 : /* We enclose the above in if (mask) {...}. If the mask is an
6520 : optional argument, generate IF (.NOT. PRESENT(MASK)
6521 : .OR. MASK(I)). */
6522 1026 : tree ifmask;
6523 1026 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6524 1026 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6525 : build_empty_stmt (input_location));
6526 : }
6527 2231 : gfc_add_expr_to_block (&body, tmp);
6528 :
6529 2231 : if (lab)
6530 : {
6531 821 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6532 :
6533 821 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6534 : nan_cst, huge_cst);
6535 821 : gfc_add_modify (&loop.code[0], limit, tmp);
6536 821 : gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6537 :
6538 : /* If we have a mask, only add this element if the mask is set. */
6539 821 : if (maskss)
6540 : {
6541 348 : gfc_init_se (&maskse, NULL);
6542 348 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6543 348 : maskse.ss = maskss;
6544 348 : gfc_conv_expr_val (&maskse, maskexpr);
6545 348 : gfc_add_block_to_block (&body, &maskse.pre);
6546 :
6547 348 : gfc_start_block (&block);
6548 : }
6549 : else
6550 473 : gfc_init_block (&block);
6551 :
6552 : /* Compare with the current limit. */
6553 821 : gfc_init_se (&arrayse, NULL);
6554 821 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6555 821 : arrayse.ss = arrayss;
6556 821 : gfc_conv_expr_val (&arrayse, arrayexpr);
6557 821 : arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
6558 821 : gfc_add_block_to_block (&block, &arrayse.pre);
6559 :
6560 : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6561 : signed zeros. */
6562 821 : if (HONOR_NANS (DECL_MODE (limit)))
6563 : {
6564 821 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6565 : arrayse.expr, limit);
6566 821 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6567 821 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6568 : build_empty_stmt (input_location));
6569 821 : gfc_add_expr_to_block (&block, tmp);
6570 : }
6571 : else
6572 : {
6573 0 : tmp = fold_build2_loc (input_location,
6574 : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6575 : type, arrayse.expr, limit);
6576 0 : gfc_add_modify (&block, limit, tmp);
6577 : }
6578 :
6579 821 : gfc_add_block_to_block (&block, &arrayse.post);
6580 :
6581 821 : tmp = gfc_finish_block (&block);
6582 821 : if (maskss)
6583 : /* We enclose the above in if (mask) {...}. */
6584 : {
6585 348 : tree ifmask;
6586 348 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6587 348 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6588 : build_empty_stmt (input_location));
6589 : }
6590 :
6591 821 : gfc_add_expr_to_block (&body, tmp);
6592 : /* Avoid initializing loopvar[0] again, it should be left where
6593 : it finished by the first loop. */
6594 821 : loop.from[0] = loop.loopvar[0];
6595 : }
6596 2231 : gfc_trans_scalarizing_loops (&loop, &body);
6597 :
6598 2231 : if (fast)
6599 : {
6600 420 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6601 : nan_cst, huge_cst);
6602 420 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6603 420 : tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6604 : ifbody);
6605 420 : gfc_add_expr_to_block (&loop.pre, tmp);
6606 : }
6607 1811 : else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6608 : {
6609 0 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6610 : huge_cst);
6611 0 : gfc_add_modify (&loop.pre, limit, tmp);
6612 : }
6613 :
6614 : /* For a scalar mask, enclose the loop in an if statement. */
6615 2231 : if (maskexpr && maskss == NULL)
6616 : {
6617 546 : tree else_stmt;
6618 546 : tree ifmask;
6619 :
6620 546 : gfc_init_se (&maskse, NULL);
6621 546 : gfc_conv_expr_val (&maskse, maskexpr);
6622 546 : gfc_init_block (&block);
6623 546 : gfc_add_block_to_block (&block, &loop.pre);
6624 546 : gfc_add_block_to_block (&block, &loop.post);
6625 546 : tmp = gfc_finish_block (&block);
6626 :
6627 546 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6628 354 : else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6629 : else
6630 192 : else_stmt = build_empty_stmt (input_location);
6631 :
6632 546 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6633 546 : tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6634 546 : gfc_add_expr_to_block (&block, tmp);
6635 546 : gfc_add_block_to_block (&se->pre, &block);
6636 : }
6637 : else
6638 : {
6639 1685 : gfc_add_block_to_block (&se->pre, &loop.pre);
6640 1685 : gfc_add_block_to_block (&se->pre, &loop.post);
6641 : }
6642 :
6643 2231 : gfc_cleanup_loop (&loop);
6644 :
6645 2231 : se->expr = limit;
6646 : }
6647 :
6648 : /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6649 : static void
6650 145 : gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6651 : {
6652 145 : tree args[2];
6653 145 : tree type;
6654 145 : tree tmp;
6655 :
6656 145 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6657 145 : type = TREE_TYPE (args[0]);
6658 :
6659 : /* Optionally generate code for runtime argument check. */
6660 145 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6661 : {
6662 6 : tree below = fold_build2_loc (input_location, LT_EXPR,
6663 : logical_type_node, args[1],
6664 6 : build_int_cst (TREE_TYPE (args[1]), 0));
6665 6 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6666 6 : tree above = fold_build2_loc (input_location, GE_EXPR,
6667 : logical_type_node, args[1], nbits);
6668 6 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6669 : logical_type_node, below, above);
6670 6 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6671 : "POS argument (%ld) out of range 0:%ld "
6672 : "in intrinsic BTEST",
6673 : fold_convert (long_integer_type_node, args[1]),
6674 : fold_convert (long_integer_type_node, nbits));
6675 : }
6676 :
6677 145 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6678 : build_int_cst (type, 1), args[1]);
6679 145 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6680 145 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6681 : build_int_cst (type, 0));
6682 145 : type = gfc_typenode_for_spec (&expr->ts);
6683 145 : se->expr = convert (type, tmp);
6684 145 : }
6685 :
6686 :
6687 : /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6688 : static void
6689 216 : gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6690 : {
6691 216 : tree args[2];
6692 :
6693 216 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6694 :
6695 : /* Convert both arguments to the unsigned type of the same size. */
6696 216 : args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6697 216 : args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6698 :
6699 : /* If they have unequal type size, convert to the larger one. */
6700 216 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
6701 216 : > TYPE_PRECISION (TREE_TYPE (args[1])))
6702 0 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6703 216 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6704 216 : > TYPE_PRECISION (TREE_TYPE (args[0])))
6705 0 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6706 :
6707 : /* Now, we compare them. */
6708 216 : se->expr = fold_build2_loc (input_location, op, logical_type_node,
6709 : args[0], args[1]);
6710 216 : }
6711 :
6712 :
6713 : /* Generate code to perform the specified operation. */
6714 : static void
6715 1915 : gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6716 : {
6717 1915 : tree args[2];
6718 :
6719 1915 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6720 1915 : se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6721 : args[0], args[1]);
6722 1915 : }
6723 :
6724 : /* Bitwise not. */
6725 : static void
6726 230 : gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6727 : {
6728 230 : tree arg;
6729 :
6730 230 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6731 230 : se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6732 230 : TREE_TYPE (arg), arg);
6733 230 : }
6734 :
6735 :
6736 : /* Generate code for OUT_OF_RANGE. */
6737 : static void
6738 468 : gfc_conv_intrinsic_out_of_range (gfc_se * se, gfc_expr * expr)
6739 : {
6740 468 : tree *args;
6741 468 : tree type;
6742 468 : tree tmp = NULL_TREE, tmp1, tmp2;
6743 468 : unsigned int num_args;
6744 468 : int k;
6745 468 : gfc_se rnd_se;
6746 468 : gfc_actual_arglist *arg = expr->value.function.actual;
6747 468 : gfc_expr *x = arg->expr;
6748 468 : gfc_expr *mold = arg->next->expr;
6749 :
6750 468 : num_args = gfc_intrinsic_argument_list_length (expr);
6751 468 : args = XALLOCAVEC (tree, num_args);
6752 :
6753 468 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6754 :
6755 468 : gfc_init_se (&rnd_se, NULL);
6756 :
6757 468 : if (num_args == 3)
6758 : {
6759 : /* The ROUND argument is optional and shall appear only if X is
6760 : of type real and MOLD is of type integer (see edit F23/004). */
6761 270 : gfc_expr *round = arg->next->next->expr;
6762 270 : gfc_conv_expr (&rnd_se, round);
6763 :
6764 270 : if (round->expr_type == EXPR_VARIABLE
6765 198 : && round->symtree->n.sym->attr.dummy
6766 30 : && round->symtree->n.sym->attr.optional)
6767 : {
6768 30 : tree present = gfc_conv_expr_present (round->symtree->n.sym);
6769 30 : rnd_se.expr = build3_loc (input_location, COND_EXPR,
6770 : logical_type_node, present,
6771 : rnd_se.expr, logical_false_node);
6772 30 : gfc_add_block_to_block (&se->pre, &rnd_se.pre);
6773 : }
6774 : }
6775 : else
6776 : {
6777 : /* If ROUND is absent, it is equivalent to having the value false. */
6778 198 : rnd_se.expr = logical_false_node;
6779 : }
6780 :
6781 468 : type = TREE_TYPE (args[0]);
6782 468 : k = gfc_validate_kind (mold->ts.type, mold->ts.kind, false);
6783 :
6784 468 : switch (x->ts.type)
6785 : {
6786 378 : case BT_REAL:
6787 : /* X may be IEEE infinity or NaN, but the representation of MOLD may not
6788 : support infinity or NaN. */
6789 378 : tree finite;
6790 378 : finite = build_call_expr_loc (input_location,
6791 : builtin_decl_explicit (BUILT_IN_ISFINITE),
6792 : 1, args[0]);
6793 378 : finite = convert (logical_type_node, finite);
6794 :
6795 378 : if (mold->ts.type == BT_REAL)
6796 : {
6797 24 : tmp1 = build1 (ABS_EXPR, type, args[0]);
6798 24 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6799 : mold->ts.kind, 0);
6800 24 : tmp = build2 (GT_EXPR, logical_type_node, tmp1,
6801 : convert (type, tmp2));
6802 :
6803 : /* Check if MOLD representation supports infinity or NaN. */
6804 24 : bool infnan = (HONOR_INFINITIES (TREE_TYPE (args[1]))
6805 24 : || HONOR_NANS (TREE_TYPE (args[1])));
6806 24 : tmp = build3 (COND_EXPR, logical_type_node, finite, tmp,
6807 : infnan ? logical_false_node : logical_true_node);
6808 : }
6809 : else
6810 : {
6811 354 : tree rounded;
6812 354 : tree decl;
6813 :
6814 354 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, x->ts.kind);
6815 354 : gcc_assert (decl != NULL_TREE);
6816 :
6817 : /* Round or truncate argument X, depending on the optional argument
6818 : ROUND (default: .false.). */
6819 354 : tmp1 = build_round_expr (args[0], type);
6820 354 : tmp2 = build_call_expr_loc (input_location, decl, 1, args[0]);
6821 354 : rounded = build3 (COND_EXPR, type, rnd_se.expr, tmp1, tmp2);
6822 :
6823 354 : if (mold->ts.type == BT_INTEGER)
6824 : {
6825 180 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6826 : x->ts.kind);
6827 180 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6828 : x->ts.kind);
6829 : }
6830 174 : else if (mold->ts.type == BT_UNSIGNED)
6831 : {
6832 174 : tmp1 = build_real_from_int_cst (type, integer_zero_node);
6833 174 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6834 : x->ts.kind);
6835 : }
6836 : else
6837 0 : gcc_unreachable ();
6838 :
6839 354 : tmp1 = build2 (LT_EXPR, logical_type_node, rounded,
6840 : convert (type, tmp1));
6841 354 : tmp2 = build2 (GT_EXPR, logical_type_node, rounded,
6842 : convert (type, tmp2));
6843 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6844 354 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node,
6845 : build1 (TRUTH_NOT_EXPR, logical_type_node, finite),
6846 : tmp);
6847 : }
6848 : break;
6849 :
6850 48 : case BT_INTEGER:
6851 48 : if (mold->ts.type == BT_INTEGER)
6852 : {
6853 12 : tmp1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].min_int,
6854 : x->ts.kind);
6855 12 : tmp2 = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6856 : x->ts.kind);
6857 12 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6858 : convert (type, tmp1));
6859 12 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6860 : convert (type, tmp2));
6861 12 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6862 : }
6863 36 : else if (mold->ts.type == BT_UNSIGNED)
6864 : {
6865 36 : int i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
6866 36 : tmp = build_int_cst (type, 0);
6867 36 : tmp = build2 (LT_EXPR, logical_type_node, args[0], tmp);
6868 36 : if (mpz_cmp (gfc_integer_kinds[i].huge,
6869 36 : gfc_unsigned_kinds[k].huge) > 0)
6870 : {
6871 0 : tmp2 = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6872 : x->ts.kind);
6873 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6874 : convert (type, tmp2));
6875 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp, tmp2);
6876 : }
6877 : }
6878 0 : else if (mold->ts.type == BT_REAL)
6879 : {
6880 0 : tmp2 = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6881 : mold->ts.kind, 0);
6882 0 : tmp1 = build1 (NEGATE_EXPR, TREE_TYPE (tmp2), tmp2);
6883 0 : tmp1 = build2 (LT_EXPR, logical_type_node, args[0],
6884 : convert (type, tmp1));
6885 0 : tmp2 = build2 (GT_EXPR, logical_type_node, args[0],
6886 : convert (type, tmp2));
6887 0 : tmp = build2 (TRUTH_ORIF_EXPR, logical_type_node, tmp1, tmp2);
6888 : }
6889 : else
6890 0 : gcc_unreachable ();
6891 : break;
6892 :
6893 42 : case BT_UNSIGNED:
6894 42 : if (mold->ts.type == BT_UNSIGNED)
6895 : {
6896 12 : tmp = gfc_conv_mpz_to_tree (gfc_unsigned_kinds[k].huge,
6897 : x->ts.kind);
6898 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6899 : convert (type, tmp));
6900 : }
6901 30 : else if (mold->ts.type == BT_INTEGER)
6902 : {
6903 18 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[k].huge,
6904 : x->ts.kind);
6905 18 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6906 : convert (type, tmp));
6907 : }
6908 12 : else if (mold->ts.type == BT_REAL)
6909 : {
6910 12 : tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge,
6911 : mold->ts.kind, 0);
6912 12 : tmp = build2 (GT_EXPR, logical_type_node, args[0],
6913 : convert (type, tmp));
6914 : }
6915 : else
6916 0 : gcc_unreachable ();
6917 : break;
6918 :
6919 0 : default:
6920 0 : gcc_unreachable ();
6921 : }
6922 :
6923 468 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
6924 468 : }
6925 :
6926 :
6927 : /* Set or clear a single bit. */
6928 : static void
6929 306 : gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6930 : {
6931 306 : tree args[2];
6932 306 : tree type;
6933 306 : tree tmp;
6934 306 : enum tree_code op;
6935 :
6936 306 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6937 306 : type = TREE_TYPE (args[0]);
6938 :
6939 : /* Optionally generate code for runtime argument check. */
6940 306 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6941 : {
6942 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6943 : logical_type_node, args[1],
6944 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6945 12 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6946 12 : tree above = fold_build2_loc (input_location, GE_EXPR,
6947 : logical_type_node, args[1], nbits);
6948 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6949 : logical_type_node, below, above);
6950 12 : size_t len_name = strlen (expr->value.function.isym->name);
6951 12 : char *name = XALLOCAVEC (char, len_name + 1);
6952 72 : for (size_t i = 0; i < len_name; i++)
6953 60 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
6954 12 : name[len_name] = '\0';
6955 12 : tree iname = gfc_build_addr_expr (pchar_type_node,
6956 : gfc_build_cstring_const (name));
6957 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6958 : "POS argument (%ld) out of range 0:%ld "
6959 : "in intrinsic %s",
6960 : fold_convert (long_integer_type_node, args[1]),
6961 : fold_convert (long_integer_type_node, nbits),
6962 : iname);
6963 : }
6964 :
6965 306 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6966 : build_int_cst (type, 1), args[1]);
6967 306 : if (set)
6968 : op = BIT_IOR_EXPR;
6969 : else
6970 : {
6971 168 : op = BIT_AND_EXPR;
6972 168 : tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6973 : }
6974 306 : se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6975 306 : }
6976 :
6977 : /* Extract a sequence of bits.
6978 : IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6979 : static void
6980 27 : gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6981 : {
6982 27 : tree args[3];
6983 27 : tree type;
6984 27 : tree tmp;
6985 27 : tree mask;
6986 27 : tree num_bits, cond;
6987 :
6988 27 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
6989 27 : type = TREE_TYPE (args[0]);
6990 :
6991 : /* Optionally generate code for runtime argument check. */
6992 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6993 : {
6994 12 : tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6995 12 : tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6996 12 : tree nbits = build_int_cst (long_integer_type_node,
6997 12 : TYPE_PRECISION (type));
6998 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6999 : logical_type_node, args[1],
7000 12 : build_int_cst (TREE_TYPE (args[1]), 0));
7001 12 : tree above = fold_build2_loc (input_location, GT_EXPR,
7002 : logical_type_node, tmp1, nbits);
7003 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7004 : logical_type_node, below, above);
7005 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7006 : "POS argument (%ld) out of range 0:%ld "
7007 : "in intrinsic IBITS", tmp1, nbits);
7008 12 : below = fold_build2_loc (input_location, LT_EXPR,
7009 : logical_type_node, args[2],
7010 12 : build_int_cst (TREE_TYPE (args[2]), 0));
7011 12 : above = fold_build2_loc (input_location, GT_EXPR,
7012 : logical_type_node, tmp2, nbits);
7013 12 : scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7014 : logical_type_node, below, above);
7015 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7016 : "LEN argument (%ld) out of range 0:%ld "
7017 : "in intrinsic IBITS", tmp2, nbits);
7018 12 : above = fold_build2_loc (input_location, PLUS_EXPR,
7019 : long_integer_type_node, tmp1, tmp2);
7020 12 : scond = fold_build2_loc (input_location, GT_EXPR,
7021 : logical_type_node, above, nbits);
7022 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7023 : "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
7024 : "in intrinsic IBITS", tmp1, tmp2, nbits);
7025 : }
7026 :
7027 : /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
7028 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7029 : special case. See also gfc_conv_intrinsic_ishft (). */
7030 27 : num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
7031 :
7032 27 : mask = build_int_cst (type, -1);
7033 27 : mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
7034 27 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
7035 : num_bits);
7036 27 : mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
7037 : build_int_cst (type, 0), mask);
7038 27 : mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
7039 :
7040 27 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
7041 :
7042 27 : se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
7043 27 : }
7044 :
7045 : static void
7046 492 : gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
7047 : bool arithmetic)
7048 : {
7049 492 : tree args[2], type, num_bits, cond;
7050 492 : tree bigshift;
7051 492 : bool do_convert = false;
7052 :
7053 492 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7054 :
7055 492 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7056 492 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7057 492 : type = TREE_TYPE (args[0]);
7058 :
7059 492 : if (!arithmetic)
7060 : {
7061 390 : args[0] = fold_convert (unsigned_type_for (type), args[0]);
7062 390 : do_convert = true;
7063 : }
7064 : else
7065 102 : gcc_assert (right_shift);
7066 :
7067 492 : if (flag_unsigned && arithmetic && expr->ts.type == BT_UNSIGNED)
7068 : {
7069 30 : do_convert = true;
7070 30 : args[0] = fold_convert (signed_type_for (type), args[0]);
7071 : }
7072 :
7073 816 : se->expr = fold_build2_loc (input_location,
7074 : right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
7075 492 : TREE_TYPE (args[0]), args[0], args[1]);
7076 :
7077 492 : if (do_convert)
7078 420 : se->expr = fold_convert (type, se->expr);
7079 :
7080 492 : if (!arithmetic)
7081 390 : bigshift = build_int_cst (type, 0);
7082 : else
7083 : {
7084 102 : tree nonneg = fold_build2_loc (input_location, GE_EXPR,
7085 : logical_type_node, args[0],
7086 102 : build_int_cst (TREE_TYPE (args[0]), 0));
7087 102 : bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
7088 : build_int_cst (type, 0),
7089 : build_int_cst (type, -1));
7090 : }
7091 :
7092 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7093 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7094 : special case. */
7095 492 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7096 :
7097 : /* Optionally generate code for runtime argument check. */
7098 492 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7099 : {
7100 30 : tree below = fold_build2_loc (input_location, LT_EXPR,
7101 : logical_type_node, args[1],
7102 30 : build_int_cst (TREE_TYPE (args[1]), 0));
7103 30 : tree above = fold_build2_loc (input_location, GT_EXPR,
7104 : logical_type_node, args[1], num_bits);
7105 30 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7106 : logical_type_node, below, above);
7107 30 : size_t len_name = strlen (expr->value.function.isym->name);
7108 30 : char *name = XALLOCAVEC (char, len_name + 1);
7109 210 : for (size_t i = 0; i < len_name; i++)
7110 180 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
7111 30 : name[len_name] = '\0';
7112 30 : tree iname = gfc_build_addr_expr (pchar_type_node,
7113 : gfc_build_cstring_const (name));
7114 30 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7115 : "SHIFT argument (%ld) out of range 0:%ld "
7116 : "in intrinsic %s",
7117 : fold_convert (long_integer_type_node, args[1]),
7118 : fold_convert (long_integer_type_node, num_bits),
7119 : iname);
7120 : }
7121 :
7122 492 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7123 : args[1], num_bits);
7124 :
7125 492 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7126 : bigshift, se->expr);
7127 492 : }
7128 :
7129 : /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
7130 : ? 0
7131 : : ((shift >= 0) ? i << shift : i >> -shift)
7132 : where all shifts are logical shifts. */
7133 : static void
7134 318 : gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
7135 : {
7136 318 : tree args[2];
7137 318 : tree type;
7138 318 : tree utype;
7139 318 : tree tmp;
7140 318 : tree width;
7141 318 : tree num_bits;
7142 318 : tree cond;
7143 318 : tree lshift;
7144 318 : tree rshift;
7145 :
7146 318 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7147 :
7148 318 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7149 318 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7150 :
7151 318 : type = TREE_TYPE (args[0]);
7152 318 : utype = unsigned_type_for (type);
7153 :
7154 318 : width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
7155 : args[1]);
7156 :
7157 : /* Left shift if positive. */
7158 318 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
7159 :
7160 : /* Right shift if negative.
7161 : We convert to an unsigned type because we want a logical shift.
7162 : The standard doesn't define the case of shifting negative
7163 : numbers, and we try to be compatible with other compilers, most
7164 : notably g77, here. */
7165 318 : rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
7166 : utype, convert (utype, args[0]), width));
7167 :
7168 318 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
7169 318 : build_int_cst (TREE_TYPE (args[1]), 0));
7170 318 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
7171 :
7172 : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
7173 : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
7174 : special case. */
7175 318 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
7176 :
7177 : /* Optionally generate code for runtime argument check. */
7178 318 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7179 : {
7180 24 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7181 : logical_type_node, width, num_bits);
7182 24 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7183 : "SHIFT argument (%ld) out of range -%ld:%ld "
7184 : "in intrinsic ISHFT",
7185 : fold_convert (long_integer_type_node, args[1]),
7186 : fold_convert (long_integer_type_node, num_bits),
7187 : fold_convert (long_integer_type_node, num_bits));
7188 : }
7189 :
7190 318 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
7191 : num_bits);
7192 318 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7193 : build_int_cst (type, 0), tmp);
7194 318 : }
7195 :
7196 :
7197 : /* Circular shift. AKA rotate or barrel shift. */
7198 :
7199 : static void
7200 658 : gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
7201 : {
7202 658 : tree *args;
7203 658 : tree type;
7204 658 : tree tmp;
7205 658 : tree lrot;
7206 658 : tree rrot;
7207 658 : tree zero;
7208 658 : tree nbits;
7209 658 : unsigned int num_args;
7210 :
7211 658 : num_args = gfc_intrinsic_argument_list_length (expr);
7212 658 : args = XALLOCAVEC (tree, num_args);
7213 :
7214 658 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7215 :
7216 658 : type = TREE_TYPE (args[0]);
7217 658 : nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
7218 :
7219 658 : if (num_args == 3)
7220 : {
7221 550 : gfc_expr *size = expr->value.function.actual->next->next->expr;
7222 :
7223 : /* Use a library function for the 3 parameter version. */
7224 550 : tree int4type = gfc_get_int_type (4);
7225 :
7226 : /* Treat optional SIZE argument when it is passed as an optional
7227 : dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
7228 550 : if (size->expr_type == EXPR_VARIABLE
7229 438 : && size->symtree->n.sym->attr.dummy
7230 36 : && size->symtree->n.sym->attr.optional)
7231 : {
7232 36 : tree type_of_size = TREE_TYPE (args[2]);
7233 72 : args[2] = build3_loc (input_location, COND_EXPR, type_of_size,
7234 36 : gfc_conv_expr_present (size->symtree->n.sym),
7235 : args[2], fold_convert (type_of_size, nbits));
7236 : }
7237 :
7238 : /* We convert the first argument to at least 4 bytes, and
7239 : convert back afterwards. This removes the need for library
7240 : functions for all argument sizes, and function will be
7241 : aligned to at least 32 bits, so there's no loss. */
7242 550 : if (expr->ts.kind < 4)
7243 242 : args[0] = convert (int4type, args[0]);
7244 :
7245 : /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
7246 : need loads of library functions. They cannot have values >
7247 : BIT_SIZE (I) so the conversion is safe. */
7248 550 : args[1] = convert (int4type, args[1]);
7249 550 : args[2] = convert (int4type, args[2]);
7250 :
7251 : /* Optionally generate code for runtime argument check. */
7252 550 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7253 : {
7254 18 : tree size = fold_convert (long_integer_type_node, args[2]);
7255 18 : tree below = fold_build2_loc (input_location, LE_EXPR,
7256 : logical_type_node, size,
7257 18 : build_int_cst (TREE_TYPE (args[1]), 0));
7258 18 : tree above = fold_build2_loc (input_location, GT_EXPR,
7259 : logical_type_node, size, nbits);
7260 18 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7261 : logical_type_node, below, above);
7262 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7263 : "SIZE argument (%ld) out of range 1:%ld "
7264 : "in intrinsic ISHFTC", size, nbits);
7265 18 : tree width = fold_convert (long_integer_type_node, args[1]);
7266 18 : width = fold_build1_loc (input_location, ABS_EXPR,
7267 : long_integer_type_node, width);
7268 18 : scond = fold_build2_loc (input_location, GT_EXPR,
7269 : logical_type_node, width, size);
7270 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
7271 : "SHIFT argument (%ld) out of range -%ld:%ld "
7272 : "in intrinsic ISHFTC",
7273 : fold_convert (long_integer_type_node, args[1]),
7274 : size, size);
7275 : }
7276 :
7277 550 : switch (expr->ts.kind)
7278 : {
7279 426 : case 1:
7280 426 : case 2:
7281 426 : case 4:
7282 426 : tmp = gfor_fndecl_math_ishftc4;
7283 426 : break;
7284 124 : case 8:
7285 124 : tmp = gfor_fndecl_math_ishftc8;
7286 124 : break;
7287 0 : case 16:
7288 0 : tmp = gfor_fndecl_math_ishftc16;
7289 0 : break;
7290 0 : default:
7291 0 : gcc_unreachable ();
7292 : }
7293 550 : se->expr = build_call_expr_loc (input_location,
7294 : tmp, 3, args[0], args[1], args[2]);
7295 : /* Convert the result back to the original type, if we extended
7296 : the first argument's width above. */
7297 550 : if (expr->ts.kind < 4)
7298 242 : se->expr = convert (type, se->expr);
7299 :
7300 : return;
7301 : }
7302 :
7303 : /* Evaluate arguments only once. */
7304 108 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7305 108 : args[1] = gfc_evaluate_now (args[1], &se->pre);
7306 :
7307 : /* Optionally generate code for runtime argument check. */
7308 108 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
7309 : {
7310 12 : tree width = fold_convert (long_integer_type_node, args[1]);
7311 12 : width = fold_build1_loc (input_location, ABS_EXPR,
7312 : long_integer_type_node, width);
7313 12 : tree outside = fold_build2_loc (input_location, GT_EXPR,
7314 : logical_type_node, width, nbits);
7315 12 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
7316 : "SHIFT argument (%ld) out of range -%ld:%ld "
7317 : "in intrinsic ISHFTC",
7318 : fold_convert (long_integer_type_node, args[1]),
7319 : nbits, nbits);
7320 : }
7321 :
7322 : /* Rotate left if positive. */
7323 108 : lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
7324 :
7325 : /* Rotate right if negative. */
7326 108 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
7327 : args[1]);
7328 108 : rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
7329 :
7330 108 : zero = build_int_cst (TREE_TYPE (args[1]), 0);
7331 108 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
7332 : zero);
7333 108 : rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
7334 :
7335 : /* Do nothing if shift == 0. */
7336 108 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
7337 : zero);
7338 108 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
7339 : rrot);
7340 : }
7341 :
7342 :
7343 : /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
7344 : : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
7345 :
7346 : The conditional expression is necessary because the result of LEADZ(0)
7347 : is defined, but the result of __builtin_clz(0) is undefined for most
7348 : targets.
7349 :
7350 : For INTEGER kinds smaller than the C 'int' type, we have to subtract the
7351 : difference in bit size between the argument of LEADZ and the C int. */
7352 :
7353 : static void
7354 270 : gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7355 : {
7356 270 : tree arg;
7357 270 : tree arg_type;
7358 270 : tree cond;
7359 270 : tree result_type;
7360 270 : tree leadz;
7361 270 : tree bit_size;
7362 270 : tree tmp;
7363 270 : tree func;
7364 270 : int s, argsize;
7365 :
7366 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7367 270 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7368 :
7369 : /* Which variant of __builtin_clz* should we call? */
7370 270 : if (argsize <= INT_TYPE_SIZE)
7371 : {
7372 183 : arg_type = unsigned_type_node;
7373 183 : func = builtin_decl_explicit (BUILT_IN_CLZ);
7374 : }
7375 87 : else if (argsize <= LONG_TYPE_SIZE)
7376 : {
7377 57 : arg_type = long_unsigned_type_node;
7378 57 : func = builtin_decl_explicit (BUILT_IN_CLZL);
7379 : }
7380 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7381 : {
7382 0 : arg_type = long_long_unsigned_type_node;
7383 0 : func = builtin_decl_explicit (BUILT_IN_CLZLL);
7384 : }
7385 : else
7386 : {
7387 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7388 30 : arg_type = gfc_build_uint_type (argsize);
7389 30 : func = NULL_TREE;
7390 : }
7391 :
7392 : /* Convert the actual argument twice: first, to the unsigned type of the
7393 : same size; then, to the proper argument type for the built-in
7394 : function. But the return type is of the default INTEGER kind. */
7395 270 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7396 270 : arg = fold_convert (arg_type, arg);
7397 270 : arg = gfc_evaluate_now (arg, &se->pre);
7398 270 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7399 :
7400 : /* Compute LEADZ for the case i .ne. 0. */
7401 270 : if (func)
7402 : {
7403 240 : s = TYPE_PRECISION (arg_type) - argsize;
7404 240 : tmp = fold_convert (result_type,
7405 : build_call_expr_loc (input_location, func,
7406 : 1, arg));
7407 240 : leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7408 240 : tmp, build_int_cst (result_type, s));
7409 : }
7410 : else
7411 : {
7412 : /* We end up here if the argument type is larger than 'long long'.
7413 : We generate this code:
7414 :
7415 : if (x & (ULL_MAX << ULL_SIZE) != 0)
7416 : return clzll ((unsigned long long) (x >> ULLSIZE));
7417 : else
7418 : return ULL_SIZE + clzll ((unsigned long long) x);
7419 : where ULL_MAX is the largest value that a ULL_MAX can hold
7420 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7421 : is the bit-size of the long long type (64 in this example). */
7422 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7423 :
7424 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7425 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7426 : long_long_unsigned_type_node,
7427 : build_int_cst (long_long_unsigned_type_node,
7428 : 0));
7429 :
7430 30 : cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7431 : fold_convert (arg_type, ullmax), ullsize);
7432 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7433 : arg, cond);
7434 30 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7435 : cond, build_int_cst (arg_type, 0));
7436 :
7437 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7438 : arg, ullsize);
7439 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7440 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7441 30 : tmp1 = fold_convert (result_type,
7442 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7443 :
7444 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7445 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7446 30 : tmp2 = fold_convert (result_type,
7447 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7448 30 : tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7449 : tmp2, ullsize);
7450 :
7451 30 : leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7452 : cond, tmp1, tmp2);
7453 : }
7454 :
7455 : /* Build BIT_SIZE. */
7456 270 : bit_size = build_int_cst (result_type, argsize);
7457 :
7458 270 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7459 : arg, build_int_cst (arg_type, 0));
7460 270 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7461 : bit_size, leadz);
7462 270 : }
7463 :
7464 :
7465 : /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7466 :
7467 : The conditional expression is necessary because the result of TRAILZ(0)
7468 : is defined, but the result of __builtin_ctz(0) is undefined for most
7469 : targets. */
7470 :
7471 : static void
7472 282 : gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7473 : {
7474 282 : tree arg;
7475 282 : tree arg_type;
7476 282 : tree cond;
7477 282 : tree result_type;
7478 282 : tree trailz;
7479 282 : tree bit_size;
7480 282 : tree func;
7481 282 : int argsize;
7482 :
7483 282 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7484 282 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7485 :
7486 : /* Which variant of __builtin_ctz* should we call? */
7487 282 : if (argsize <= INT_TYPE_SIZE)
7488 : {
7489 195 : arg_type = unsigned_type_node;
7490 195 : func = builtin_decl_explicit (BUILT_IN_CTZ);
7491 : }
7492 87 : else if (argsize <= LONG_TYPE_SIZE)
7493 : {
7494 57 : arg_type = long_unsigned_type_node;
7495 57 : func = builtin_decl_explicit (BUILT_IN_CTZL);
7496 : }
7497 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7498 : {
7499 0 : arg_type = long_long_unsigned_type_node;
7500 0 : func = builtin_decl_explicit (BUILT_IN_CTZLL);
7501 : }
7502 : else
7503 : {
7504 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7505 30 : arg_type = gfc_build_uint_type (argsize);
7506 30 : func = NULL_TREE;
7507 : }
7508 :
7509 : /* Convert the actual argument twice: first, to the unsigned type of the
7510 : same size; then, to the proper argument type for the built-in
7511 : function. But the return type is of the default INTEGER kind. */
7512 282 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7513 282 : arg = fold_convert (arg_type, arg);
7514 282 : arg = gfc_evaluate_now (arg, &se->pre);
7515 282 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7516 :
7517 : /* Compute TRAILZ for the case i .ne. 0. */
7518 282 : if (func)
7519 252 : trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7520 : func, 1, arg));
7521 : else
7522 : {
7523 : /* We end up here if the argument type is larger than 'long long'.
7524 : We generate this code:
7525 :
7526 : if ((x & ULL_MAX) == 0)
7527 : return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7528 : else
7529 : return ctzll ((unsigned long long) x);
7530 :
7531 : where ULL_MAX is the largest value that a ULL_MAX can hold
7532 : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7533 : is the bit-size of the long long type (64 in this example). */
7534 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7535 :
7536 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7537 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7538 : long_long_unsigned_type_node,
7539 : build_int_cst (long_long_unsigned_type_node, 0));
7540 :
7541 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7542 : fold_convert (arg_type, ullmax));
7543 30 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7544 : build_int_cst (arg_type, 0));
7545 :
7546 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7547 : arg, ullsize);
7548 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7549 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7550 30 : tmp1 = fold_convert (result_type,
7551 : build_call_expr_loc (input_location, btmp, 1, tmp1));
7552 30 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7553 : tmp1, ullsize);
7554 :
7555 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7556 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7557 30 : tmp2 = fold_convert (result_type,
7558 : build_call_expr_loc (input_location, btmp, 1, tmp2));
7559 :
7560 30 : trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7561 : cond, tmp1, tmp2);
7562 : }
7563 :
7564 : /* Build BIT_SIZE. */
7565 282 : bit_size = build_int_cst (result_type, argsize);
7566 :
7567 282 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7568 : arg, build_int_cst (arg_type, 0));
7569 282 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7570 : bit_size, trailz);
7571 282 : }
7572 :
7573 : /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7574 : for types larger than "long long", we call the long long built-in for
7575 : the lower and higher bits and combine the result. */
7576 :
7577 : static void
7578 134 : gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7579 : {
7580 134 : tree arg;
7581 134 : tree arg_type;
7582 134 : tree result_type;
7583 134 : tree func;
7584 134 : int argsize;
7585 :
7586 134 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7587 134 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7588 134 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7589 :
7590 : /* Which variant of the builtin should we call? */
7591 134 : if (argsize <= INT_TYPE_SIZE)
7592 : {
7593 108 : arg_type = unsigned_type_node;
7594 198 : func = builtin_decl_explicit (parity
7595 : ? BUILT_IN_PARITY
7596 : : BUILT_IN_POPCOUNT);
7597 : }
7598 26 : else if (argsize <= LONG_TYPE_SIZE)
7599 : {
7600 12 : arg_type = long_unsigned_type_node;
7601 18 : func = builtin_decl_explicit (parity
7602 : ? BUILT_IN_PARITYL
7603 : : BUILT_IN_POPCOUNTL);
7604 : }
7605 14 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7606 : {
7607 0 : arg_type = long_long_unsigned_type_node;
7608 0 : func = builtin_decl_explicit (parity
7609 : ? BUILT_IN_PARITYLL
7610 : : BUILT_IN_POPCOUNTLL);
7611 : }
7612 : else
7613 : {
7614 : /* Our argument type is larger than 'long long', which mean none
7615 : of the POPCOUNT builtins covers it. We thus call the 'long long'
7616 : variant multiple times, and add the results. */
7617 14 : tree utype, arg2, call1, call2;
7618 :
7619 : /* For now, we only cover the case where argsize is twice as large
7620 : as 'long long'. */
7621 14 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7622 :
7623 21 : func = builtin_decl_explicit (parity
7624 : ? BUILT_IN_PARITYLL
7625 : : BUILT_IN_POPCOUNTLL);
7626 :
7627 : /* Convert it to an integer, and store into a variable. */
7628 14 : utype = gfc_build_uint_type (argsize);
7629 14 : arg = fold_convert (utype, arg);
7630 14 : arg = gfc_evaluate_now (arg, &se->pre);
7631 :
7632 : /* Call the builtin twice. */
7633 14 : call1 = build_call_expr_loc (input_location, func, 1,
7634 : fold_convert (long_long_unsigned_type_node,
7635 : arg));
7636 :
7637 14 : arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7638 : build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7639 14 : call2 = build_call_expr_loc (input_location, func, 1,
7640 : fold_convert (long_long_unsigned_type_node,
7641 : arg2));
7642 :
7643 : /* Combine the results. */
7644 14 : if (parity)
7645 7 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7646 : integer_type_node, call1, call2);
7647 : else
7648 7 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7649 : integer_type_node, call1, call2);
7650 :
7651 14 : se->expr = convert (result_type, se->expr);
7652 14 : return;
7653 : }
7654 :
7655 : /* Convert the actual argument twice: first, to the unsigned type of the
7656 : same size; then, to the proper argument type for the built-in
7657 : function. */
7658 120 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7659 120 : arg = fold_convert (arg_type, arg);
7660 :
7661 120 : se->expr = fold_convert (result_type,
7662 : build_call_expr_loc (input_location, func, 1, arg));
7663 : }
7664 :
7665 :
7666 : /* Process an intrinsic with unspecified argument-types that has an optional
7667 : argument (which could be of type character), e.g. EOSHIFT. For those, we
7668 : need to append the string length of the optional argument if it is not
7669 : present and the type is really character.
7670 : primary specifies the position (starting at 1) of the non-optional argument
7671 : specifying the type and optional gives the position of the optional
7672 : argument in the arglist. */
7673 :
7674 : static void
7675 5879 : conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7676 : unsigned primary, unsigned optional)
7677 : {
7678 5879 : gfc_actual_arglist* prim_arg;
7679 5879 : gfc_actual_arglist* opt_arg;
7680 5879 : unsigned cur_pos;
7681 5879 : gfc_actual_arglist* arg;
7682 5879 : gfc_symbol* sym;
7683 5879 : vec<tree, va_gc> *append_args;
7684 :
7685 : /* Find the two arguments given as position. */
7686 5879 : cur_pos = 0;
7687 5879 : prim_arg = NULL;
7688 5879 : opt_arg = NULL;
7689 17637 : for (arg = expr->value.function.actual; arg; arg = arg->next)
7690 : {
7691 17637 : ++cur_pos;
7692 :
7693 17637 : if (cur_pos == primary)
7694 5879 : prim_arg = arg;
7695 17637 : if (cur_pos == optional)
7696 5879 : opt_arg = arg;
7697 :
7698 17637 : if (cur_pos >= primary && cur_pos >= optional)
7699 : break;
7700 : }
7701 5879 : gcc_assert (prim_arg);
7702 5879 : gcc_assert (prim_arg->expr);
7703 5879 : gcc_assert (opt_arg);
7704 :
7705 : /* If we do have type CHARACTER and the optional argument is really absent,
7706 : append a dummy 0 as string length. */
7707 5879 : append_args = NULL;
7708 5879 : if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7709 : {
7710 608 : tree dummy;
7711 :
7712 608 : dummy = build_int_cst (gfc_charlen_type_node, 0);
7713 608 : vec_alloc (append_args, 1);
7714 608 : append_args->quick_push (dummy);
7715 : }
7716 :
7717 : /* Build the call itself. */
7718 5879 : gcc_assert (!se->ignore_optional);
7719 5879 : sym = gfc_get_symbol_for_expr (expr, false);
7720 5879 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7721 : append_args);
7722 5879 : gfc_free_symbol (sym);
7723 5879 : }
7724 :
7725 : /* The length of a character string. */
7726 : static void
7727 5946 : gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7728 : {
7729 5946 : tree len;
7730 5946 : tree type;
7731 5946 : tree decl;
7732 5946 : gfc_symbol *sym;
7733 5946 : gfc_se argse;
7734 5946 : gfc_expr *arg;
7735 :
7736 5946 : gcc_assert (!se->ss);
7737 :
7738 5946 : arg = expr->value.function.actual->expr;
7739 :
7740 5946 : type = gfc_typenode_for_spec (&expr->ts);
7741 5946 : switch (arg->expr_type)
7742 : {
7743 0 : case EXPR_CONSTANT:
7744 0 : len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7745 0 : break;
7746 :
7747 2 : case EXPR_ARRAY:
7748 : /* If there is an explicit type-spec, use it. */
7749 2 : if (arg->ts.u.cl->length && arg->ts.u.cl->length_from_typespec)
7750 : {
7751 0 : gfc_conv_string_length (arg->ts.u.cl, arg, &se->pre);
7752 0 : len = arg->ts.u.cl->backend_decl;
7753 0 : break;
7754 : }
7755 :
7756 : /* Obtain the string length from the function used by
7757 : trans-array.cc(gfc_trans_array_constructor). */
7758 2 : len = NULL_TREE;
7759 2 : get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7760 2 : break;
7761 :
7762 5359 : case EXPR_VARIABLE:
7763 5359 : if (arg->ref == NULL
7764 2416 : || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7765 : {
7766 : /* This doesn't catch all cases.
7767 : See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7768 : and the surrounding thread. */
7769 4826 : sym = arg->symtree->n.sym;
7770 4826 : decl = gfc_get_symbol_decl (sym);
7771 4826 : if (decl == current_function_decl && sym->attr.function
7772 55 : && (sym->result == sym))
7773 55 : decl = gfc_get_fake_result_decl (sym, 0);
7774 :
7775 4826 : len = sym->ts.u.cl->backend_decl;
7776 4826 : gcc_assert (len);
7777 : break;
7778 : }
7779 :
7780 : /* Fall through. */
7781 :
7782 1118 : default:
7783 1118 : gfc_init_se (&argse, se);
7784 1118 : if (arg->rank == 0)
7785 996 : gfc_conv_expr (&argse, arg);
7786 : else
7787 122 : gfc_conv_expr_descriptor (&argse, arg);
7788 1118 : gfc_add_block_to_block (&se->pre, &argse.pre);
7789 1118 : gfc_add_block_to_block (&se->post, &argse.post);
7790 1118 : len = argse.string_length;
7791 1118 : break;
7792 : }
7793 5946 : se->expr = convert (type, len);
7794 5946 : }
7795 :
7796 : /* The length of a character string not including trailing blanks. */
7797 : static void
7798 2340 : gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7799 : {
7800 2340 : int kind = expr->value.function.actual->expr->ts.kind;
7801 2340 : tree args[2], type, fndecl;
7802 :
7803 2340 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7804 2340 : type = gfc_typenode_for_spec (&expr->ts);
7805 :
7806 2340 : if (kind == 1)
7807 1938 : fndecl = gfor_fndecl_string_len_trim;
7808 402 : else if (kind == 4)
7809 402 : fndecl = gfor_fndecl_string_len_trim_char4;
7810 : else
7811 0 : gcc_unreachable ();
7812 :
7813 2340 : se->expr = build_call_expr_loc (input_location,
7814 : fndecl, 2, args[0], args[1]);
7815 2340 : se->expr = convert (type, se->expr);
7816 2340 : }
7817 :
7818 :
7819 : /* Returns the starting position of a substring within a string. */
7820 :
7821 : static void
7822 751 : gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7823 : tree function)
7824 : {
7825 751 : tree logical4_type_node = gfc_get_logical_type (4);
7826 751 : tree type;
7827 751 : tree fndecl;
7828 751 : tree *args;
7829 751 : unsigned int num_args;
7830 :
7831 751 : args = XALLOCAVEC (tree, 5);
7832 :
7833 : /* Get number of arguments; characters count double due to the
7834 : string length argument. Kind= is not passed to the library
7835 : and thus ignored. */
7836 751 : if (expr->value.function.actual->next->next->expr == NULL)
7837 : num_args = 4;
7838 : else
7839 304 : num_args = 5;
7840 :
7841 751 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7842 751 : type = gfc_typenode_for_spec (&expr->ts);
7843 :
7844 751 : if (num_args == 4)
7845 447 : args[4] = build_int_cst (logical4_type_node, 0);
7846 : else
7847 304 : args[4] = convert (logical4_type_node, args[4]);
7848 :
7849 751 : fndecl = build_addr (function);
7850 751 : se->expr = build_call_array_loc (input_location,
7851 751 : TREE_TYPE (TREE_TYPE (function)), fndecl,
7852 : 5, args);
7853 751 : se->expr = convert (type, se->expr);
7854 :
7855 751 : }
7856 :
7857 : /* The ascii value for a single character. */
7858 : static void
7859 2033 : gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7860 : {
7861 2033 : tree args[3], type, pchartype;
7862 2033 : int nargs;
7863 :
7864 2033 : nargs = gfc_intrinsic_argument_list_length (expr);
7865 2033 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7866 2033 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7867 2033 : pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7868 2033 : args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7869 2033 : type = gfc_typenode_for_spec (&expr->ts);
7870 :
7871 2033 : se->expr = build_fold_indirect_ref_loc (input_location,
7872 : args[1]);
7873 2033 : se->expr = convert (type, se->expr);
7874 2033 : }
7875 :
7876 :
7877 : /* Intrinsic ISNAN calls __builtin_isnan. */
7878 :
7879 : static void
7880 432 : gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7881 : {
7882 432 : tree arg;
7883 :
7884 432 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7885 432 : se->expr = build_call_expr_loc (input_location,
7886 : builtin_decl_explicit (BUILT_IN_ISNAN),
7887 : 1, arg);
7888 864 : STRIP_TYPE_NOPS (se->expr);
7889 432 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7890 432 : }
7891 :
7892 :
7893 : /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7894 : their argument against a constant integer value. */
7895 :
7896 : static void
7897 24 : gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7898 : {
7899 24 : tree arg;
7900 :
7901 24 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7902 24 : se->expr = fold_build2_loc (input_location, EQ_EXPR,
7903 : gfc_typenode_for_spec (&expr->ts),
7904 24 : arg, build_int_cst (TREE_TYPE (arg), value));
7905 24 : }
7906 :
7907 :
7908 :
7909 : /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7910 :
7911 : static void
7912 953 : gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7913 : {
7914 953 : tree tsource;
7915 953 : tree fsource;
7916 953 : tree mask;
7917 953 : tree type;
7918 953 : tree len, len2;
7919 953 : tree *args;
7920 953 : unsigned int num_args;
7921 :
7922 953 : num_args = gfc_intrinsic_argument_list_length (expr);
7923 953 : args = XALLOCAVEC (tree, num_args);
7924 :
7925 953 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7926 953 : if (expr->ts.type != BT_CHARACTER)
7927 : {
7928 426 : tsource = args[0];
7929 426 : fsource = args[1];
7930 426 : mask = args[2];
7931 : }
7932 : else
7933 : {
7934 : /* We do the same as in the non-character case, but the argument
7935 : list is different because of the string length arguments. We
7936 : also have to set the string length for the result. */
7937 527 : len = args[0];
7938 527 : tsource = args[1];
7939 527 : len2 = args[2];
7940 527 : fsource = args[3];
7941 527 : mask = args[4];
7942 :
7943 527 : gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7944 : &se->pre);
7945 527 : se->string_length = len;
7946 : }
7947 953 : tsource = gfc_evaluate_now (tsource, &se->pre);
7948 953 : fsource = gfc_evaluate_now (fsource, &se->pre);
7949 953 : mask = gfc_evaluate_now (mask, &se->pre);
7950 953 : type = TREE_TYPE (tsource);
7951 953 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7952 : fold_convert (type, fsource));
7953 953 : }
7954 :
7955 :
7956 : /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7957 :
7958 : static void
7959 42 : gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7960 : {
7961 42 : tree args[3], mask, type;
7962 :
7963 42 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
7964 42 : mask = gfc_evaluate_now (args[2], &se->pre);
7965 :
7966 42 : type = TREE_TYPE (args[0]);
7967 42 : gcc_assert (TREE_TYPE (args[1]) == type);
7968 42 : gcc_assert (TREE_TYPE (mask) == type);
7969 :
7970 42 : args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7971 42 : args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7972 : fold_build1_loc (input_location, BIT_NOT_EXPR,
7973 : type, mask));
7974 42 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7975 : args[0], args[1]);
7976 42 : }
7977 :
7978 :
7979 : /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7980 : MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7981 :
7982 : static void
7983 64 : gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7984 : {
7985 64 : tree arg, allones, type, utype, res, cond, bitsize;
7986 64 : int i;
7987 :
7988 64 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7989 64 : arg = gfc_evaluate_now (arg, &se->pre);
7990 :
7991 64 : type = gfc_get_int_type (expr->ts.kind);
7992 64 : utype = unsigned_type_for (type);
7993 :
7994 64 : i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7995 64 : bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7996 :
7997 64 : allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7998 : build_int_cst (utype, 0));
7999 :
8000 64 : if (left)
8001 : {
8002 : /* Left-justified mask. */
8003 32 : res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
8004 : bitsize, arg);
8005 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
8006 : fold_convert (utype, res));
8007 :
8008 : /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
8009 : smaller than type width. */
8010 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8011 32 : build_int_cst (TREE_TYPE (arg), 0));
8012 32 : res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
8013 : build_int_cst (utype, 0), res);
8014 : }
8015 : else
8016 : {
8017 : /* Right-justified mask. */
8018 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
8019 : fold_convert (utype, arg));
8020 32 : res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
8021 :
8022 : /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
8023 : strictly smaller than type width. */
8024 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
8025 : arg, bitsize);
8026 32 : res = fold_build3_loc (input_location, COND_EXPR, utype,
8027 : cond, allones, res);
8028 : }
8029 :
8030 64 : se->expr = fold_convert (type, res);
8031 64 : }
8032 :
8033 :
8034 : /* FRACTION (s) is translated into:
8035 : isfinite (s) ? frexp (s, &dummy_int) : NaN */
8036 : static void
8037 60 : gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
8038 : {
8039 60 : tree arg, type, tmp, res, frexp, cond;
8040 :
8041 60 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8042 :
8043 60 : type = gfc_typenode_for_spec (&expr->ts);
8044 60 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8045 60 : arg = gfc_evaluate_now (arg, &se->pre);
8046 :
8047 60 : cond = build_call_expr_loc (input_location,
8048 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8049 : 1, arg);
8050 :
8051 60 : tmp = gfc_create_var (integer_type_node, NULL);
8052 60 : res = build_call_expr_loc (input_location, frexp, 2,
8053 : fold_convert (type, arg),
8054 : gfc_build_addr_expr (NULL_TREE, tmp));
8055 60 : res = fold_convert (type, res);
8056 :
8057 60 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
8058 : cond, res, gfc_build_nan (type, ""));
8059 60 : }
8060 :
8061 :
8062 : /* NEAREST (s, dir) is translated into
8063 : tmp = copysign (HUGE_VAL, dir);
8064 : return nextafter (s, tmp);
8065 : */
8066 : static void
8067 1595 : gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
8068 : {
8069 1595 : tree args[2], type, tmp, nextafter, copysign, huge_val;
8070 :
8071 1595 : nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
8072 1595 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
8073 :
8074 1595 : type = gfc_typenode_for_spec (&expr->ts);
8075 1595 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8076 :
8077 1595 : huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
8078 1595 : tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
8079 : fold_convert (type, args[1]));
8080 1595 : se->expr = build_call_expr_loc (input_location, nextafter, 2,
8081 : fold_convert (type, args[0]), tmp);
8082 1595 : se->expr = fold_convert (type, se->expr);
8083 1595 : }
8084 :
8085 :
8086 : /* SPACING (s) is translated into
8087 : int e;
8088 : if (!isfinite (s))
8089 : res = NaN;
8090 : else if (s == 0)
8091 : res = tiny;
8092 : else
8093 : {
8094 : frexp (s, &e);
8095 : e = e - prec;
8096 : e = MAX_EXPR (e, emin);
8097 : res = scalbn (1., e);
8098 : }
8099 : return res;
8100 :
8101 : where prec is the precision of s, gfc_real_kinds[k].digits,
8102 : emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
8103 : and tiny is tiny(s), gfc_real_kinds[k].tiny. */
8104 :
8105 : static void
8106 70 : gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
8107 : {
8108 70 : tree arg, type, prec, emin, tiny, res, e;
8109 70 : tree cond, nan, tmp, frexp, scalbn;
8110 70 : int k;
8111 70 : stmtblock_t block;
8112 :
8113 70 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8114 70 : prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
8115 70 : emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
8116 70 : tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
8117 :
8118 70 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8119 70 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8120 :
8121 70 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8122 70 : arg = gfc_evaluate_now (arg, &se->pre);
8123 :
8124 70 : type = gfc_typenode_for_spec (&expr->ts);
8125 70 : e = gfc_create_var (integer_type_node, NULL);
8126 70 : res = gfc_create_var (type, NULL);
8127 :
8128 :
8129 : /* Build the block for s /= 0. */
8130 70 : gfc_start_block (&block);
8131 70 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8132 : gfc_build_addr_expr (NULL_TREE, e));
8133 70 : gfc_add_expr_to_block (&block, tmp);
8134 :
8135 70 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
8136 : prec);
8137 70 : gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
8138 : integer_type_node, tmp, emin));
8139 :
8140 70 : tmp = build_call_expr_loc (input_location, scalbn, 2,
8141 70 : build_real_from_int_cst (type, integer_one_node), e);
8142 70 : gfc_add_modify (&block, res, tmp);
8143 :
8144 : /* Finish by building the IF statement for value zero. */
8145 70 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
8146 70 : build_real_from_int_cst (type, integer_zero_node));
8147 70 : tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
8148 : gfc_finish_block (&block));
8149 :
8150 : /* And deal with infinities and NaNs. */
8151 70 : cond = build_call_expr_loc (input_location,
8152 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8153 : 1, arg);
8154 70 : nan = gfc_build_nan (type, "");
8155 70 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
8156 :
8157 70 : gfc_add_expr_to_block (&se->pre, tmp);
8158 70 : se->expr = res;
8159 70 : }
8160 :
8161 :
8162 : /* RRSPACING (s) is translated into
8163 : int e;
8164 : real x;
8165 : x = fabs (s);
8166 : if (isfinite (x))
8167 : {
8168 : if (x != 0)
8169 : {
8170 : frexp (s, &e);
8171 : x = scalbn (x, precision - e);
8172 : }
8173 : }
8174 : else
8175 : x = NaN;
8176 : return x;
8177 :
8178 : where precision is gfc_real_kinds[k].digits. */
8179 :
8180 : static void
8181 48 : gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
8182 : {
8183 48 : tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
8184 48 : int prec, k;
8185 48 : stmtblock_t block;
8186 :
8187 48 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
8188 48 : prec = gfc_real_kinds[k].digits;
8189 :
8190 48 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8191 48 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8192 48 : fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
8193 :
8194 48 : type = gfc_typenode_for_spec (&expr->ts);
8195 48 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8196 48 : arg = gfc_evaluate_now (arg, &se->pre);
8197 :
8198 48 : e = gfc_create_var (integer_type_node, NULL);
8199 48 : x = gfc_create_var (type, NULL);
8200 48 : gfc_add_modify (&se->pre, x,
8201 : build_call_expr_loc (input_location, fabs, 1, arg));
8202 :
8203 :
8204 48 : gfc_start_block (&block);
8205 48 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
8206 : gfc_build_addr_expr (NULL_TREE, e));
8207 48 : gfc_add_expr_to_block (&block, tmp);
8208 :
8209 48 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
8210 48 : build_int_cst (integer_type_node, prec), e);
8211 48 : tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
8212 48 : gfc_add_modify (&block, x, tmp);
8213 48 : stmt = gfc_finish_block (&block);
8214 :
8215 : /* if (x != 0) */
8216 48 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
8217 48 : build_real_from_int_cst (type, integer_zero_node));
8218 48 : tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
8219 :
8220 : /* And deal with infinities and NaNs. */
8221 48 : cond = build_call_expr_loc (input_location,
8222 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8223 : 1, x);
8224 48 : nan = gfc_build_nan (type, "");
8225 48 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
8226 :
8227 48 : gfc_add_expr_to_block (&se->pre, tmp);
8228 48 : se->expr = fold_convert (type, x);
8229 48 : }
8230 :
8231 :
8232 : /* SCALE (s, i) is translated into scalbn (s, i). */
8233 : static void
8234 72 : gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
8235 : {
8236 72 : tree args[2], type, scalbn;
8237 :
8238 72 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8239 :
8240 72 : type = gfc_typenode_for_spec (&expr->ts);
8241 72 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8242 72 : se->expr = build_call_expr_loc (input_location, scalbn, 2,
8243 : fold_convert (type, args[0]),
8244 : fold_convert (integer_type_node, args[1]));
8245 72 : se->expr = fold_convert (type, se->expr);
8246 72 : }
8247 :
8248 :
8249 : /* SET_EXPONENT (s, i) is translated into
8250 : isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
8251 : static void
8252 262 : gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
8253 : {
8254 262 : tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
8255 :
8256 262 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
8257 262 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
8258 :
8259 262 : type = gfc_typenode_for_spec (&expr->ts);
8260 262 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
8261 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
8262 :
8263 262 : tmp = gfc_create_var (integer_type_node, NULL);
8264 262 : tmp = build_call_expr_loc (input_location, frexp, 2,
8265 : fold_convert (type, args[0]),
8266 : gfc_build_addr_expr (NULL_TREE, tmp));
8267 262 : res = build_call_expr_loc (input_location, scalbn, 2, tmp,
8268 : fold_convert (integer_type_node, args[1]));
8269 262 : res = fold_convert (type, res);
8270 :
8271 : /* Call to isfinite */
8272 262 : cond = build_call_expr_loc (input_location,
8273 : builtin_decl_explicit (BUILT_IN_ISFINITE),
8274 : 1, args[0]);
8275 262 : nan = gfc_build_nan (type, "");
8276 :
8277 262 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
8278 : res, nan);
8279 262 : }
8280 :
8281 :
8282 : static void
8283 15667 : gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
8284 : {
8285 15667 : gfc_actual_arglist *actual;
8286 15667 : tree arg1;
8287 15667 : tree type;
8288 15667 : tree size;
8289 15667 : gfc_se argse;
8290 15667 : gfc_expr *e;
8291 15667 : gfc_symbol *sym = NULL;
8292 :
8293 15667 : gfc_init_se (&argse, NULL);
8294 15667 : actual = expr->value.function.actual;
8295 :
8296 15667 : if (actual->expr->ts.type == BT_CLASS)
8297 627 : gfc_add_class_array_ref (actual->expr);
8298 :
8299 15667 : e = actual->expr;
8300 :
8301 : /* These are emerging from the interface mapping, when a class valued
8302 : function appears as the rhs in a realloc on assign statement, where
8303 : the size of the result is that of one of the actual arguments. */
8304 15667 : if (e->expr_type == EXPR_VARIABLE
8305 15185 : && e->symtree->n.sym->ns == NULL /* This is distinctive! */
8306 573 : && e->symtree->n.sym->ts.type == BT_CLASS
8307 62 : && e->ref && e->ref->type == REF_COMPONENT
8308 44 : && strcmp (e->ref->u.c.component->name, "_data") == 0)
8309 15667 : sym = e->symtree->n.sym;
8310 :
8311 15667 : if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
8312 : && e
8313 854 : && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
8314 : {
8315 854 : symbol_attribute attr;
8316 854 : char *msg;
8317 854 : tree temp;
8318 854 : tree cond;
8319 :
8320 854 : if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
8321 : {
8322 33 : attr = CLASS_DATA (e->symtree->n.sym)->attr;
8323 33 : attr.pointer = attr.class_pointer;
8324 : }
8325 : else
8326 821 : attr = gfc_expr_attr (e);
8327 :
8328 854 : if (attr.allocatable)
8329 100 : msg = xasprintf ("Allocatable argument '%s' is not allocated",
8330 100 : e->symtree->n.sym->name);
8331 754 : else if (attr.pointer)
8332 46 : msg = xasprintf ("Pointer argument '%s' is not associated",
8333 46 : e->symtree->n.sym->name);
8334 : else
8335 708 : goto end_arg_check;
8336 :
8337 146 : if (sym)
8338 : {
8339 0 : temp = gfc_class_data_get (sym->backend_decl);
8340 0 : temp = gfc_conv_descriptor_data_get (temp);
8341 : }
8342 : else
8343 : {
8344 146 : argse.descriptor_only = 1;
8345 146 : gfc_conv_expr_descriptor (&argse, actual->expr);
8346 146 : temp = gfc_conv_descriptor_data_get (argse.expr);
8347 : }
8348 :
8349 146 : cond = fold_build2_loc (input_location, EQ_EXPR,
8350 : logical_type_node, temp,
8351 146 : fold_convert (TREE_TYPE (temp),
8352 : null_pointer_node));
8353 146 : gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
8354 :
8355 146 : free (msg);
8356 : }
8357 14813 : end_arg_check:
8358 :
8359 15667 : argse.data_not_needed = 1;
8360 15667 : if (gfc_is_class_array_function (e))
8361 : {
8362 : /* For functions that return a class array conv_expr_descriptor is not
8363 : able to get the descriptor right. Therefore this special case. */
8364 7 : gfc_conv_expr_reference (&argse, e);
8365 7 : argse.expr = gfc_class_data_get (argse.expr);
8366 : }
8367 15660 : else if (sym && sym->backend_decl)
8368 : {
8369 32 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8370 32 : argse.expr = gfc_class_data_get (sym->backend_decl);
8371 : }
8372 : else
8373 15628 : gfc_conv_expr_descriptor (&argse, actual->expr);
8374 15667 : gfc_add_block_to_block (&se->pre, &argse.pre);
8375 15667 : gfc_add_block_to_block (&se->post, &argse.post);
8376 15667 : arg1 = argse.expr;
8377 :
8378 15667 : actual = actual->next;
8379 15667 : if (actual->expr)
8380 : {
8381 9367 : stmtblock_t block;
8382 9367 : gfc_init_block (&block);
8383 9367 : gfc_init_se (&argse, NULL);
8384 9367 : gfc_conv_expr_type (&argse, actual->expr,
8385 : gfc_array_index_type);
8386 9367 : gfc_add_block_to_block (&block, &argse.pre);
8387 9367 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8388 : argse.expr, gfc_index_one_node);
8389 9367 : size = gfc_tree_array_size (&block, arg1, e, tmp);
8390 :
8391 : /* Unusually, for an intrinsic, size does not exclude
8392 : an optional arg2, so we must test for it. */
8393 9367 : if (actual->expr->expr_type == EXPR_VARIABLE
8394 2571 : && actual->expr->symtree->n.sym->attr.dummy
8395 31 : && actual->expr->symtree->n.sym->attr.optional)
8396 : {
8397 31 : tree cond;
8398 31 : stmtblock_t block2;
8399 31 : gfc_init_block (&block2);
8400 31 : gfc_init_se (&argse, NULL);
8401 31 : argse.want_pointer = 1;
8402 31 : argse.data_not_needed = 1;
8403 31 : gfc_conv_expr (&argse, actual->expr);
8404 31 : gfc_add_block_to_block (&se->pre, &argse.pre);
8405 : /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8406 : case; size_var can be used in both blocks. */
8407 31 : tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8408 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8409 31 : TREE_TYPE (size_var), size_var, size);
8410 31 : gfc_add_expr_to_block (&block, tmp);
8411 31 : size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8412 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8413 31 : TREE_TYPE (size_var), size_var, size);
8414 31 : gfc_add_expr_to_block (&block2, tmp);
8415 31 : cond = gfc_conv_expr_present (actual->expr->symtree->n.sym);
8416 31 : tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8417 : gfc_finish_block (&block2));
8418 31 : gfc_add_expr_to_block (&se->pre, tmp);
8419 31 : size = size_var;
8420 31 : }
8421 : else
8422 9336 : gfc_add_block_to_block (&se->pre, &block);
8423 : }
8424 : else
8425 6300 : size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8426 15667 : type = gfc_typenode_for_spec (&expr->ts);
8427 15667 : se->expr = convert (type, size);
8428 15667 : }
8429 :
8430 :
8431 : /* Helper function to compute the size of a character variable,
8432 : excluding the terminating null characters. The result has
8433 : gfc_array_index_type type. */
8434 :
8435 : tree
8436 1918 : size_of_string_in_bytes (int kind, tree string_length)
8437 : {
8438 1918 : tree bytesize;
8439 1918 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8440 :
8441 3836 : bytesize = build_int_cst (gfc_array_index_type,
8442 1918 : gfc_character_kinds[i].bit_size / 8);
8443 :
8444 1918 : return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8445 : bytesize,
8446 1918 : fold_convert (gfc_array_index_type, string_length));
8447 : }
8448 :
8449 :
8450 : static void
8451 1309 : gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8452 : {
8453 1309 : gfc_expr *arg;
8454 1309 : gfc_se argse;
8455 1309 : tree source_bytes;
8456 1309 : tree tmp;
8457 1309 : tree lower;
8458 1309 : tree upper;
8459 1309 : tree byte_size;
8460 1309 : int n;
8461 :
8462 1309 : gfc_init_se (&argse, NULL);
8463 1309 : arg = expr->value.function.actual->expr;
8464 :
8465 1309 : if (arg->rank || arg->ts.type == BT_ASSUMED)
8466 1012 : gfc_conv_expr_descriptor (&argse, arg);
8467 : else
8468 297 : gfc_conv_expr_reference (&argse, arg);
8469 :
8470 1309 : if (arg->ts.type == BT_ASSUMED)
8471 : {
8472 : /* This only works if an array descriptor has been passed; thus, extract
8473 : the size from the descriptor. */
8474 172 : gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8475 : == TYPE_PRECISION (size_type_node));
8476 172 : tmp = arg->symtree->n.sym->backend_decl;
8477 172 : tmp = DECL_LANG_SPECIFIC (tmp)
8478 60 : && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8479 226 : ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8480 172 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8481 172 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8482 :
8483 172 : tmp = gfc_conv_descriptor_elem_len_get (tmp);
8484 :
8485 172 : byte_size = fold_convert (gfc_array_index_type, tmp);
8486 : }
8487 1137 : else if (arg->ts.type == BT_CLASS)
8488 : {
8489 : /* Conv_expr_descriptor returns a component_ref to _data component of the
8490 : class object. The class object may be a non-pointer object, e.g.
8491 : located on the stack, or a memory location pointed to, e.g. a
8492 : parameter, i.e., an indirect_ref. */
8493 959 : if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8494 589 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8495 198 : byte_size
8496 198 : = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8497 391 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8498 0 : byte_size = gfc_class_vtab_size_get (argse.expr);
8499 391 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8500 391 : && TREE_CODE (argse.expr) == COMPONENT_REF)
8501 328 : byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8502 63 : else if (arg->rank > 0
8503 21 : || (arg->rank == 0
8504 21 : && arg->ref && arg->ref->type == REF_COMPONENT))
8505 : {
8506 : /* The scalarizer added an additional temp. To get the class' vptr
8507 : one has to look at the original backend_decl. */
8508 63 : if (argse.class_container)
8509 21 : byte_size = gfc_class_vtab_size_get (argse.class_container);
8510 42 : else if (DECL_LANG_SPECIFIC (arg->symtree->n.sym->backend_decl))
8511 84 : byte_size = gfc_class_vtab_size_get (
8512 42 : GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8513 : else
8514 0 : gcc_unreachable ();
8515 : }
8516 : else
8517 0 : gcc_unreachable ();
8518 : }
8519 : else
8520 : {
8521 548 : if (arg->ts.type == BT_CHARACTER)
8522 84 : byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8523 : else
8524 : {
8525 464 : if (arg->rank == 0)
8526 0 : byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8527 : argse.expr));
8528 : else
8529 464 : byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8530 464 : byte_size = fold_convert (gfc_array_index_type,
8531 : size_in_bytes (byte_size));
8532 : }
8533 : }
8534 :
8535 1309 : if (arg->rank == 0)
8536 297 : se->expr = byte_size;
8537 : else
8538 : {
8539 1012 : source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8540 1012 : gfc_add_modify (&argse.pre, source_bytes, byte_size);
8541 :
8542 1012 : if (arg->rank == -1)
8543 : {
8544 365 : tree cond, loop_var, exit_label;
8545 365 : stmtblock_t body;
8546 :
8547 365 : tmp = gfc_conv_descriptor_rank_get (argse.expr);
8548 365 : loop_var = gfc_create_var (gfc_array_dim_rank_type, "i");
8549 365 : gfc_add_modify (&argse.pre, loop_var, gfc_rank_cst[0]);
8550 365 : exit_label = gfc_build_label_decl (NULL_TREE);
8551 :
8552 : /* Create loop:
8553 : for (;;)
8554 : {
8555 : if (i >= rank)
8556 : goto exit;
8557 : source_bytes = source_bytes * array.dim[i].extent;
8558 : i = i + 1;
8559 : }
8560 : exit: */
8561 365 : gfc_start_block (&body);
8562 365 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8563 : loop_var, tmp);
8564 365 : tmp = build1_v (GOTO_EXPR, exit_label);
8565 365 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8566 : cond, tmp, build_empty_stmt (input_location));
8567 365 : gfc_add_expr_to_block (&body, tmp);
8568 :
8569 365 : lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8570 365 : upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8571 365 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8572 365 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8573 : gfc_array_index_type, tmp, source_bytes);
8574 365 : gfc_add_modify (&body, source_bytes, tmp);
8575 :
8576 365 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8577 : gfc_array_dim_rank_type, loop_var,
8578 : gfc_rank_cst[1]);
8579 365 : gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8580 :
8581 365 : tmp = gfc_finish_block (&body);
8582 :
8583 365 : tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8584 : tmp);
8585 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8586 :
8587 365 : tmp = build1_v (LABEL_EXPR, exit_label);
8588 365 : gfc_add_expr_to_block (&argse.pre, tmp);
8589 : }
8590 : else
8591 : {
8592 : /* Obtain the size of the array in bytes. */
8593 1834 : for (n = 0; n < arg->rank; n++)
8594 : {
8595 1187 : tree idx;
8596 1187 : idx = gfc_rank_cst[n];
8597 1187 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8598 1187 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8599 1187 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8600 1187 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8601 : gfc_array_index_type, tmp, source_bytes);
8602 1187 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8603 : }
8604 : }
8605 1012 : se->expr = source_bytes;
8606 : }
8607 :
8608 1309 : gfc_add_block_to_block (&se->pre, &argse.pre);
8609 1309 : }
8610 :
8611 :
8612 : static void
8613 865 : gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8614 : {
8615 865 : gfc_expr *arg;
8616 865 : gfc_se argse;
8617 865 : tree type, result_type, tmp, class_decl = NULL;
8618 865 : gfc_symbol *sym;
8619 865 : bool unlimited = false;
8620 :
8621 865 : arg = expr->value.function.actual->expr;
8622 :
8623 865 : gfc_init_se (&argse, NULL);
8624 865 : result_type = gfc_get_int_type (expr->ts.kind);
8625 :
8626 865 : if (arg->rank == 0)
8627 : {
8628 236 : if (arg->ts.type == BT_CLASS)
8629 : {
8630 86 : unlimited = UNLIMITED_POLY (arg);
8631 86 : gfc_add_vptr_component (arg);
8632 86 : gfc_add_size_component (arg);
8633 86 : gfc_conv_expr (&argse, arg);
8634 86 : tmp = fold_convert (result_type, argse.expr);
8635 86 : class_decl = gfc_get_class_from_expr (argse.expr);
8636 86 : goto done;
8637 : }
8638 :
8639 150 : gfc_conv_expr_reference (&argse, arg);
8640 150 : type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8641 : argse.expr));
8642 : }
8643 : else
8644 : {
8645 629 : argse.want_pointer = 0;
8646 629 : gfc_conv_expr_descriptor (&argse, arg);
8647 629 : sym = arg->expr_type == EXPR_VARIABLE ? arg->symtree->n.sym : NULL;
8648 629 : if (arg->ts.type == BT_CLASS)
8649 : {
8650 60 : unlimited = UNLIMITED_POLY (arg);
8651 60 : if (TREE_CODE (argse.expr) == COMPONENT_REF)
8652 54 : tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8653 6 : else if (arg->rank > 0 && sym
8654 12 : && DECL_LANG_SPECIFIC (sym->backend_decl))
8655 12 : tmp = gfc_class_vtab_size_get (
8656 6 : GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl));
8657 : else
8658 0 : gcc_unreachable ();
8659 60 : tmp = fold_convert (result_type, tmp);
8660 60 : class_decl = gfc_get_class_from_expr (argse.expr);
8661 60 : goto done;
8662 : }
8663 569 : type = gfc_get_element_type (TREE_TYPE (argse.expr));
8664 : }
8665 :
8666 : /* Obtain the argument's word length. */
8667 719 : if (arg->ts.type == BT_CHARACTER)
8668 241 : tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8669 : else
8670 478 : tmp = size_in_bytes (type);
8671 719 : tmp = fold_convert (result_type, tmp);
8672 :
8673 865 : done:
8674 865 : if (unlimited && class_decl)
8675 68 : tmp = gfc_resize_class_size_with_len (NULL, class_decl, tmp);
8676 :
8677 865 : se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8678 : build_int_cst (result_type, BITS_PER_UNIT));
8679 865 : gfc_add_block_to_block (&se->pre, &argse.pre);
8680 865 : }
8681 :
8682 :
8683 : /* Intrinsic string comparison functions. */
8684 :
8685 : static void
8686 99 : gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8687 : {
8688 99 : tree args[4];
8689 :
8690 99 : gfc_conv_intrinsic_function_args (se, expr, args, 4);
8691 :
8692 99 : se->expr
8693 198 : = gfc_build_compare_string (args[0], args[1], args[2], args[3],
8694 99 : expr->value.function.actual->expr->ts.kind,
8695 : op);
8696 99 : se->expr = fold_build2_loc (input_location, op,
8697 : gfc_typenode_for_spec (&expr->ts), se->expr,
8698 99 : build_int_cst (TREE_TYPE (se->expr), 0));
8699 99 : }
8700 :
8701 : /* Generate a call to the adjustl/adjustr library function. */
8702 : static void
8703 468 : gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8704 : {
8705 468 : tree args[3];
8706 468 : tree len;
8707 468 : tree type;
8708 468 : tree var;
8709 468 : tree tmp;
8710 :
8711 468 : gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
8712 468 : len = args[1];
8713 :
8714 468 : type = TREE_TYPE (args[2]);
8715 468 : var = gfc_conv_string_tmp (se, type, len);
8716 468 : args[0] = var;
8717 :
8718 468 : tmp = build_call_expr_loc (input_location,
8719 : fndecl, 3, args[0], args[1], args[2]);
8720 468 : gfc_add_expr_to_block (&se->pre, tmp);
8721 468 : se->expr = var;
8722 468 : se->string_length = len;
8723 468 : }
8724 :
8725 :
8726 : /* Generate code for the TRANSFER intrinsic:
8727 : For scalar results:
8728 : DEST = TRANSFER (SOURCE, MOLD)
8729 : where:
8730 : typeof<DEST> = typeof<MOLD>
8731 : and:
8732 : MOLD is scalar.
8733 :
8734 : For array results:
8735 : DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8736 : where:
8737 : typeof<DEST> = typeof<MOLD>
8738 : and:
8739 : N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8740 : sizeof (DEST(0) * SIZE). */
8741 : static void
8742 3991 : gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8743 : {
8744 3991 : tree tmp;
8745 3991 : tree tmpdecl;
8746 3991 : tree ptr;
8747 3991 : tree extent;
8748 3991 : tree source;
8749 3991 : tree source_type;
8750 3991 : tree source_bytes;
8751 3991 : tree mold_type;
8752 3991 : tree dest_word_len;
8753 3991 : tree size_words;
8754 3991 : tree size_bytes;
8755 3991 : tree upper;
8756 3991 : tree lower;
8757 3991 : tree stmt;
8758 3991 : tree class_ref = NULL_TREE;
8759 3991 : gfc_actual_arglist *arg;
8760 3991 : gfc_se argse;
8761 3991 : gfc_array_info *info;
8762 3991 : stmtblock_t block;
8763 3991 : int n;
8764 3991 : bool scalar_mold;
8765 3991 : gfc_expr *source_expr, *mold_expr, *class_expr;
8766 :
8767 3991 : info = NULL;
8768 3991 : if (se->loop)
8769 478 : info = &se->ss->info->data.array;
8770 :
8771 : /* Convert SOURCE. The output from this stage is:-
8772 : source_bytes = length of the source in bytes
8773 : source = pointer to the source data. */
8774 3991 : arg = expr->value.function.actual;
8775 3991 : source_expr = arg->expr;
8776 :
8777 : /* Ensure double transfer through LOGICAL preserves all
8778 : the needed bits. */
8779 3991 : if (arg->expr->expr_type == EXPR_FUNCTION
8780 2986 : && arg->expr->value.function.esym == NULL
8781 2962 : && arg->expr->value.function.isym != NULL
8782 2962 : && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8783 12 : && arg->expr->ts.type == BT_LOGICAL
8784 12 : && expr->ts.type != arg->expr->ts.type)
8785 12 : arg->expr->value.function.name = "__transfer_in_transfer";
8786 :
8787 3991 : gfc_init_se (&argse, NULL);
8788 :
8789 3991 : source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8790 :
8791 : /* Obtain the pointer to source and the length of source in bytes. */
8792 3991 : if (arg->expr->rank == 0)
8793 : {
8794 3635 : gfc_conv_expr_reference (&argse, arg->expr);
8795 3635 : if (arg->expr->ts.type == BT_CLASS)
8796 : {
8797 37 : tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8798 37 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8799 : {
8800 19 : source = gfc_class_data_get (tmp);
8801 19 : class_ref = tmp;
8802 : }
8803 : else
8804 : {
8805 : /* Array elements are evaluated as a reference to the data.
8806 : To obtain the vptr for the element size, the argument
8807 : expression must be stripped to the class reference and
8808 : re-evaluated. The pre and post blocks are not needed. */
8809 18 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8810 18 : source = argse.expr;
8811 18 : class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8812 18 : gfc_init_se (&argse, NULL);
8813 18 : gfc_conv_expr (&argse, class_expr);
8814 18 : class_ref = argse.expr;
8815 : }
8816 : }
8817 : else
8818 3598 : source = argse.expr;
8819 :
8820 : /* Obtain the source word length. */
8821 3635 : switch (arg->expr->ts.type)
8822 : {
8823 300 : case BT_CHARACTER:
8824 300 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8825 : argse.string_length);
8826 300 : break;
8827 37 : case BT_CLASS:
8828 37 : if (class_ref != NULL_TREE)
8829 : {
8830 37 : tmp = gfc_class_vtab_size_get (class_ref);
8831 37 : if (UNLIMITED_POLY (source_expr))
8832 30 : tmp = gfc_resize_class_size_with_len (NULL, class_ref, tmp);
8833 : }
8834 : else
8835 : {
8836 0 : tmp = gfc_class_vtab_size_get (argse.expr);
8837 0 : if (UNLIMITED_POLY (source_expr))
8838 0 : tmp = gfc_resize_class_size_with_len (NULL, argse.expr, tmp);
8839 : }
8840 : break;
8841 3298 : default:
8842 3298 : source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8843 : source));
8844 3298 : tmp = fold_convert (gfc_array_index_type,
8845 : size_in_bytes (source_type));
8846 3298 : break;
8847 : }
8848 : }
8849 : else
8850 : {
8851 356 : bool simply_contiguous = gfc_is_simply_contiguous (arg->expr,
8852 : false, true);
8853 356 : argse.want_pointer = 0;
8854 : /* A non-contiguous SOURCE needs packing. */
8855 356 : if (!simply_contiguous)
8856 74 : argse.force_tmp = 1;
8857 356 : gfc_conv_expr_descriptor (&argse, arg->expr);
8858 356 : source = gfc_conv_descriptor_data_get (argse.expr);
8859 356 : source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8860 :
8861 : /* Repack the source if not simply contiguous. */
8862 356 : if (!simply_contiguous)
8863 : {
8864 74 : tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8865 :
8866 74 : if (warn_array_temporaries)
8867 0 : gfc_warning (OPT_Warray_temporaries,
8868 : "Creating array temporary at %L", &expr->where);
8869 :
8870 74 : source = build_call_expr_loc (input_location,
8871 : gfor_fndecl_in_pack, 1, tmp);
8872 74 : source = gfc_evaluate_now (source, &argse.pre);
8873 :
8874 : /* Free the temporary. */
8875 74 : gfc_start_block (&block);
8876 74 : tmp = gfc_call_free (source);
8877 74 : gfc_add_expr_to_block (&block, tmp);
8878 74 : stmt = gfc_finish_block (&block);
8879 :
8880 : /* Clean up if it was repacked. */
8881 74 : gfc_init_block (&block);
8882 74 : tmp = gfc_conv_array_data (argse.expr);
8883 74 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8884 : source, tmp);
8885 74 : tmp = build3_v (COND_EXPR, tmp, stmt,
8886 : build_empty_stmt (input_location));
8887 74 : gfc_add_expr_to_block (&block, tmp);
8888 74 : gfc_add_block_to_block (&block, &se->post);
8889 74 : gfc_init_block (&se->post);
8890 74 : gfc_add_block_to_block (&se->post, &block);
8891 : }
8892 :
8893 : /* Obtain the source word length. */
8894 356 : if (arg->expr->ts.type == BT_CHARACTER)
8895 144 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8896 : argse.string_length);
8897 212 : else if (arg->expr->ts.type == BT_CLASS)
8898 : {
8899 54 : if (UNLIMITED_POLY (source_expr)
8900 54 : && DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl))
8901 12 : class_ref = GFC_DECL_SAVED_DESCRIPTOR
8902 : (source_expr->symtree->n.sym->backend_decl);
8903 : else
8904 42 : class_ref = TREE_OPERAND (argse.expr, 0);
8905 54 : tmp = gfc_class_vtab_size_get (class_ref);
8906 54 : if (UNLIMITED_POLY (arg->expr))
8907 54 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8908 : }
8909 : else
8910 158 : tmp = fold_convert (gfc_array_index_type,
8911 : size_in_bytes (source_type));
8912 :
8913 : /* Obtain the size of the array in bytes. */
8914 356 : extent = gfc_create_var (gfc_array_index_type, NULL);
8915 1098 : for (n = 0; n < arg->expr->rank; n++)
8916 : {
8917 386 : tree idx;
8918 386 : idx = gfc_rank_cst[n];
8919 386 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8920 386 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8921 386 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8922 386 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8923 : gfc_array_index_type, upper, lower);
8924 386 : gfc_add_modify (&argse.pre, extent, tmp);
8925 386 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8926 : gfc_array_index_type, extent,
8927 : gfc_index_one_node);
8928 386 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8929 : gfc_array_index_type, tmp, source_bytes);
8930 : }
8931 : }
8932 :
8933 3991 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8934 3991 : gfc_add_block_to_block (&se->pre, &argse.pre);
8935 3991 : gfc_add_block_to_block (&se->post, &argse.post);
8936 :
8937 : /* Now convert MOLD. The outputs are:
8938 : mold_type = the TREE type of MOLD
8939 : dest_word_len = destination word length in bytes. */
8940 3991 : arg = arg->next;
8941 3991 : mold_expr = arg->expr;
8942 :
8943 3991 : gfc_init_se (&argse, NULL);
8944 :
8945 3991 : scalar_mold = arg->expr->rank == 0;
8946 :
8947 3991 : if (arg->expr->rank == 0)
8948 : {
8949 3662 : gfc_conv_expr_reference (&argse, mold_expr);
8950 3662 : mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8951 : argse.expr));
8952 : }
8953 : else
8954 : {
8955 329 : argse.want_pointer = 0;
8956 329 : gfc_conv_expr_descriptor (&argse, mold_expr);
8957 329 : mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8958 : }
8959 :
8960 3991 : gfc_add_block_to_block (&se->pre, &argse.pre);
8961 3991 : gfc_add_block_to_block (&se->post, &argse.post);
8962 :
8963 3991 : if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8964 : {
8965 : /* If this TRANSFER is nested in another TRANSFER, use a type
8966 : that preserves all bits. */
8967 12 : if (mold_expr->ts.type == BT_LOGICAL)
8968 12 : mold_type = gfc_get_int_type (mold_expr->ts.kind);
8969 : }
8970 :
8971 : /* Obtain the destination word length. */
8972 3991 : switch (mold_expr->ts.type)
8973 : {
8974 473 : case BT_CHARACTER:
8975 473 : tmp = size_of_string_in_bytes (mold_expr->ts.kind, argse.string_length);
8976 473 : mold_type = gfc_get_character_type_len (mold_expr->ts.kind,
8977 : argse.string_length);
8978 473 : break;
8979 6 : case BT_CLASS:
8980 6 : if (scalar_mold)
8981 6 : class_ref = argse.expr;
8982 : else
8983 0 : class_ref = TREE_OPERAND (argse.expr, 0);
8984 6 : tmp = gfc_class_vtab_size_get (class_ref);
8985 6 : if (UNLIMITED_POLY (arg->expr))
8986 0 : tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp);
8987 : break;
8988 3512 : default:
8989 3512 : tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8990 3512 : break;
8991 : }
8992 :
8993 : /* Do not fix dest_word_len if it is a variable, since the temporary can wind
8994 : up being used before the assignment. */
8995 3991 : if (mold_expr->ts.type == BT_CHARACTER && mold_expr->ts.deferred)
8996 : dest_word_len = tmp;
8997 : else
8998 : {
8999 3937 : dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
9000 3937 : gfc_add_modify (&se->pre, dest_word_len, tmp);
9001 : }
9002 :
9003 : /* Finally convert SIZE, if it is present. */
9004 3991 : arg = arg->next;
9005 3991 : size_words = gfc_create_var (gfc_array_index_type, NULL);
9006 :
9007 3991 : if (arg->expr)
9008 : {
9009 222 : gfc_init_se (&argse, NULL);
9010 222 : gfc_conv_expr_reference (&argse, arg->expr);
9011 222 : tmp = convert (gfc_array_index_type,
9012 : build_fold_indirect_ref_loc (input_location,
9013 : argse.expr));
9014 222 : gfc_add_block_to_block (&se->pre, &argse.pre);
9015 222 : gfc_add_block_to_block (&se->post, &argse.post);
9016 : }
9017 : else
9018 : tmp = NULL_TREE;
9019 :
9020 : /* Separate array and scalar results. */
9021 3991 : if (scalar_mold && tmp == NULL_TREE)
9022 3513 : goto scalar_transfer;
9023 :
9024 478 : size_bytes = gfc_create_var (gfc_array_index_type, NULL);
9025 478 : if (tmp != NULL_TREE)
9026 222 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9027 : tmp, dest_word_len);
9028 : else
9029 : tmp = source_bytes;
9030 :
9031 478 : gfc_add_modify (&se->pre, size_bytes, tmp);
9032 478 : gfc_add_modify (&se->pre, size_words,
9033 : fold_build2_loc (input_location, CEIL_DIV_EXPR,
9034 : gfc_array_index_type,
9035 : size_bytes, dest_word_len));
9036 :
9037 : /* Evaluate the bounds of the result. If the loop range exists, we have
9038 : to check if it is too large. If so, we modify loop->to be consistent
9039 : with min(size, size(source)). Otherwise, size is made consistent with
9040 : the loop range, so that the right number of bytes is transferred.*/
9041 478 : n = se->loop->order[0];
9042 478 : if (se->loop->to[n] != NULL_TREE)
9043 : {
9044 205 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9045 : se->loop->to[n], se->loop->from[n]);
9046 205 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9047 : tmp, gfc_index_one_node);
9048 205 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9049 : tmp, size_words);
9050 205 : gfc_add_modify (&se->pre, size_words, tmp);
9051 205 : gfc_add_modify (&se->pre, size_bytes,
9052 : fold_build2_loc (input_location, MULT_EXPR,
9053 : gfc_array_index_type,
9054 : size_words, dest_word_len));
9055 410 : upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9056 205 : size_words, se->loop->from[n]);
9057 205 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9058 : upper, gfc_index_one_node);
9059 : }
9060 : else
9061 : {
9062 273 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9063 : size_words, gfc_index_one_node);
9064 273 : se->loop->from[n] = gfc_index_zero_node;
9065 : }
9066 :
9067 478 : se->loop->to[n] = upper;
9068 :
9069 : /* Build a destination descriptor, using the pointer, source, as the
9070 : data field. */
9071 478 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
9072 : NULL_TREE, false, true, false, &expr->where);
9073 :
9074 : /* Cast the pointer to the result. */
9075 478 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9076 478 : tmp = fold_convert (pvoid_type_node, tmp);
9077 :
9078 : /* Use memcpy to do the transfer. */
9079 478 : tmp
9080 478 : = build_call_expr_loc (input_location,
9081 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
9082 : fold_convert (pvoid_type_node, source),
9083 : fold_convert (size_type_node,
9084 : fold_build2_loc (input_location,
9085 : MIN_EXPR,
9086 : gfc_array_index_type,
9087 : size_bytes,
9088 : source_bytes)));
9089 478 : gfc_add_expr_to_block (&se->pre, tmp);
9090 :
9091 478 : se->expr = info->descriptor;
9092 478 : if (expr->ts.type == BT_CHARACTER)
9093 : {
9094 281 : tmp = fold_convert (gfc_charlen_type_node,
9095 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9096 281 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9097 : gfc_charlen_type_node,
9098 : dest_word_len, tmp);
9099 : }
9100 :
9101 478 : return;
9102 :
9103 : /* Deal with scalar results. */
9104 3513 : scalar_transfer:
9105 3513 : extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
9106 : dest_word_len, source_bytes);
9107 3513 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
9108 : extent, gfc_index_zero_node);
9109 :
9110 3513 : if (expr->ts.type == BT_CHARACTER)
9111 : {
9112 192 : tree direct, indirect, free;
9113 :
9114 192 : ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
9115 192 : tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
9116 : "transfer");
9117 :
9118 : /* If source is longer than the destination, use a pointer to
9119 : the source directly. */
9120 192 : gfc_init_block (&block);
9121 192 : gfc_add_modify (&block, tmpdecl, ptr);
9122 192 : direct = gfc_finish_block (&block);
9123 :
9124 : /* Otherwise, allocate a string with the length of the destination
9125 : and copy the source into it. */
9126 192 : gfc_init_block (&block);
9127 192 : tmp = gfc_get_pchar_type (expr->ts.kind);
9128 192 : tmp = gfc_call_malloc (&block, tmp, dest_word_len);
9129 192 : gfc_add_modify (&block, tmpdecl,
9130 192 : fold_convert (TREE_TYPE (ptr), tmp));
9131 192 : tmp = build_call_expr_loc (input_location,
9132 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9133 : fold_convert (pvoid_type_node, tmpdecl),
9134 : fold_convert (pvoid_type_node, ptr),
9135 : fold_convert (size_type_node, extent));
9136 192 : gfc_add_expr_to_block (&block, tmp);
9137 192 : indirect = gfc_finish_block (&block);
9138 :
9139 : /* Wrap it up with the condition. */
9140 192 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
9141 : dest_word_len, source_bytes);
9142 192 : tmp = build3_v (COND_EXPR, tmp, direct, indirect);
9143 192 : gfc_add_expr_to_block (&se->pre, tmp);
9144 :
9145 : /* Free the temporary string, if necessary. */
9146 192 : free = gfc_call_free (tmpdecl);
9147 192 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9148 : dest_word_len, source_bytes);
9149 192 : tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
9150 192 : gfc_add_expr_to_block (&se->post, tmp);
9151 :
9152 192 : se->expr = tmpdecl;
9153 192 : tmp = fold_convert (gfc_charlen_type_node,
9154 : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
9155 192 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
9156 : gfc_charlen_type_node,
9157 : dest_word_len, tmp);
9158 : }
9159 : else
9160 : {
9161 3321 : tmpdecl = gfc_create_var (mold_type, "transfer");
9162 :
9163 3321 : ptr = convert (build_pointer_type (mold_type), source);
9164 :
9165 : /* For CLASS results, allocate the needed memory first. */
9166 3321 : if (mold_expr->ts.type == BT_CLASS)
9167 : {
9168 6 : tree cdata;
9169 6 : cdata = gfc_class_data_get (tmpdecl);
9170 6 : tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
9171 6 : gfc_add_modify (&se->pre, cdata, tmp);
9172 : }
9173 :
9174 : /* Use memcpy to do the transfer. */
9175 3321 : if (mold_expr->ts.type == BT_CLASS)
9176 6 : tmp = gfc_class_data_get (tmpdecl);
9177 : else
9178 3315 : tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
9179 :
9180 3321 : tmp = build_call_expr_loc (input_location,
9181 : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
9182 : fold_convert (pvoid_type_node, tmp),
9183 : fold_convert (pvoid_type_node, ptr),
9184 : fold_convert (size_type_node, extent));
9185 3321 : gfc_add_expr_to_block (&se->pre, tmp);
9186 :
9187 : /* For CLASS results, set the _vptr. */
9188 3321 : if (mold_expr->ts.type == BT_CLASS)
9189 6 : gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived);
9190 :
9191 3321 : se->expr = tmpdecl;
9192 : }
9193 : }
9194 :
9195 :
9196 : /* Generate code for the ALLOCATED intrinsic.
9197 : Generate inline code that directly check the address of the argument. */
9198 :
9199 : static void
9200 7534 : gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
9201 : {
9202 7534 : gfc_se arg1se;
9203 7534 : tree tmp;
9204 7534 : gfc_expr *e = expr->value.function.actual->expr;
9205 :
9206 7534 : gfc_init_se (&arg1se, NULL);
9207 7534 : if (e->ts.type == BT_CLASS)
9208 : {
9209 : /* Make sure that class array expressions have both a _data
9210 : component reference and an array reference.... */
9211 923 : if (CLASS_DATA (e)->attr.dimension)
9212 424 : gfc_add_class_array_ref (e);
9213 : /* .... whilst scalars only need the _data component. */
9214 : else
9215 499 : gfc_add_data_component (e);
9216 : }
9217 :
9218 7534 : gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
9219 :
9220 7534 : if (e->rank == 0)
9221 : {
9222 : /* Allocatable scalar. */
9223 2974 : arg1se.want_pointer = 1;
9224 2974 : gfc_conv_expr (&arg1se, e);
9225 2974 : tmp = arg1se.expr;
9226 : }
9227 : else
9228 : {
9229 : /* Allocatable array. */
9230 4560 : arg1se.descriptor_only = 1;
9231 4560 : gfc_conv_expr_descriptor (&arg1se, e);
9232 4560 : tmp = gfc_conv_descriptor_data_get (arg1se.expr);
9233 : }
9234 :
9235 7534 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
9236 7534 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9237 :
9238 : /* Components of pointer array references sometimes come back with a pre block. */
9239 7534 : if (arg1se.pre.head)
9240 327 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9241 :
9242 7534 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9243 7534 : }
9244 :
9245 :
9246 : /* Generate code for the ASSOCIATED intrinsic.
9247 : If both POINTER and TARGET are arrays, generate a call to library function
9248 : _gfor_associated, and pass descriptors of POINTER and TARGET to it.
9249 : In other cases, generate inline code that directly compare the address of
9250 : POINTER with the address of TARGET. */
9251 :
9252 : static void
9253 9743 : gfc_conv_associated (gfc_se *se, gfc_expr *expr)
9254 : {
9255 9743 : gfc_actual_arglist *arg1;
9256 9743 : gfc_actual_arglist *arg2;
9257 9743 : gfc_se arg1se;
9258 9743 : gfc_se arg2se;
9259 9743 : tree tmp2;
9260 9743 : tree tmp;
9261 9743 : tree nonzero_arraylen = NULL_TREE;
9262 9743 : gfc_ss *ss;
9263 9743 : bool scalar;
9264 :
9265 9743 : gfc_init_se (&arg1se, NULL);
9266 9743 : gfc_init_se (&arg2se, NULL);
9267 9743 : arg1 = expr->value.function.actual;
9268 9743 : arg2 = arg1->next;
9269 :
9270 : /* Check whether the expression is a scalar or not; we cannot use
9271 : arg1->expr->rank as it can be nonzero for proc pointers. */
9272 9743 : ss = gfc_walk_expr (arg1->expr);
9273 9743 : scalar = ss == gfc_ss_terminator;
9274 9743 : if (!scalar)
9275 3985 : gfc_free_ss_chain (ss);
9276 :
9277 9743 : if (!arg2->expr)
9278 : {
9279 : /* No optional target. */
9280 7298 : if (scalar)
9281 : {
9282 : /* A pointer to a scalar. */
9283 4831 : arg1se.want_pointer = 1;
9284 4831 : gfc_conv_expr (&arg1se, arg1->expr);
9285 4831 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9286 185 : && arg1->expr->symtree->n.sym->attr.dummy)
9287 78 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9288 : arg1se.expr);
9289 4831 : if (arg1->expr->ts.type == BT_CLASS)
9290 : {
9291 390 : tmp2 = gfc_class_data_get (arg1se.expr);
9292 390 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
9293 0 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
9294 : }
9295 : else
9296 4441 : tmp2 = arg1se.expr;
9297 : }
9298 : else
9299 : {
9300 : /* A pointer to an array. */
9301 2467 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9302 2467 : tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
9303 : }
9304 7298 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9305 7298 : gfc_add_block_to_block (&se->post, &arg1se.post);
9306 7298 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
9307 7298 : fold_convert (TREE_TYPE (tmp2), null_pointer_node));
9308 7298 : se->expr = tmp;
9309 : }
9310 : else
9311 : {
9312 : /* An optional target. */
9313 2445 : if (arg2->expr->ts.type == BT_CLASS
9314 30 : && arg2->expr->expr_type != EXPR_FUNCTION)
9315 24 : gfc_add_data_component (arg2->expr);
9316 :
9317 2445 : if (scalar)
9318 : {
9319 : /* A pointer to a scalar. */
9320 927 : arg1se.want_pointer = 1;
9321 927 : gfc_conv_expr (&arg1se, arg1->expr);
9322 927 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
9323 128 : && arg1->expr->symtree->n.sym->attr.dummy)
9324 42 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
9325 : arg1se.expr);
9326 927 : if (arg1->expr->ts.type == BT_CLASS)
9327 254 : arg1se.expr = gfc_class_data_get (arg1se.expr);
9328 :
9329 927 : arg2se.want_pointer = 1;
9330 927 : gfc_conv_expr (&arg2se, arg2->expr);
9331 927 : if (arg2->expr->symtree->n.sym->attr.proc_pointer
9332 36 : && arg2->expr->symtree->n.sym->attr.dummy)
9333 0 : arg2se.expr = build_fold_indirect_ref_loc (input_location,
9334 : arg2se.expr);
9335 927 : if (arg2->expr->ts.type == BT_CLASS)
9336 : {
9337 6 : arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
9338 6 : arg2se.expr = gfc_class_data_get (arg2se.expr);
9339 : }
9340 927 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9341 927 : gfc_add_block_to_block (&se->post, &arg1se.post);
9342 927 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9343 927 : gfc_add_block_to_block (&se->post, &arg2se.post);
9344 927 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9345 : arg1se.expr, arg2se.expr);
9346 927 : tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9347 : arg1se.expr, null_pointer_node);
9348 927 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9349 : logical_type_node, tmp, tmp2);
9350 : }
9351 : else
9352 : {
9353 : /* An array pointer of zero length is not associated if target is
9354 : present. */
9355 1518 : arg1se.descriptor_only = 1;
9356 1518 : gfc_conv_expr_lhs (&arg1se, arg1->expr);
9357 1518 : if (arg1->expr->rank == -1)
9358 : {
9359 84 : tmp = gfc_conv_descriptor_rank_get (arg1se.expr);
9360 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9361 84 : TREE_TYPE (tmp), tmp,
9362 84 : build_int_cst (TREE_TYPE (tmp), 1));
9363 : }
9364 : else
9365 1434 : tmp = gfc_rank_cst[arg1->expr->rank - 1];
9366 1518 : tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9367 1518 : if (arg2->expr->rank != 0)
9368 1488 : nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9369 : logical_type_node, tmp,
9370 1488 : build_int_cst (TREE_TYPE (tmp), 0));
9371 :
9372 : /* A pointer to an array, call library function _gfor_associated. */
9373 1518 : arg1se.want_pointer = 1;
9374 1518 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9375 1518 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9376 1518 : gfc_add_block_to_block (&se->post, &arg1se.post);
9377 :
9378 1518 : arg2se.want_pointer = 1;
9379 1518 : arg2se.force_no_tmp = 1;
9380 1518 : if (arg2->expr->rank != 0)
9381 1488 : gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9382 : else
9383 : {
9384 30 : gfc_conv_expr (&arg2se, arg2->expr);
9385 30 : arg2se.expr
9386 30 : = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9387 30 : gfc_expr_attr (arg2->expr));
9388 30 : arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9389 : }
9390 1518 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9391 1518 : gfc_add_block_to_block (&se->post, &arg2se.post);
9392 1518 : se->expr = build_call_expr_loc (input_location,
9393 : gfor_fndecl_associated, 2,
9394 : arg1se.expr, arg2se.expr);
9395 1518 : se->expr = convert (logical_type_node, se->expr);
9396 1518 : if (arg2->expr->rank != 0)
9397 1488 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9398 : logical_type_node, se->expr,
9399 : nonzero_arraylen);
9400 : }
9401 :
9402 : /* If target is present zero character length pointers cannot
9403 : be associated. */
9404 2445 : if (arg1->expr->ts.type == BT_CHARACTER)
9405 : {
9406 631 : tmp = arg1se.string_length;
9407 631 : tmp = fold_build2_loc (input_location, NE_EXPR,
9408 : logical_type_node, tmp,
9409 631 : build_zero_cst (TREE_TYPE (tmp)));
9410 631 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9411 : logical_type_node, se->expr, tmp);
9412 : }
9413 : }
9414 :
9415 9743 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9416 9743 : }
9417 :
9418 :
9419 : /* Generate code for the SAME_TYPE_AS intrinsic.
9420 : Generate inline code that directly checks the vindices. */
9421 :
9422 : static void
9423 409 : gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9424 : {
9425 409 : gfc_expr *a, *b;
9426 409 : gfc_se se1, se2;
9427 409 : tree tmp;
9428 409 : tree conda = NULL_TREE, condb = NULL_TREE;
9429 :
9430 409 : gfc_init_se (&se1, NULL);
9431 409 : gfc_init_se (&se2, NULL);
9432 :
9433 409 : a = expr->value.function.actual->expr;
9434 409 : b = expr->value.function.actual->next->expr;
9435 :
9436 409 : bool unlimited_poly_a = UNLIMITED_POLY (a);
9437 409 : bool unlimited_poly_b = UNLIMITED_POLY (b);
9438 409 : if (unlimited_poly_a)
9439 : {
9440 111 : se1.want_pointer = 1;
9441 111 : gfc_add_vptr_component (a);
9442 : }
9443 298 : else if (a->ts.type == BT_CLASS)
9444 : {
9445 256 : gfc_add_vptr_component (a);
9446 256 : gfc_add_hash_component (a);
9447 : }
9448 42 : else if (a->ts.type == BT_DERIVED)
9449 42 : a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9450 42 : a->ts.u.derived->hash_value);
9451 :
9452 409 : if (unlimited_poly_b)
9453 : {
9454 72 : se2.want_pointer = 1;
9455 72 : gfc_add_vptr_component (b);
9456 : }
9457 337 : else if (b->ts.type == BT_CLASS)
9458 : {
9459 169 : gfc_add_vptr_component (b);
9460 169 : gfc_add_hash_component (b);
9461 : }
9462 168 : else if (b->ts.type == BT_DERIVED)
9463 168 : b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9464 168 : b->ts.u.derived->hash_value);
9465 :
9466 409 : gfc_conv_expr (&se1, a);
9467 409 : gfc_conv_expr (&se2, b);
9468 :
9469 409 : if (unlimited_poly_a)
9470 : {
9471 111 : conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9472 : se1.expr,
9473 111 : build_int_cst (TREE_TYPE (se1.expr), 0));
9474 111 : se1.expr = gfc_vptr_hash_get (se1.expr);
9475 : }
9476 :
9477 409 : if (unlimited_poly_b)
9478 : {
9479 72 : condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9480 : se2.expr,
9481 72 : build_int_cst (TREE_TYPE (se2.expr), 0));
9482 72 : se2.expr = gfc_vptr_hash_get (se2.expr);
9483 : }
9484 :
9485 409 : tmp = fold_build2_loc (input_location, EQ_EXPR,
9486 : logical_type_node, se1.expr,
9487 409 : fold_convert (TREE_TYPE (se1.expr), se2.expr));
9488 :
9489 409 : if (conda)
9490 111 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9491 : logical_type_node, conda, tmp);
9492 :
9493 409 : if (condb)
9494 72 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9495 : logical_type_node, condb, tmp);
9496 :
9497 409 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9498 409 : }
9499 :
9500 :
9501 : /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9502 :
9503 : static void
9504 42 : gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9505 : {
9506 42 : tree args[2];
9507 :
9508 42 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
9509 42 : se->expr = build_call_expr_loc (input_location,
9510 : gfor_fndecl_sc_kind, 2, args[0], args[1]);
9511 42 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9512 42 : }
9513 :
9514 :
9515 : /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9516 :
9517 : static void
9518 45 : gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9519 : {
9520 45 : tree arg, type;
9521 :
9522 45 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9523 :
9524 : /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9525 45 : type = gfc_get_int_type (4);
9526 45 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9527 :
9528 : /* Convert it to the required type. */
9529 45 : type = gfc_typenode_for_spec (&expr->ts);
9530 45 : se->expr = build_call_expr_loc (input_location,
9531 : gfor_fndecl_si_kind, 1, arg);
9532 45 : se->expr = fold_convert (type, se->expr);
9533 45 : }
9534 :
9535 :
9536 : /* Generate code for SELECTED_LOGICAL_KIND (BITS) intrinsic function. */
9537 :
9538 : static void
9539 6 : gfc_conv_intrinsic_sl_kind (gfc_se *se, gfc_expr *expr)
9540 : {
9541 6 : tree arg, type;
9542 :
9543 6 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9544 :
9545 : /* The argument to SELECTED_LOGICAL_KIND is INTEGER(4). */
9546 6 : type = gfc_get_int_type (4);
9547 6 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9548 :
9549 : /* Convert it to the required type. */
9550 6 : type = gfc_typenode_for_spec (&expr->ts);
9551 6 : se->expr = build_call_expr_loc (input_location,
9552 : gfor_fndecl_sl_kind, 1, arg);
9553 6 : se->expr = fold_convert (type, se->expr);
9554 6 : }
9555 :
9556 :
9557 : /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9558 :
9559 : static void
9560 82 : gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9561 : {
9562 82 : gfc_actual_arglist *actual;
9563 82 : tree type;
9564 82 : gfc_se argse;
9565 82 : vec<tree, va_gc> *args = NULL;
9566 :
9567 328 : for (actual = expr->value.function.actual; actual; actual = actual->next)
9568 : {
9569 246 : gfc_init_se (&argse, se);
9570 :
9571 : /* Pass a NULL pointer for an absent arg. */
9572 246 : if (actual->expr == NULL)
9573 96 : argse.expr = null_pointer_node;
9574 : else
9575 : {
9576 150 : gfc_typespec ts;
9577 150 : gfc_clear_ts (&ts);
9578 :
9579 150 : if (actual->expr->ts.kind != gfc_c_int_kind)
9580 : {
9581 : /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9582 0 : ts.type = BT_INTEGER;
9583 0 : ts.kind = gfc_c_int_kind;
9584 0 : gfc_convert_type (actual->expr, &ts, 2);
9585 : }
9586 150 : gfc_conv_expr_reference (&argse, actual->expr);
9587 : }
9588 :
9589 246 : gfc_add_block_to_block (&se->pre, &argse.pre);
9590 246 : gfc_add_block_to_block (&se->post, &argse.post);
9591 246 : vec_safe_push (args, argse.expr);
9592 : }
9593 :
9594 : /* Convert it to the required type. */
9595 82 : type = gfc_typenode_for_spec (&expr->ts);
9596 82 : se->expr = build_call_expr_loc_vec (input_location,
9597 : gfor_fndecl_sr_kind, args);
9598 82 : se->expr = fold_convert (type, se->expr);
9599 82 : }
9600 :
9601 :
9602 : /* Generate code for TRIM (A) intrinsic function. */
9603 :
9604 : static void
9605 580 : gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9606 : {
9607 580 : tree var;
9608 580 : tree len;
9609 580 : tree addr;
9610 580 : tree tmp;
9611 580 : tree cond;
9612 580 : tree fndecl;
9613 580 : tree function;
9614 580 : tree *args;
9615 580 : unsigned int num_args;
9616 :
9617 580 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9618 580 : args = XALLOCAVEC (tree, num_args);
9619 :
9620 580 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9621 580 : addr = gfc_build_addr_expr (ppvoid_type_node, var);
9622 580 : len = gfc_create_var (gfc_charlen_type_node, "len");
9623 :
9624 580 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
9625 580 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
9626 580 : args[1] = addr;
9627 :
9628 580 : if (expr->ts.kind == 1)
9629 548 : function = gfor_fndecl_string_trim;
9630 32 : else if (expr->ts.kind == 4)
9631 32 : function = gfor_fndecl_string_trim_char4;
9632 : else
9633 0 : gcc_unreachable ();
9634 :
9635 580 : fndecl = build_addr (function);
9636 580 : tmp = build_call_array_loc (input_location,
9637 580 : TREE_TYPE (TREE_TYPE (function)), fndecl,
9638 : num_args, args);
9639 580 : gfc_add_expr_to_block (&se->pre, tmp);
9640 :
9641 : /* Free the temporary afterwards, if necessary. */
9642 580 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9643 580 : len, build_int_cst (TREE_TYPE (len), 0));
9644 580 : tmp = gfc_call_free (var);
9645 580 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9646 580 : gfc_add_expr_to_block (&se->post, tmp);
9647 :
9648 580 : se->expr = var;
9649 580 : se->string_length = len;
9650 580 : }
9651 :
9652 :
9653 : /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9654 :
9655 : static void
9656 541 : gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9657 : {
9658 541 : tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9659 541 : tree type, cond, tmp, count, exit_label, n, max, largest;
9660 541 : tree size;
9661 541 : stmtblock_t block, body;
9662 541 : int i;
9663 :
9664 : /* We store in charsize the size of a character. */
9665 541 : i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9666 541 : size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9667 :
9668 : /* Get the arguments. */
9669 541 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
9670 541 : slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9671 541 : src = args[1];
9672 541 : ncopies = gfc_evaluate_now (args[2], &se->pre);
9673 541 : ncopies_type = TREE_TYPE (ncopies);
9674 :
9675 : /* Check that NCOPIES is not negative. */
9676 541 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9677 : build_int_cst (ncopies_type, 0));
9678 541 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9679 : "Argument NCOPIES of REPEAT intrinsic is negative "
9680 : "(its value is %ld)",
9681 : fold_convert (long_integer_type_node, ncopies));
9682 :
9683 : /* If the source length is zero, any non negative value of NCOPIES
9684 : is valid, and nothing happens. */
9685 541 : n = gfc_create_var (ncopies_type, "ncopies");
9686 541 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9687 : size_zero_node);
9688 541 : tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9689 : build_int_cst (ncopies_type, 0), ncopies);
9690 541 : gfc_add_modify (&se->pre, n, tmp);
9691 541 : ncopies = n;
9692 :
9693 : /* Check that ncopies is not too large: ncopies should be less than
9694 : (or equal to) MAX / slen, where MAX is the maximal integer of
9695 : the gfc_charlen_type_node type. If slen == 0, we need a special
9696 : case to avoid the division by zero. */
9697 541 : max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9698 541 : fold_convert (sizetype,
9699 : TYPE_MAX_VALUE (gfc_charlen_type_node)),
9700 : slen);
9701 1078 : largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9702 541 : ? sizetype : ncopies_type;
9703 541 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9704 : fold_convert (largest, ncopies),
9705 : fold_convert (largest, max));
9706 541 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9707 : size_zero_node);
9708 541 : cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9709 : logical_false_node, cond);
9710 541 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9711 : "Argument NCOPIES of REPEAT intrinsic is too large");
9712 :
9713 : /* Compute the destination length. */
9714 541 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9715 : fold_convert (gfc_charlen_type_node, slen),
9716 : fold_convert (gfc_charlen_type_node, ncopies));
9717 541 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9718 541 : dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9719 :
9720 : /* Generate the code to do the repeat operation:
9721 : for (i = 0; i < ncopies; i++)
9722 : memmove (dest + (i * slen * size), src, slen*size); */
9723 541 : gfc_start_block (&block);
9724 541 : count = gfc_create_var (sizetype, "count");
9725 541 : gfc_add_modify (&block, count, size_zero_node);
9726 541 : exit_label = gfc_build_label_decl (NULL_TREE);
9727 :
9728 : /* Start the loop body. */
9729 541 : gfc_start_block (&body);
9730 :
9731 : /* Exit the loop if count >= ncopies. */
9732 541 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9733 : fold_convert (sizetype, ncopies));
9734 541 : tmp = build1_v (GOTO_EXPR, exit_label);
9735 541 : TREE_USED (exit_label) = 1;
9736 541 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9737 : build_empty_stmt (input_location));
9738 541 : gfc_add_expr_to_block (&body, tmp);
9739 :
9740 : /* Call memmove (dest + (i*slen*size), src, slen*size). */
9741 541 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9742 : count);
9743 541 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9744 : size);
9745 541 : tmp = fold_build_pointer_plus_loc (input_location,
9746 : fold_convert (pvoid_type_node, dest), tmp);
9747 541 : tmp = build_call_expr_loc (input_location,
9748 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9749 : 3, tmp, src,
9750 : fold_build2_loc (input_location, MULT_EXPR,
9751 : size_type_node, slen, size));
9752 541 : gfc_add_expr_to_block (&body, tmp);
9753 :
9754 : /* Increment count. */
9755 541 : tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9756 : count, size_one_node);
9757 541 : gfc_add_modify (&body, count, tmp);
9758 :
9759 : /* Build the loop. */
9760 541 : tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9761 541 : gfc_add_expr_to_block (&block, tmp);
9762 :
9763 : /* Add the exit label. */
9764 541 : tmp = build1_v (LABEL_EXPR, exit_label);
9765 541 : gfc_add_expr_to_block (&block, tmp);
9766 :
9767 : /* Finish the block. */
9768 541 : tmp = gfc_finish_block (&block);
9769 541 : gfc_add_expr_to_block (&se->pre, tmp);
9770 :
9771 : /* Set the result value. */
9772 541 : se->expr = dest;
9773 541 : se->string_length = dlen;
9774 541 : }
9775 :
9776 :
9777 : /* Generate code for the IARGC intrinsic. */
9778 :
9779 : static void
9780 12 : gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9781 : {
9782 12 : tree tmp;
9783 12 : tree fndecl;
9784 12 : tree type;
9785 :
9786 : /* Call the library function. This always returns an INTEGER(4). */
9787 12 : fndecl = gfor_fndecl_iargc;
9788 12 : tmp = build_call_expr_loc (input_location,
9789 : fndecl, 0);
9790 :
9791 : /* Convert it to the required type. */
9792 12 : type = gfc_typenode_for_spec (&expr->ts);
9793 12 : tmp = fold_convert (type, tmp);
9794 :
9795 12 : se->expr = tmp;
9796 12 : }
9797 :
9798 :
9799 : /* Generate code for the KILL intrinsic. */
9800 :
9801 : static void
9802 8 : conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9803 : {
9804 8 : tree *args;
9805 8 : tree int4_type_node = gfc_get_int_type (4);
9806 8 : tree pid;
9807 8 : tree sig;
9808 8 : tree tmp;
9809 8 : unsigned int num_args;
9810 :
9811 8 : num_args = gfc_intrinsic_argument_list_length (expr);
9812 8 : args = XALLOCAVEC (tree, num_args);
9813 8 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
9814 :
9815 : /* Convert PID to a INTEGER(4) entity. */
9816 8 : pid = convert (int4_type_node, args[0]);
9817 :
9818 : /* Convert SIG to a INTEGER(4) entity. */
9819 8 : sig = convert (int4_type_node, args[1]);
9820 :
9821 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9822 :
9823 8 : se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9824 8 : }
9825 :
9826 :
9827 : static tree
9828 15 : conv_intrinsic_kill_sub (gfc_code *code)
9829 : {
9830 15 : stmtblock_t block;
9831 15 : gfc_se se, se_stat;
9832 15 : tree int4_type_node = gfc_get_int_type (4);
9833 15 : tree pid;
9834 15 : tree sig;
9835 15 : tree statp;
9836 15 : tree tmp;
9837 :
9838 : /* Make the function call. */
9839 15 : gfc_init_block (&block);
9840 15 : gfc_init_se (&se, NULL);
9841 :
9842 : /* Convert PID to a INTEGER(4) entity. */
9843 15 : gfc_conv_expr (&se, code->ext.actual->expr);
9844 15 : gfc_add_block_to_block (&block, &se.pre);
9845 15 : pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9846 15 : gfc_add_block_to_block (&block, &se.post);
9847 :
9848 : /* Convert SIG to a INTEGER(4) entity. */
9849 15 : gfc_conv_expr (&se, code->ext.actual->next->expr);
9850 15 : gfc_add_block_to_block (&block, &se.pre);
9851 15 : sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9852 15 : gfc_add_block_to_block (&block, &se.post);
9853 :
9854 : /* Deal with an optional STATUS. */
9855 15 : if (code->ext.actual->next->next->expr)
9856 : {
9857 10 : gfc_init_se (&se_stat, NULL);
9858 10 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
9859 10 : statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9860 : }
9861 : else
9862 : statp = NULL_TREE;
9863 :
9864 25 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9865 10 : statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9866 :
9867 15 : gfc_add_expr_to_block (&block, tmp);
9868 :
9869 15 : if (statp && statp != se_stat.expr)
9870 10 : gfc_add_modify (&block, se_stat.expr,
9871 10 : fold_convert (TREE_TYPE (se_stat.expr), statp));
9872 :
9873 15 : return gfc_finish_block (&block);
9874 : }
9875 :
9876 :
9877 :
9878 : /* The loc intrinsic returns the address of its argument as
9879 : gfc_index_integer_kind integer. */
9880 :
9881 : static void
9882 8993 : gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9883 : {
9884 8993 : tree temp_var;
9885 8993 : gfc_expr *arg_expr;
9886 :
9887 8993 : gcc_assert (!se->ss);
9888 :
9889 8993 : arg_expr = expr->value.function.actual->expr;
9890 8993 : if (arg_expr->rank == 0)
9891 : {
9892 6575 : if (arg_expr->ts.type == BT_CLASS)
9893 18 : gfc_add_data_component (arg_expr);
9894 6575 : gfc_conv_expr_reference (se, arg_expr);
9895 : }
9896 2418 : else if (gfc_is_simply_contiguous (arg_expr, false, false))
9897 2380 : gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9898 : else
9899 : {
9900 38 : gfc_conv_expr_descriptor (se, arg_expr);
9901 38 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9902 : }
9903 8993 : se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9904 8993 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9905 :
9906 : /* Create a temporary variable for loc return value. Without this,
9907 : we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9908 8993 : temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9909 8993 : gfc_add_modify (&se->pre, temp_var, se->expr);
9910 8993 : se->expr = temp_var;
9911 8993 : }
9912 :
9913 : /* The following routine generates code for the intrinsic functions from
9914 : the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
9915 : F_C_STRING. */
9916 :
9917 : static void
9918 9949 : conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9919 : {
9920 9949 : gfc_actual_arglist *arg = expr->value.function.actual;
9921 :
9922 9949 : if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9923 : {
9924 7559 : if (arg->expr->rank == 0)
9925 2010 : gfc_conv_expr_reference (se, arg->expr);
9926 5549 : else if (gfc_is_simply_contiguous (arg->expr, false, false))
9927 4465 : gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9928 : else
9929 : {
9930 1084 : gfc_conv_expr_descriptor (se, arg->expr);
9931 1084 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9932 : }
9933 :
9934 : /* TODO -- the following two lines shouldn't be necessary, but if
9935 : they're removed, a bug is exposed later in the code path.
9936 : This workaround was thus introduced, but will have to be
9937 : removed; please see PR 35150 for details about the issue. */
9938 7559 : se->expr = convert (pvoid_type_node, se->expr);
9939 7559 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9940 : }
9941 2390 : else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9942 : {
9943 260 : gfc_conv_expr_reference (se, arg->expr);
9944 260 : if (arg->expr->symtree->n.sym->attr.proc_pointer
9945 29 : && arg->expr->symtree->n.sym->attr.dummy)
9946 7 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9947 : /* The code below is necessary to create a reference from the calling
9948 : subprogram to the argument of C_FUNLOC() in the call graph.
9949 : Please see PR 117303 for more details. */
9950 260 : se->expr = convert (pvoid_type_node, se->expr);
9951 260 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9952 : }
9953 2130 : else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9954 : {
9955 2054 : gfc_se arg1se;
9956 2054 : gfc_se arg2se;
9957 :
9958 : /* Build the addr_expr for the first argument. The argument is
9959 : already an *address* so we don't need to set want_pointer in
9960 : the gfc_se. */
9961 2054 : gfc_init_se (&arg1se, NULL);
9962 2054 : gfc_conv_expr (&arg1se, arg->expr);
9963 2054 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9964 2054 : gfc_add_block_to_block (&se->post, &arg1se.post);
9965 :
9966 : /* See if we were given two arguments. */
9967 2054 : if (arg->next->expr == NULL)
9968 : /* Only given one arg so generate a null and do a
9969 : not-equal comparison against the first arg. */
9970 1675 : se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9971 : arg1se.expr,
9972 1675 : fold_convert (TREE_TYPE (arg1se.expr),
9973 : null_pointer_node));
9974 : else
9975 : {
9976 379 : tree eq_expr;
9977 379 : tree not_null_expr;
9978 :
9979 : /* Given two arguments so build the arg2se from second arg. */
9980 379 : gfc_init_se (&arg2se, NULL);
9981 379 : gfc_conv_expr (&arg2se, arg->next->expr);
9982 379 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9983 379 : gfc_add_block_to_block (&se->post, &arg2se.post);
9984 :
9985 : /* Generate test to compare that the two args are equal. */
9986 379 : eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9987 : arg1se.expr, arg2se.expr);
9988 : /* Generate test to ensure that the first arg is not null. */
9989 379 : not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9990 : logical_type_node,
9991 : arg1se.expr, null_pointer_node);
9992 :
9993 : /* Finally, the generated test must check that both arg1 is not
9994 : NULL and that it is equal to the second arg. */
9995 379 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9996 : logical_type_node,
9997 : not_null_expr, eq_expr);
9998 : }
9999 : }
10000 76 : else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
10001 : {
10002 : /* There are three cases:
10003 : f_c_string(string) -> trim(string) // c_null_char
10004 : f_c_string(string, .false.) -> trim(string) // c_null_char
10005 : f_c_string(string, .true.) -> string // c_null_char */
10006 :
10007 76 : gfc_expr *string = arg->expr;
10008 76 : gfc_expr *asis = arg->next->expr;
10009 76 : bool need_asis = false, need_trim = false;
10010 76 : gfc_se asis_se;
10011 :
10012 76 : if (!asis)
10013 : {
10014 : need_trim = true;
10015 : need_asis = false;
10016 : }
10017 54 : else if (asis->expr_type == EXPR_CONSTANT)
10018 : {
10019 32 : need_asis = asis->value.logical;
10020 32 : need_trim = !need_asis;
10021 : }
10022 : else
10023 : {
10024 : /* A conditional expression is needed. */
10025 22 : need_asis = true;
10026 22 : need_trim = true;
10027 22 : gfc_init_se (&asis_se, se);
10028 22 : gfc_conv_expr (&asis_se, asis);
10029 22 : if (asis->expr_type == EXPR_VARIABLE
10030 22 : && asis->symtree->n.sym->attr.dummy
10031 10 : && asis->symtree->n.sym->attr.optional)
10032 : {
10033 6 : tree present = gfc_conv_expr_present (asis->symtree->n.sym);
10034 6 : asis_se.expr
10035 6 : = build3_loc (input_location, COND_EXPR,
10036 : logical_type_node, present,
10037 : asis_se.expr, logical_false_node);
10038 : }
10039 22 : gfc_make_safe_expr (&asis_se);
10040 : }
10041 :
10042 : /* Handle the case of a constant string argument first. */
10043 76 : if (string->expr_type == EXPR_CONSTANT)
10044 : {
10045 : /* Output for the asis "then" case goes tlen/tstr, and the
10046 : trimmed case in elen/estr. */
10047 34 : tree elen, estr, tlen, tstr;
10048 34 : elen = estr = tlen = tstr = NULL_TREE;
10049 :
10050 34 : gfc_char_t *orig_string = string->value.character.string;
10051 34 : gfc_charlen_t orig_len = string->value.character.length;
10052 34 : gfc_charlen_t n;
10053 34 : gfc_char_t *buf
10054 34 : = (gfc_char_t *) alloca ((orig_len + 1) * sizeof (gfc_char_t));
10055 34 : memcpy (buf, orig_string, orig_len * sizeof (gfc_char_t));
10056 34 : buf[orig_len] = '\0';
10057 34 : int kind = gfc_default_character_kind;
10058 34 : gcc_assert (string->ts.kind == kind);
10059 :
10060 : /* Build the new string constant(s). */
10061 34 : if (need_asis)
10062 : {
10063 14 : tstr = gfc_build_wide_string_const (kind, orig_len + 1, buf);
10064 14 : tlen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tstr)));
10065 14 : if (!need_trim)
10066 : {
10067 10 : se->expr = tstr;
10068 10 : se->string_length = tlen;
10069 10 : return;
10070 : }
10071 : }
10072 24 : if (need_trim)
10073 : {
10074 72 : for (n = orig_len; n; n--)
10075 72 : if (buf[n - 1] != ' ')
10076 : break;
10077 24 : buf[n] = '\0';
10078 24 : if (need_asis && n == orig_len)
10079 : {
10080 : /* Special case; trimming is a no-op. Add side-effects
10081 : from the condition and then just return the string
10082 : without a conditional. */
10083 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10084 2 : se->expr = tstr;
10085 2 : se->string_length = tlen;
10086 2 : return;
10087 : }
10088 : else
10089 : {
10090 22 : estr = gfc_build_wide_string_const (kind, n + 1, buf);
10091 22 : elen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (estr)));
10092 : }
10093 22 : if (!need_asis)
10094 : {
10095 20 : se->expr = estr;
10096 20 : se->string_length = elen;
10097 20 : return;
10098 : }
10099 : }
10100 0 : gcc_assert (need_asis && need_trim);
10101 2 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10102 2 : se->expr
10103 2 : = fold_build3_loc (input_location, COND_EXPR,
10104 : pchar_type_node, asis_se.expr,
10105 : tstr, estr);
10106 2 : se->string_length
10107 2 : = fold_build3_loc (input_location, COND_EXPR,
10108 : gfc_charlen_type_node, asis_se.expr,
10109 : tlen, elen);
10110 2 : return;
10111 : }
10112 : else
10113 : /* We have to generate code to do the string transformation(s) at
10114 : runtime. */
10115 : {
10116 42 : tree tmp;
10117 :
10118 : /* Convert input string. */
10119 42 : gfc_se sse;
10120 42 : gfc_init_se (&sse, se);
10121 42 : gfc_conv_expr (&sse, string);
10122 42 : gfc_conv_string_parameter (&sse);
10123 42 : gfc_make_safe_expr (&sse);
10124 42 : gfc_add_block_to_block (&se->pre, &sse.pre);
10125 :
10126 : /* Use a temporary for the (possibly trimmed) string length. */
10127 42 : tree lenvar = gfc_create_var (gfc_charlen_type_node, NULL);
10128 42 : gfc_add_modify (&se->pre, lenvar, sse.string_length);
10129 :
10130 : /* Build the expression for a call to LEN_TRIM if we may need
10131 : to trim the string. If it's conditional, handle that too. */
10132 42 : if (need_trim)
10133 : {
10134 36 : tree trimlen
10135 36 : = build_call_expr_loc (input_location,
10136 : gfor_fndecl_string_len_trim, 2,
10137 : lenvar, sse.expr);
10138 36 : if (need_asis)
10139 : {
10140 18 : gfc_add_block_to_block (&se->pre, &asis_se.pre);
10141 18 : tmp = fold_build3_loc (input_location, COND_EXPR,
10142 : gfc_charlen_type_node, asis_se.expr,
10143 : lenvar, trimlen);
10144 18 : gfc_add_modify (&se->pre, lenvar, tmp);
10145 : }
10146 : else
10147 18 : gfc_add_modify (&se->pre, lenvar, trimlen);
10148 : }
10149 :
10150 : /* Allocate a new string newvar that is lenvar+1 bytes long.
10151 : memcpy the first lenvar bytes from the input string, and
10152 : add a null character. Note that lenvar, the length of
10153 : the (trimmed) original string, has type gfc_charlen_type_node,
10154 : but newlen is size_type_node. */
10155 42 : tree string_type_node = build_pointer_type (char_type_node);
10156 42 : tree newvar = gfc_create_var (string_type_node, NULL);
10157 42 : tree newlen = fold_build2_loc (input_location, PLUS_EXPR,
10158 : size_type_node,
10159 : fold_convert (size_type_node,
10160 : lenvar),
10161 : size_one_node);
10162 42 : gfc_add_modify (&se->pre, newvar,
10163 : gfc_call_malloc (&se->pre, string_type_node,
10164 : newlen));
10165 42 : tmp = build_call_expr_loc (input_location,
10166 : builtin_decl_explicit (BUILT_IN_MEMCPY),
10167 : 3,
10168 : fold_convert (pvoid_type_node, newvar),
10169 : fold_convert (pvoid_type_node, sse.expr),
10170 : fold_convert (size_type_node, lenvar));
10171 42 : gfc_add_expr_to_block (&se->pre, tmp);
10172 42 : tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
10173 : string_type_node, newvar,
10174 : fold_convert (size_type_node, lenvar));
10175 42 : tmp = fold_build1_loc (input_location, INDIRECT_REF,
10176 : char_type_node, tmp);
10177 42 : gfc_add_modify (&se->pre, tmp,
10178 : fold_convert (char_type_node, integer_zero_node));
10179 :
10180 : /* Remember to free the string later. */
10181 42 : tmp = gfc_call_free (newvar);
10182 42 : gfc_add_expr_to_block (&se->post, tmp);
10183 :
10184 : /* Return the result. */
10185 42 : se->expr = newvar;
10186 42 : se->string_length = fold_convert (gfc_charlen_type_node, newlen);
10187 42 : return;
10188 : }
10189 : }
10190 : else
10191 0 : gcc_unreachable ();
10192 : }
10193 :
10194 :
10195 : /* The following routine generates code for the intrinsic
10196 : subroutines from the ISO_C_BINDING module:
10197 : * C_F_POINTER
10198 : * C_F_PROCPOINTER. */
10199 :
10200 : static tree
10201 3370 : conv_isocbinding_subroutine (gfc_code *code)
10202 : {
10203 3370 : gfc_expr *cptr, *fptr, *shape, *lower;
10204 3370 : gfc_se se, cptrse, fptrse, shapese, lowerse;
10205 3370 : gfc_ss *shape_ss, *lower_ss;
10206 3370 : tree desc, dim, tmp, stride, offset, lbound, ubound;
10207 3370 : stmtblock_t body, block;
10208 3370 : gfc_loopinfo loop;
10209 3370 : gfc_actual_arglist *arg;
10210 :
10211 3370 : arg = code->ext.actual;
10212 3370 : cptr = arg->expr;
10213 3370 : fptr = arg->next->expr;
10214 3370 : shape = arg->next->next ? arg->next->next->expr : NULL;
10215 3288 : lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL;
10216 :
10217 3370 : gfc_init_se (&se, NULL);
10218 3370 : gfc_init_se (&cptrse, NULL);
10219 3370 : gfc_conv_expr (&cptrse, cptr);
10220 3370 : gfc_add_block_to_block (&se.pre, &cptrse.pre);
10221 3370 : gfc_add_block_to_block (&se.post, &cptrse.post);
10222 :
10223 3370 : gfc_init_se (&fptrse, NULL);
10224 3370 : if (fptr->rank == 0)
10225 : {
10226 2884 : fptrse.want_pointer = 1;
10227 2884 : gfc_conv_expr (&fptrse, fptr);
10228 2884 : gfc_add_block_to_block (&se.pre, &fptrse.pre);
10229 2884 : gfc_add_block_to_block (&se.post, &fptrse.post);
10230 2884 : if (fptr->symtree->n.sym->attr.proc_pointer
10231 81 : && fptr->symtree->n.sym->attr.dummy)
10232 19 : fptrse.expr = build_fold_indirect_ref_loc (input_location, fptrse.expr);
10233 2884 : se.expr
10234 2884 : = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (fptrse.expr),
10235 : fptrse.expr,
10236 2884 : fold_convert (TREE_TYPE (fptrse.expr), cptrse.expr));
10237 2884 : gfc_add_expr_to_block (&se.pre, se.expr);
10238 2884 : gfc_add_block_to_block (&se.pre, &se.post);
10239 2884 : return gfc_finish_block (&se.pre);
10240 : }
10241 :
10242 486 : gfc_start_block (&block);
10243 :
10244 : /* Get the descriptor of the Fortran pointer. */
10245 486 : fptrse.descriptor_only = 1;
10246 486 : gfc_conv_expr_descriptor (&fptrse, fptr);
10247 486 : gfc_add_block_to_block (&block, &fptrse.pre);
10248 486 : desc = fptrse.expr;
10249 :
10250 : /* Set the span field. */
10251 486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
10252 486 : tmp = fold_convert (gfc_array_index_type, tmp);
10253 486 : gfc_conv_descriptor_span_set (&block, desc, tmp);
10254 :
10255 : /* Set data value, dtype, and offset. */
10256 486 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
10257 486 : gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
10258 486 : gfc_conv_descriptor_dtype_set (&block, desc,
10259 486 : gfc_get_dtype (TREE_TYPE (desc)));
10260 :
10261 : /* Start scalarization of the bounds, using the shape argument. */
10262 :
10263 486 : shape_ss = gfc_walk_expr (shape);
10264 486 : gcc_assert (shape_ss != gfc_ss_terminator);
10265 486 : gfc_init_se (&shapese, NULL);
10266 486 : if (lower)
10267 : {
10268 12 : lower_ss = gfc_walk_expr (lower);
10269 12 : gcc_assert (lower_ss != gfc_ss_terminator);
10270 12 : gfc_init_se (&lowerse, NULL);
10271 : }
10272 :
10273 486 : gfc_init_loopinfo (&loop);
10274 486 : gfc_add_ss_to_loop (&loop, shape_ss);
10275 486 : if (lower)
10276 12 : gfc_add_ss_to_loop (&loop, lower_ss);
10277 486 : gfc_conv_ss_startstride (&loop);
10278 486 : gfc_conv_loop_setup (&loop, &fptr->where);
10279 486 : gfc_mark_ss_chain_used (shape_ss, 1);
10280 486 : if (lower)
10281 12 : gfc_mark_ss_chain_used (lower_ss, 1);
10282 :
10283 486 : gfc_copy_loopinfo_to_se (&shapese, &loop);
10284 486 : shapese.ss = shape_ss;
10285 486 : if (lower)
10286 : {
10287 12 : gfc_copy_loopinfo_to_se (&lowerse, &loop);
10288 12 : lowerse.ss = lower_ss;
10289 : }
10290 :
10291 486 : stride = gfc_create_var (gfc_array_index_type, "stride");
10292 486 : offset = gfc_create_var (gfc_array_index_type, "offset");
10293 486 : gfc_add_modify (&block, stride, gfc_index_one_node);
10294 486 : gfc_add_modify (&block, offset, gfc_index_zero_node);
10295 :
10296 : /* Loop body. */
10297 486 : gfc_start_scalarized_body (&loop, &body);
10298 :
10299 486 : dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10300 : loop.loopvar[0], loop.from[0]);
10301 :
10302 486 : if (lower)
10303 : {
10304 12 : gfc_conv_expr (&lowerse, lower);
10305 12 : gfc_add_block_to_block (&body, &lowerse.pre);
10306 12 : lbound = fold_convert (gfc_array_index_type, lowerse.expr);
10307 12 : gfc_add_block_to_block (&body, &lowerse.post);
10308 : }
10309 : else
10310 474 : lbound = gfc_index_one_node;
10311 :
10312 : /* Set bounds and stride. */
10313 486 : gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
10314 486 : gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
10315 :
10316 486 : gfc_conv_expr (&shapese, shape);
10317 486 : gfc_add_block_to_block (&body, &shapese.pre);
10318 486 : ubound = fold_build2_loc (
10319 : input_location, MINUS_EXPR, gfc_array_index_type,
10320 : fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
10321 : fold_convert (gfc_array_index_type, shapese.expr)),
10322 : gfc_index_one_node);
10323 486 : gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
10324 486 : gfc_add_block_to_block (&body, &shapese.post);
10325 :
10326 : /* Calculate offset. */
10327 486 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10328 : stride, lbound);
10329 486 : gfc_add_modify (&body, offset,
10330 : fold_build2_loc (input_location, PLUS_EXPR,
10331 : gfc_array_index_type, offset, tmp));
10332 :
10333 : /* Update stride. */
10334 486 : gfc_add_modify (
10335 : &body, stride,
10336 : fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
10337 : fold_convert (gfc_array_index_type, shapese.expr)));
10338 : /* Finish scalarization loop. */
10339 486 : gfc_trans_scalarizing_loops (&loop, &body);
10340 486 : gfc_add_block_to_block (&block, &loop.pre);
10341 486 : gfc_add_block_to_block (&block, &loop.post);
10342 486 : gfc_add_block_to_block (&block, &fptrse.post);
10343 486 : gfc_cleanup_loop (&loop);
10344 :
10345 486 : gfc_add_modify (&block, offset,
10346 : fold_build1_loc (input_location, NEGATE_EXPR,
10347 : gfc_array_index_type, offset));
10348 486 : gfc_conv_descriptor_offset_set (&block, desc, offset);
10349 :
10350 486 : gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
10351 486 : gfc_add_block_to_block (&se.pre, &se.post);
10352 486 : return gfc_finish_block (&se.pre);
10353 : }
10354 :
10355 :
10356 : /* The following routine generates code for both forms of the intrinsic
10357 : subroutine C_F_STRPOINTER from the ISO_C_BINDING module. */
10358 : static tree
10359 60 : conv_isocbinding_subroutine_strpointer (gfc_code *code)
10360 : {
10361 60 : gfc_actual_arglist *arg = code->ext.actual;
10362 60 : gfc_expr *arg0 = arg->expr;
10363 60 : gfc_expr *fstrptr = arg->next->expr;
10364 60 : gfc_expr *nchars = arg->next->next->expr;
10365 60 : tree ptr;
10366 60 : tree size = NULL_TREE;
10367 60 : tree nc = NULL_TREE;
10368 60 : tree fstrptr_ptr, fstrptr_len;
10369 60 : stmtblock_t block;
10370 60 : gfc_init_block (&block);
10371 60 : gfc_se se0, se1, se2;
10372 60 : gfc_init_se (&se0, NULL);
10373 60 : gfc_init_se (&se1, NULL);
10374 60 : gfc_init_se (&se2, NULL);
10375 :
10376 : /* arg0 can either be a simply contiguous rank-one character array,
10377 : or a scalar of type c_ptr that points to a contiguous array.
10378 : In the first case nchars may be omitted and defaults to the size
10379 : of the array. */
10380 60 : if (arg0->rank == 1)
10381 : {
10382 42 : gfc_array_ref *ar = gfc_find_array_ref (arg0);
10383 42 : if (ar->as && ar->as->type == AS_ASSUMED_SIZE
10384 12 : && (ar->type == AR_FULL || ar->end[0] == nullptr))
10385 : /* No size available. */
10386 12 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, NULL);
10387 : else
10388 : {
10389 30 : gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, &size);
10390 30 : gcc_assert (size);
10391 : }
10392 42 : ptr = se0.expr;
10393 : }
10394 18 : else if (arg0->rank == 0)
10395 : {
10396 : /* Scalar case. arg0 is a C pointer to the string, and the
10397 : nchars argument is required. */
10398 18 : gfc_conv_expr (&se0, arg0);
10399 18 : ptr = se0.expr;
10400 : /* We already issued a diagnostic for this in parsing. */
10401 18 : gcc_assert (nchars);
10402 : }
10403 : else
10404 0 : gcc_unreachable ();
10405 :
10406 : /* Translate the fortran array pointer argument. AFAICT the
10407 : representation here is that this returns the pointer location in
10408 : se1.expr and there is a separate decl for the length.
10409 : Of course none of this is properly documented.... :-( */
10410 60 : gfc_conv_expr (&se1, fstrptr);
10411 60 : fstrptr_ptr = se1.expr;
10412 60 : gcc_assert (fstrptr->ts.u.cl && fstrptr->ts.u.cl->backend_decl);
10413 60 : fstrptr_len = fstrptr->ts.u.cl->backend_decl;
10414 :
10415 : /* Translate nchars, if provided. If we have both the array size
10416 : and nchars, take the minimum value. NC is the tree expr to hold
10417 : the value. */
10418 60 : if (nchars)
10419 : {
10420 30 : gfc_conv_expr (&se2, nchars);
10421 30 : nc = se2.expr;
10422 30 : if (size)
10423 0 : nc = fold_build2_loc (input_location, MIN_EXPR,
10424 0 : TREE_TYPE (nc), nc, size);
10425 : /* Check for the case where an optional dummy parameter is
10426 : passed as the optional nchars argument. It's not supposed to
10427 : be omitted if we don't also have an array size; rather than
10428 : produce a run-time error, assume size 0. */
10429 30 : if (nchars->expr_type == EXPR_VARIABLE
10430 18 : && nchars->symtree->n.sym->attr.dummy
10431 18 : && nchars->symtree->n.sym->attr.optional)
10432 : {
10433 12 : tree present = gfc_conv_expr_present (nchars->symtree->n.sym);
10434 12 : nc = build3_loc (input_location, COND_EXPR,
10435 12 : TREE_TYPE (nc), present, nc,
10436 24 : size ? size : build_int_cst (TREE_TYPE (nc), 0));
10437 : }
10438 : }
10439 : else
10440 : {
10441 30 : gcc_assert (size);
10442 : nc = size;
10443 : }
10444 :
10445 : /* Collect argument side-effect statements. */
10446 60 : gfc_add_block_to_block (&block, &se0.pre);
10447 60 : gfc_add_block_to_block (&block, &se1.pre);
10448 60 : gfc_add_block_to_block (&block, &se2.pre);
10449 :
10450 : /* Generate a call to builtin_strnlen to get the C string length
10451 : for the output fstrptr. */
10452 60 : ptr = gfc_evaluate_now (ptr, &block);
10453 60 : size = build_call_expr_loc (input_location,
10454 : builtin_decl_explicit (BUILT_IN_STRNLEN), 2,
10455 : fold_convert (const_ptr_type_node, ptr),
10456 : fold_convert (size_type_node, nc));
10457 :
10458 : /* Stuff the raw C char pointer PTR and actual length SIZE into fstrptr. */
10459 60 : gfc_add_modify (&block, fstrptr_ptr,
10460 60 : fold_convert (TREE_TYPE (fstrptr_ptr), ptr));
10461 60 : gfc_add_modify (&block, fstrptr_len,
10462 : fold_convert (gfc_charlen_type_node, size));
10463 :
10464 : /* Collect argument cleanups. */
10465 60 : gfc_add_block_to_block (&block, &se2.post);
10466 60 : gfc_add_block_to_block (&block, &se1.post);
10467 60 : gfc_add_block_to_block (&block, &se0.post);
10468 :
10469 60 : return gfc_finish_block (&block);
10470 : }
10471 :
10472 : /* Save and restore floating-point state. */
10473 :
10474 : tree
10475 944 : gfc_save_fp_state (stmtblock_t *block)
10476 : {
10477 944 : tree type, fpstate, tmp;
10478 :
10479 944 : type = build_array_type (char_type_node,
10480 : build_range_type (size_type_node, size_zero_node,
10481 : size_int (GFC_FPE_STATE_BUFFER_SIZE)));
10482 944 : fpstate = gfc_create_var (type, "fpstate");
10483 944 : fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
10484 :
10485 944 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
10486 : 1, fpstate);
10487 944 : gfc_add_expr_to_block (block, tmp);
10488 :
10489 944 : return fpstate;
10490 : }
10491 :
10492 :
10493 : void
10494 944 : gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
10495 : {
10496 944 : tree tmp;
10497 :
10498 944 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
10499 : 1, fpstate);
10500 944 : gfc_add_expr_to_block (block, tmp);
10501 944 : }
10502 :
10503 :
10504 : /* Generate code for arguments of IEEE functions. */
10505 :
10506 : static void
10507 12457 : conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
10508 : int nargs)
10509 : {
10510 12457 : gfc_actual_arglist *actual;
10511 12457 : gfc_expr *e;
10512 12457 : gfc_se argse;
10513 12457 : int arg;
10514 :
10515 12457 : actual = expr->value.function.actual;
10516 34461 : for (arg = 0; arg < nargs; arg++, actual = actual->next)
10517 : {
10518 22004 : gcc_assert (actual);
10519 22004 : e = actual->expr;
10520 :
10521 22004 : gfc_init_se (&argse, se);
10522 22004 : gfc_conv_expr_val (&argse, e);
10523 :
10524 22004 : gfc_add_block_to_block (&se->pre, &argse.pre);
10525 22004 : gfc_add_block_to_block (&se->post, &argse.post);
10526 22004 : argarray[arg] = argse.expr;
10527 : }
10528 12457 : }
10529 :
10530 :
10531 : /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
10532 : and IEEE_UNORDERED, which translate directly to GCC type-generic
10533 : built-ins. */
10534 :
10535 : static void
10536 1062 : conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
10537 : enum built_in_function code, int nargs)
10538 : {
10539 1062 : tree args[2];
10540 1062 : gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
10541 :
10542 1062 : conv_ieee_function_args (se, expr, args, nargs);
10543 1062 : se->expr = build_call_expr_loc_array (input_location,
10544 : builtin_decl_explicit (code),
10545 : nargs, args);
10546 2388 : STRIP_TYPE_NOPS (se->expr);
10547 1062 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10548 1062 : }
10549 :
10550 :
10551 : /* Generate code for intrinsics IEEE_SIGNBIT. */
10552 :
10553 : static void
10554 624 : conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
10555 : {
10556 624 : tree arg, signbit;
10557 :
10558 624 : conv_ieee_function_args (se, expr, &arg, 1);
10559 624 : signbit = build_call_expr_loc (input_location,
10560 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10561 : 1, arg);
10562 624 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10563 : signbit, integer_zero_node);
10564 624 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
10565 624 : }
10566 :
10567 :
10568 : /* Generate code for IEEE_IS_NORMAL intrinsic:
10569 : IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
10570 :
10571 : static void
10572 312 : conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
10573 : {
10574 312 : tree arg, isnormal, iszero;
10575 :
10576 : /* Convert arg, evaluate it only once. */
10577 312 : conv_ieee_function_args (se, expr, &arg, 1);
10578 312 : arg = gfc_evaluate_now (arg, &se->pre);
10579 :
10580 312 : isnormal = build_call_expr_loc (input_location,
10581 : builtin_decl_explicit (BUILT_IN_ISNORMAL),
10582 : 1, arg);
10583 312 : iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
10584 312 : build_real_from_int_cst (TREE_TYPE (arg),
10585 312 : integer_zero_node));
10586 312 : se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10587 : logical_type_node, isnormal, iszero);
10588 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10589 312 : }
10590 :
10591 :
10592 : /* Generate code for IEEE_IS_NEGATIVE intrinsic:
10593 : IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
10594 :
10595 : static void
10596 312 : conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
10597 : {
10598 312 : tree arg, signbit, isnan;
10599 :
10600 : /* Convert arg, evaluate it only once. */
10601 312 : conv_ieee_function_args (se, expr, &arg, 1);
10602 312 : arg = gfc_evaluate_now (arg, &se->pre);
10603 :
10604 312 : isnan = build_call_expr_loc (input_location,
10605 : builtin_decl_explicit (BUILT_IN_ISNAN),
10606 : 1, arg);
10607 936 : STRIP_TYPE_NOPS (isnan);
10608 :
10609 312 : signbit = build_call_expr_loc (input_location,
10610 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10611 : 1, arg);
10612 312 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10613 : signbit, integer_zero_node);
10614 :
10615 312 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10616 : logical_type_node, signbit,
10617 : fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10618 312 : TREE_TYPE(isnan), isnan));
10619 :
10620 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
10621 312 : }
10622 :
10623 :
10624 : /* Generate code for IEEE_LOGB and IEEE_RINT. */
10625 :
10626 : static void
10627 240 : conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
10628 : enum built_in_function code)
10629 : {
10630 240 : tree arg, decl, call, fpstate;
10631 240 : int argprec;
10632 :
10633 240 : conv_ieee_function_args (se, expr, &arg, 1);
10634 240 : argprec = TYPE_PRECISION (TREE_TYPE (arg));
10635 240 : decl = builtin_decl_for_precision (code, argprec);
10636 :
10637 : /* Save floating-point state. */
10638 240 : fpstate = gfc_save_fp_state (&se->pre);
10639 :
10640 : /* Make the function call. */
10641 240 : call = build_call_expr_loc (input_location, decl, 1, arg);
10642 240 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
10643 :
10644 : /* Restore floating-point state. */
10645 240 : gfc_restore_fp_state (&se->post, fpstate);
10646 240 : }
10647 :
10648 :
10649 : /* Generate code for IEEE_REM. */
10650 :
10651 : static void
10652 84 : conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
10653 : {
10654 84 : tree args[2], decl, call, fpstate;
10655 84 : int argprec;
10656 :
10657 84 : conv_ieee_function_args (se, expr, args, 2);
10658 :
10659 : /* If arguments have unequal size, convert them to the larger. */
10660 84 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
10661 84 : > TYPE_PRECISION (TREE_TYPE (args[1])))
10662 6 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10663 78 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
10664 78 : > TYPE_PRECISION (TREE_TYPE (args[0])))
10665 24 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
10666 :
10667 84 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10668 84 : decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
10669 :
10670 : /* Save floating-point state. */
10671 84 : fpstate = gfc_save_fp_state (&se->pre);
10672 :
10673 : /* Make the function call. */
10674 84 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10675 84 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10676 :
10677 : /* Restore floating-point state. */
10678 84 : gfc_restore_fp_state (&se->post, fpstate);
10679 84 : }
10680 :
10681 :
10682 : /* Generate code for IEEE_NEXT_AFTER. */
10683 :
10684 : static void
10685 180 : conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
10686 : {
10687 180 : tree args[2], decl, call, fpstate;
10688 180 : int argprec;
10689 :
10690 180 : conv_ieee_function_args (se, expr, args, 2);
10691 :
10692 : /* Result has the characteristics of first argument. */
10693 180 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
10694 180 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10695 180 : decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
10696 :
10697 : /* Save floating-point state. */
10698 180 : fpstate = gfc_save_fp_state (&se->pre);
10699 :
10700 : /* Make the function call. */
10701 180 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10702 180 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10703 :
10704 : /* Restore floating-point state. */
10705 180 : gfc_restore_fp_state (&se->post, fpstate);
10706 180 : }
10707 :
10708 :
10709 : /* Generate code for IEEE_SCALB. */
10710 :
10711 : static void
10712 228 : conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
10713 : {
10714 228 : tree args[2], decl, call, huge, type;
10715 228 : int argprec, n;
10716 :
10717 228 : conv_ieee_function_args (se, expr, args, 2);
10718 :
10719 : /* Result has the characteristics of first argument. */
10720 228 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10721 228 : decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10722 :
10723 228 : if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10724 : {
10725 : /* We need to fold the integer into the range of a C int. */
10726 18 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10727 18 : type = TREE_TYPE (args[1]);
10728 :
10729 18 : n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10730 18 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10731 : gfc_c_int_kind);
10732 18 : huge = fold_convert (type, huge);
10733 18 : args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10734 : huge);
10735 18 : args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10736 : fold_build1_loc (input_location, NEGATE_EXPR,
10737 : type, huge));
10738 : }
10739 :
10740 228 : args[1] = fold_convert (integer_type_node, args[1]);
10741 :
10742 : /* Make the function call. */
10743 228 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10744 228 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10745 228 : }
10746 :
10747 :
10748 : /* Generate code for IEEE_COPY_SIGN. */
10749 :
10750 : static void
10751 576 : conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10752 : {
10753 576 : tree args[2], decl, sign;
10754 576 : int argprec;
10755 :
10756 576 : conv_ieee_function_args (se, expr, args, 2);
10757 :
10758 : /* Get the sign of the second argument. */
10759 576 : sign = build_call_expr_loc (input_location,
10760 : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10761 : 1, args[1]);
10762 576 : sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10763 : sign, integer_zero_node);
10764 :
10765 : /* Create a value of one, with the right sign. */
10766 576 : sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10767 : sign,
10768 : fold_build1_loc (input_location, NEGATE_EXPR,
10769 : integer_type_node,
10770 : integer_one_node),
10771 : integer_one_node);
10772 576 : args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10773 :
10774 576 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10775 576 : decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10776 :
10777 576 : se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10778 576 : }
10779 :
10780 :
10781 : /* Generate code for IEEE_CLASS. */
10782 :
10783 : static void
10784 648 : conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10785 : {
10786 648 : tree arg, c, t1, t2, t3, t4;
10787 :
10788 : /* Convert arg, evaluate it only once. */
10789 648 : conv_ieee_function_args (se, expr, &arg, 1);
10790 648 : arg = gfc_evaluate_now (arg, &se->pre);
10791 :
10792 648 : c = build_call_expr_loc (input_location,
10793 : builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
10794 : build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10795 : build_int_cst (integer_type_node,
10796 : IEEE_POSITIVE_INF),
10797 : build_int_cst (integer_type_node,
10798 : IEEE_POSITIVE_NORMAL),
10799 : build_int_cst (integer_type_node,
10800 : IEEE_POSITIVE_DENORMAL),
10801 : build_int_cst (integer_type_node,
10802 : IEEE_POSITIVE_ZERO),
10803 : arg);
10804 648 : c = gfc_evaluate_now (c, &se->pre);
10805 648 : t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10806 : c, build_int_cst (integer_type_node,
10807 : IEEE_QUIET_NAN));
10808 648 : t2 = build_call_expr_loc (input_location,
10809 : builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
10810 : arg);
10811 648 : t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10812 648 : t2, build_zero_cst (TREE_TYPE (t2)));
10813 648 : t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10814 : logical_type_node, t1, t2);
10815 648 : t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10816 : c, build_int_cst (integer_type_node,
10817 : IEEE_POSITIVE_ZERO));
10818 648 : t4 = build_call_expr_loc (input_location,
10819 : builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
10820 : arg);
10821 648 : t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10822 648 : t4, build_zero_cst (TREE_TYPE (t4)));
10823 648 : t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10824 : logical_type_node, t3, t4);
10825 648 : int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10826 648 : gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10827 648 : gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10828 648 : gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10829 648 : gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10830 648 : gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10831 648 : t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10832 648 : build_int_cst (TREE_TYPE (c), s), c);
10833 648 : t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10834 : t3, t4, c);
10835 648 : t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10836 648 : build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10837 : t3);
10838 648 : tree type = gfc_typenode_for_spec (&expr->ts);
10839 : /* Perform a quick sanity check that the return type is
10840 : IEEE_CLASS_TYPE derived type defined in
10841 : libgfortran/ieee/ieee_arithmetic.F90
10842 : Primarily check that it is a derived type with a single
10843 : member in it. */
10844 648 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10845 648 : tree field = NULL_TREE;
10846 1296 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10847 648 : if (TREE_CODE (f) == FIELD_DECL)
10848 : {
10849 648 : gcc_assert (field == NULL_TREE);
10850 : field = f;
10851 : }
10852 648 : gcc_assert (field);
10853 648 : t1 = fold_convert (TREE_TYPE (field), t1);
10854 648 : se->expr = build_constructor_single (type, field, t1);
10855 648 : }
10856 :
10857 :
10858 : /* Generate code for IEEE_VALUE. */
10859 :
10860 : static void
10861 1111 : conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10862 : {
10863 1111 : tree args[2], arg, ret, tmp;
10864 1111 : stmtblock_t body;
10865 :
10866 : /* Convert args, evaluate the second one only once. */
10867 1111 : conv_ieee_function_args (se, expr, args, 2);
10868 1111 : arg = gfc_evaluate_now (args[1], &se->pre);
10869 :
10870 1111 : tree type = TREE_TYPE (arg);
10871 : /* Perform a quick sanity check that the second argument's type is
10872 : IEEE_CLASS_TYPE derived type defined in
10873 : libgfortran/ieee/ieee_arithmetic.F90
10874 : Primarily check that it is a derived type with a single
10875 : member in it. */
10876 1111 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10877 1111 : tree field = NULL_TREE;
10878 2222 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10879 1111 : if (TREE_CODE (f) == FIELD_DECL)
10880 : {
10881 1111 : gcc_assert (field == NULL_TREE);
10882 : field = f;
10883 : }
10884 1111 : gcc_assert (field);
10885 1111 : arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10886 : arg, field, NULL_TREE);
10887 1111 : arg = gfc_evaluate_now (arg, &se->pre);
10888 :
10889 1111 : type = gfc_typenode_for_spec (&expr->ts);
10890 1111 : gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10891 1111 : ret = gfc_create_var (type, NULL);
10892 :
10893 1111 : gfc_init_block (&body);
10894 :
10895 1111 : tree end_label = gfc_build_label_decl (NULL_TREE);
10896 13332 : for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10897 : {
10898 11110 : tree label = gfc_build_label_decl (NULL_TREE);
10899 11110 : tree low = build_int_cst (TREE_TYPE (arg), c);
10900 11110 : tmp = build_case_label (low, low, label);
10901 11110 : gfc_add_expr_to_block (&body, tmp);
10902 :
10903 11110 : REAL_VALUE_TYPE real;
10904 11110 : int k;
10905 11110 : switch (c)
10906 : {
10907 1111 : case IEEE_SIGNALING_NAN:
10908 1111 : real_nan (&real, "", 0, TYPE_MODE (type));
10909 1111 : break;
10910 1111 : case IEEE_QUIET_NAN:
10911 1111 : real_nan (&real, "", 1, TYPE_MODE (type));
10912 1111 : break;
10913 1111 : case IEEE_NEGATIVE_INF:
10914 1111 : real_inf (&real);
10915 1111 : real = real_value_negate (&real);
10916 1111 : break;
10917 1111 : case IEEE_NEGATIVE_NORMAL:
10918 1111 : real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10919 1111 : break;
10920 1111 : case IEEE_NEGATIVE_DENORMAL:
10921 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10922 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10923 : type, GFC_RND_MODE);
10924 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10925 1111 : real = real_value_negate (&real);
10926 1111 : break;
10927 1111 : case IEEE_NEGATIVE_ZERO:
10928 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10929 1111 : real = real_value_negate (&real);
10930 1111 : break;
10931 1111 : case IEEE_POSITIVE_ZERO:
10932 : /* Make this also the default: label. The other possibility
10933 : would be to add a separate default: label followed by
10934 : __builtin_unreachable (). */
10935 1111 : label = gfc_build_label_decl (NULL_TREE);
10936 1111 : tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10937 1111 : gfc_add_expr_to_block (&body, tmp);
10938 1111 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10939 1111 : break;
10940 1111 : case IEEE_POSITIVE_DENORMAL:
10941 1111 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10942 1111 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10943 : type, GFC_RND_MODE);
10944 1111 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10945 1111 : break;
10946 1111 : case IEEE_POSITIVE_NORMAL:
10947 1111 : real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10948 1111 : break;
10949 1111 : case IEEE_POSITIVE_INF:
10950 1111 : real_inf (&real);
10951 1111 : break;
10952 : default:
10953 : gcc_unreachable ();
10954 : }
10955 :
10956 11110 : tree val = build_real (type, real);
10957 11110 : gfc_add_modify (&body, ret, val);
10958 :
10959 11110 : tmp = build1_v (GOTO_EXPR, end_label);
10960 11110 : gfc_add_expr_to_block (&body, tmp);
10961 : }
10962 :
10963 1111 : tmp = gfc_finish_block (&body);
10964 1111 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10965 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10966 :
10967 1111 : tmp = build1_v (LABEL_EXPR, end_label);
10968 1111 : gfc_add_expr_to_block (&se->pre, tmp);
10969 :
10970 1111 : se->expr = ret;
10971 1111 : }
10972 :
10973 :
10974 : /* Generate code for IEEE_FMA. */
10975 :
10976 : static void
10977 120 : conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10978 : {
10979 120 : tree args[3], decl, call;
10980 120 : int argprec;
10981 :
10982 120 : conv_ieee_function_args (se, expr, args, 3);
10983 :
10984 : /* All three arguments should have the same type. */
10985 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10986 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10987 :
10988 : /* Call the type-generic FMA built-in. */
10989 120 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10990 120 : decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
10991 120 : call = build_call_expr_loc_array (input_location, decl, 3, args);
10992 :
10993 : /* Convert to the final type. */
10994 120 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10995 120 : }
10996 :
10997 :
10998 : /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10999 :
11000 : static void
11001 3072 : conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
11002 : const char *name)
11003 : {
11004 3072 : tree args[2], func;
11005 3072 : built_in_function fn;
11006 :
11007 3072 : conv_ieee_function_args (se, expr, args, 2);
11008 3072 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
11009 3072 : args[0] = gfc_evaluate_now (args[0], &se->pre);
11010 3072 : args[1] = gfc_evaluate_now (args[1], &se->pre);
11011 :
11012 3072 : if (startswith (name, "mag"))
11013 : {
11014 : /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
11015 : fminmag() and fmaxmag(), which do not exist as built-ins.
11016 :
11017 : Following glibc, we emit this:
11018 :
11019 : fminmag (x, y) {
11020 : ax = ABS (x);
11021 : ay = ABS (y);
11022 : if (isless (ax, ay))
11023 : return x;
11024 : else if (isgreater (ax, ay))
11025 : return y;
11026 : else if (ax == ay)
11027 : return x < y ? x : y;
11028 : else if (issignaling (x) || issignaling (y))
11029 : return x + y;
11030 : else
11031 : return isnan (y) ? x : y;
11032 : }
11033 :
11034 : fmaxmag (x, y) {
11035 : ax = ABS (x);
11036 : ay = ABS (y);
11037 : if (isgreater (ax, ay))
11038 : return x;
11039 : else if (isless (ax, ay))
11040 : return y;
11041 : else if (ax == ay)
11042 : return x > y ? x : y;
11043 : else if (issignaling (x) || issignaling (y))
11044 : return x + y;
11045 : else
11046 : return isnan (y) ? x : y;
11047 : }
11048 :
11049 : */
11050 :
11051 1536 : tree abs0, abs1, sig0, sig1;
11052 1536 : tree cond1, cond2, cond3, cond4, cond5;
11053 1536 : tree res;
11054 1536 : tree type = TREE_TYPE (args[0]);
11055 :
11056 1536 : func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
11057 1536 : abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
11058 1536 : abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
11059 1536 : abs0 = gfc_evaluate_now (abs0, &se->pre);
11060 1536 : abs1 = gfc_evaluate_now (abs1, &se->pre);
11061 :
11062 1536 : cond5 = build_call_expr_loc (input_location,
11063 : builtin_decl_explicit (BUILT_IN_ISNAN),
11064 : 1, args[1]);
11065 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
11066 : args[0], args[1]);
11067 :
11068 1536 : sig0 = build_call_expr_loc (input_location,
11069 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11070 : 1, args[0]);
11071 1536 : sig1 = build_call_expr_loc (input_location,
11072 : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
11073 : 1, args[1]);
11074 1536 : cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
11075 : logical_type_node, sig0, sig1);
11076 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
11077 : fold_build2_loc (input_location, PLUS_EXPR,
11078 : type, args[0], args[1]),
11079 : res);
11080 :
11081 1536 : cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11082 : abs0, abs1);
11083 2304 : res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
11084 : fold_build2_loc (input_location,
11085 : max ? MAX_EXPR : MIN_EXPR,
11086 : type, args[0], args[1]),
11087 : res);
11088 :
11089 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
11090 1536 : cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11091 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
11092 : args[1], res);
11093 :
11094 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
11095 1536 : cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
11096 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
11097 : args[0], res);
11098 :
11099 1536 : se->expr = res;
11100 : }
11101 : else
11102 : {
11103 : /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
11104 1536 : fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
11105 1536 : func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind);
11106 1536 : se->expr = build_call_expr_loc_array (input_location, func, 2, args);
11107 : }
11108 3072 : }
11109 :
11110 :
11111 : /* Generate code for comparison functions IEEE_QUIET_* and
11112 : IEEE_SIGNALING_*. */
11113 :
11114 : static void
11115 3888 : conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
11116 : const char *name)
11117 : {
11118 3888 : tree args[2];
11119 3888 : tree arg1, arg2, res;
11120 :
11121 : /* Evaluate arguments only once. */
11122 3888 : conv_ieee_function_args (se, expr, args, 2);
11123 3888 : arg1 = gfc_evaluate_now (args[0], &se->pre);
11124 3888 : arg2 = gfc_evaluate_now (args[1], &se->pre);
11125 :
11126 3888 : if (startswith (name, "eq"))
11127 : {
11128 648 : if (signaling)
11129 324 : res = build_call_expr_loc (input_location,
11130 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11131 : 2, arg1, arg2);
11132 : else
11133 324 : res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11134 : arg1, arg2);
11135 : }
11136 3240 : else if (startswith (name, "ne"))
11137 : {
11138 648 : if (signaling)
11139 : {
11140 324 : res = build_call_expr_loc (input_location,
11141 : builtin_decl_explicit (BUILT_IN_ISEQSIG),
11142 : 2, arg1, arg2);
11143 324 : res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
11144 : logical_type_node, res);
11145 : }
11146 : else
11147 324 : res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
11148 : arg1, arg2);
11149 : }
11150 2592 : else if (startswith (name, "ge"))
11151 : {
11152 648 : if (signaling)
11153 324 : res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
11154 : arg1, arg2);
11155 : else
11156 324 : res = build_call_expr_loc (input_location,
11157 : builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
11158 : 2, arg1, arg2);
11159 : }
11160 1944 : else if (startswith (name, "gt"))
11161 : {
11162 648 : if (signaling)
11163 324 : res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
11164 : arg1, arg2);
11165 : else
11166 324 : res = build_call_expr_loc (input_location,
11167 : builtin_decl_explicit (BUILT_IN_ISGREATER),
11168 : 2, arg1, arg2);
11169 : }
11170 1296 : else if (startswith (name, "le"))
11171 : {
11172 648 : if (signaling)
11173 324 : res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
11174 : arg1, arg2);
11175 : else
11176 324 : res = build_call_expr_loc (input_location,
11177 : builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
11178 : 2, arg1, arg2);
11179 : }
11180 648 : else if (startswith (name, "lt"))
11181 : {
11182 648 : if (signaling)
11183 324 : res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11184 : arg1, arg2);
11185 : else
11186 324 : res = build_call_expr_loc (input_location,
11187 : builtin_decl_explicit (BUILT_IN_ISLESS),
11188 : 2, arg1, arg2);
11189 : }
11190 : else
11191 0 : gcc_unreachable ();
11192 :
11193 3888 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
11194 3888 : }
11195 :
11196 :
11197 : /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
11198 : module. */
11199 :
11200 : bool
11201 13939 : gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
11202 : {
11203 13939 : const char *name = expr->value.function.name;
11204 :
11205 13939 : if (startswith (name, "_gfortran_ieee_is_nan"))
11206 522 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
11207 13417 : else if (startswith (name, "_gfortran_ieee_is_finite"))
11208 372 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
11209 13045 : else if (startswith (name, "_gfortran_ieee_unordered"))
11210 168 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
11211 12877 : else if (startswith (name, "_gfortran_ieee_signbit"))
11212 624 : conv_intrinsic_ieee_signbit (se, expr);
11213 12253 : else if (startswith (name, "_gfortran_ieee_is_normal"))
11214 312 : conv_intrinsic_ieee_is_normal (se, expr);
11215 11941 : else if (startswith (name, "_gfortran_ieee_is_negative"))
11216 312 : conv_intrinsic_ieee_is_negative (se, expr);
11217 11629 : else if (startswith (name, "_gfortran_ieee_copy_sign"))
11218 576 : conv_intrinsic_ieee_copy_sign (se, expr);
11219 11053 : else if (startswith (name, "_gfortran_ieee_scalb"))
11220 228 : conv_intrinsic_ieee_scalb (se, expr);
11221 10825 : else if (startswith (name, "_gfortran_ieee_next_after"))
11222 180 : conv_intrinsic_ieee_next_after (se, expr);
11223 10645 : else if (startswith (name, "_gfortran_ieee_rem"))
11224 84 : conv_intrinsic_ieee_rem (se, expr);
11225 10561 : else if (startswith (name, "_gfortran_ieee_logb"))
11226 144 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
11227 10417 : else if (startswith (name, "_gfortran_ieee_rint"))
11228 96 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
11229 10321 : else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
11230 648 : conv_intrinsic_ieee_class (se, expr);
11231 9673 : else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
11232 1111 : conv_intrinsic_ieee_value (se, expr);
11233 8562 : else if (startswith (name, "_gfortran_ieee_fma"))
11234 120 : conv_intrinsic_ieee_fma (se, expr);
11235 8442 : else if (startswith (name, "_gfortran_ieee_min_num_"))
11236 1536 : conv_intrinsic_ieee_minmax (se, expr, 0, name + 23);
11237 6906 : else if (startswith (name, "_gfortran_ieee_max_num_"))
11238 1536 : conv_intrinsic_ieee_minmax (se, expr, 1, name + 23);
11239 5370 : else if (startswith (name, "_gfortran_ieee_quiet_"))
11240 1944 : conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
11241 3426 : else if (startswith (name, "_gfortran_ieee_signaling_"))
11242 1944 : conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
11243 : else
11244 : /* It is not among the functions we translate directly. We return
11245 : false, so a library function call is emitted. */
11246 : return false;
11247 :
11248 : return true;
11249 : }
11250 :
11251 :
11252 : /* Generate a direct call to malloc() for the MALLOC intrinsic. */
11253 :
11254 : static void
11255 16 : gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
11256 : {
11257 16 : tree arg, res, restype;
11258 :
11259 16 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
11260 16 : arg = fold_convert (size_type_node, arg);
11261 16 : res = build_call_expr_loc (input_location,
11262 : builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
11263 16 : restype = gfc_typenode_for_spec (&expr->ts);
11264 16 : se->expr = fold_convert (restype, res);
11265 16 : }
11266 :
11267 :
11268 : /* Generate code for an intrinsic function. Some map directly to library
11269 : calls, others get special handling. In some cases the name of the function
11270 : used depends on the type specifiers. */
11271 :
11272 : void
11273 269834 : gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
11274 : {
11275 269834 : const char *name;
11276 269834 : int lib, kind;
11277 269834 : tree fndecl;
11278 :
11279 269834 : name = &expr->value.function.name[2];
11280 :
11281 269834 : if (expr->rank > 0)
11282 : {
11283 50687 : lib = gfc_is_intrinsic_libcall (expr);
11284 50687 : if (lib != 0)
11285 : {
11286 19242 : if (lib == 1)
11287 11792 : se->ignore_optional = 1;
11288 :
11289 19242 : switch (expr->value.function.isym->id)
11290 : {
11291 5879 : case GFC_ISYM_EOSHIFT:
11292 5879 : case GFC_ISYM_PACK:
11293 5879 : case GFC_ISYM_RESHAPE:
11294 5879 : case GFC_ISYM_REDUCE:
11295 : /* For all of those the first argument specifies the type and the
11296 : third is optional. */
11297 5879 : conv_generic_with_optional_char_arg (se, expr, 1, 3);
11298 5879 : break;
11299 :
11300 1116 : case GFC_ISYM_FINDLOC:
11301 1116 : gfc_conv_intrinsic_findloc (se, expr);
11302 1116 : break;
11303 :
11304 2935 : case GFC_ISYM_MINLOC:
11305 2935 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11306 2935 : break;
11307 :
11308 2439 : case GFC_ISYM_MAXLOC:
11309 2439 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11310 2439 : break;
11311 :
11312 6873 : default:
11313 6873 : gfc_conv_intrinsic_funcall (se, expr);
11314 6873 : break;
11315 : }
11316 :
11317 : return;
11318 : }
11319 : }
11320 :
11321 250592 : switch (expr->value.function.isym->id)
11322 : {
11323 0 : case GFC_ISYM_NONE:
11324 0 : gcc_unreachable ();
11325 :
11326 541 : case GFC_ISYM_REPEAT:
11327 541 : gfc_conv_intrinsic_repeat (se, expr);
11328 541 : break;
11329 :
11330 580 : case GFC_ISYM_TRIM:
11331 580 : gfc_conv_intrinsic_trim (se, expr);
11332 580 : break;
11333 :
11334 42 : case GFC_ISYM_SC_KIND:
11335 42 : gfc_conv_intrinsic_sc_kind (se, expr);
11336 42 : break;
11337 :
11338 45 : case GFC_ISYM_SI_KIND:
11339 45 : gfc_conv_intrinsic_si_kind (se, expr);
11340 45 : break;
11341 :
11342 6 : case GFC_ISYM_SL_KIND:
11343 6 : gfc_conv_intrinsic_sl_kind (se, expr);
11344 6 : break;
11345 :
11346 82 : case GFC_ISYM_SR_KIND:
11347 82 : gfc_conv_intrinsic_sr_kind (se, expr);
11348 82 : break;
11349 :
11350 228 : case GFC_ISYM_EXPONENT:
11351 228 : gfc_conv_intrinsic_exponent (se, expr);
11352 228 : break;
11353 :
11354 316 : case GFC_ISYM_SCAN:
11355 316 : kind = expr->value.function.actual->expr->ts.kind;
11356 316 : if (kind == 1)
11357 250 : fndecl = gfor_fndecl_string_scan;
11358 66 : else if (kind == 4)
11359 66 : fndecl = gfor_fndecl_string_scan_char4;
11360 : else
11361 0 : gcc_unreachable ();
11362 :
11363 316 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11364 316 : break;
11365 :
11366 94 : case GFC_ISYM_VERIFY:
11367 94 : kind = expr->value.function.actual->expr->ts.kind;
11368 94 : if (kind == 1)
11369 70 : fndecl = gfor_fndecl_string_verify;
11370 24 : else if (kind == 4)
11371 24 : fndecl = gfor_fndecl_string_verify_char4;
11372 : else
11373 0 : gcc_unreachable ();
11374 :
11375 94 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11376 94 : break;
11377 :
11378 7534 : case GFC_ISYM_ALLOCATED:
11379 7534 : gfc_conv_allocated (se, expr);
11380 7534 : break;
11381 :
11382 9743 : case GFC_ISYM_ASSOCIATED:
11383 9743 : gfc_conv_associated(se, expr);
11384 9743 : break;
11385 :
11386 409 : case GFC_ISYM_SAME_TYPE_AS:
11387 409 : gfc_conv_same_type_as (se, expr);
11388 409 : break;
11389 :
11390 8028 : case GFC_ISYM_ABS:
11391 8028 : gfc_conv_intrinsic_abs (se, expr);
11392 8028 : break;
11393 :
11394 345 : case GFC_ISYM_ADJUSTL:
11395 345 : if (expr->ts.kind == 1)
11396 291 : fndecl = gfor_fndecl_adjustl;
11397 54 : else if (expr->ts.kind == 4)
11398 54 : fndecl = gfor_fndecl_adjustl_char4;
11399 : else
11400 0 : gcc_unreachable ();
11401 :
11402 345 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11403 345 : break;
11404 :
11405 123 : case GFC_ISYM_ADJUSTR:
11406 123 : if (expr->ts.kind == 1)
11407 68 : fndecl = gfor_fndecl_adjustr;
11408 55 : else if (expr->ts.kind == 4)
11409 55 : fndecl = gfor_fndecl_adjustr_char4;
11410 : else
11411 0 : gcc_unreachable ();
11412 :
11413 123 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
11414 123 : break;
11415 :
11416 440 : case GFC_ISYM_AIMAG:
11417 440 : gfc_conv_intrinsic_imagpart (se, expr);
11418 440 : break;
11419 :
11420 146 : case GFC_ISYM_AINT:
11421 146 : gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
11422 146 : break;
11423 :
11424 432 : case GFC_ISYM_ALL:
11425 432 : gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
11426 432 : break;
11427 :
11428 74 : case GFC_ISYM_ANINT:
11429 74 : gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
11430 74 : break;
11431 :
11432 90 : case GFC_ISYM_AND:
11433 90 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11434 90 : break;
11435 :
11436 38733 : case GFC_ISYM_ANY:
11437 38733 : gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
11438 38733 : break;
11439 :
11440 270 : case GFC_ISYM_ACOSD:
11441 270 : case GFC_ISYM_ASIND:
11442 270 : case GFC_ISYM_ATAND:
11443 270 : gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
11444 270 : break;
11445 :
11446 102 : case GFC_ISYM_COTAN:
11447 102 : gfc_conv_intrinsic_cotan (se, expr);
11448 102 : break;
11449 :
11450 108 : case GFC_ISYM_COTAND:
11451 108 : gfc_conv_intrinsic_cotand (se, expr);
11452 108 : break;
11453 :
11454 138 : case GFC_ISYM_ATAN2D:
11455 138 : gfc_conv_intrinsic_atan2d (se, expr);
11456 138 : break;
11457 :
11458 145 : case GFC_ISYM_BTEST:
11459 145 : gfc_conv_intrinsic_btest (se, expr);
11460 145 : break;
11461 :
11462 54 : case GFC_ISYM_BGE:
11463 54 : gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
11464 54 : break;
11465 :
11466 54 : case GFC_ISYM_BGT:
11467 54 : gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
11468 54 : break;
11469 :
11470 54 : case GFC_ISYM_BLE:
11471 54 : gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
11472 54 : break;
11473 :
11474 54 : case GFC_ISYM_BLT:
11475 54 : gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
11476 54 : break;
11477 :
11478 9949 : case GFC_ISYM_C_ASSOCIATED:
11479 9949 : case GFC_ISYM_C_FUNLOC:
11480 9949 : case GFC_ISYM_C_LOC:
11481 9949 : case GFC_ISYM_F_C_STRING:
11482 9949 : conv_isocbinding_function (se, expr);
11483 9949 : break;
11484 :
11485 2020 : case GFC_ISYM_ACHAR:
11486 2020 : case GFC_ISYM_CHAR:
11487 2020 : gfc_conv_intrinsic_char (se, expr);
11488 2020 : break;
11489 :
11490 41281 : case GFC_ISYM_CONVERSION:
11491 41281 : case GFC_ISYM_DBLE:
11492 41281 : case GFC_ISYM_DFLOAT:
11493 41281 : case GFC_ISYM_FLOAT:
11494 41281 : case GFC_ISYM_LOGICAL:
11495 41281 : case GFC_ISYM_REAL:
11496 41281 : case GFC_ISYM_REALPART:
11497 41281 : case GFC_ISYM_SNGL:
11498 41281 : gfc_conv_intrinsic_conversion (se, expr);
11499 41281 : break;
11500 :
11501 : /* Integer conversions are handled separately to make sure we get the
11502 : correct rounding mode. */
11503 2836 : case GFC_ISYM_INT:
11504 2836 : case GFC_ISYM_INT2:
11505 2836 : case GFC_ISYM_INT8:
11506 2836 : case GFC_ISYM_LONG:
11507 2836 : case GFC_ISYM_UINT:
11508 2836 : gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
11509 2836 : break;
11510 :
11511 162 : case GFC_ISYM_NINT:
11512 162 : gfc_conv_intrinsic_int (se, expr, RND_ROUND);
11513 162 : break;
11514 :
11515 16 : case GFC_ISYM_CEILING:
11516 16 : gfc_conv_intrinsic_int (se, expr, RND_CEIL);
11517 16 : break;
11518 :
11519 116 : case GFC_ISYM_FLOOR:
11520 116 : gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
11521 116 : break;
11522 :
11523 3403 : case GFC_ISYM_MOD:
11524 3403 : gfc_conv_intrinsic_mod (se, expr, 0);
11525 3403 : break;
11526 :
11527 442 : case GFC_ISYM_MODULO:
11528 442 : gfc_conv_intrinsic_mod (se, expr, 1);
11529 442 : break;
11530 :
11531 1006 : case GFC_ISYM_CAF_GET:
11532 1006 : gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL);
11533 1006 : break;
11534 :
11535 243 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
11536 243 : gfc_conv_intrinsic_caf_is_present_remote (se, expr);
11537 243 : break;
11538 :
11539 491 : case GFC_ISYM_CMPLX:
11540 491 : gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
11541 491 : break;
11542 :
11543 10 : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
11544 10 : gfc_conv_intrinsic_iargc (se, expr);
11545 10 : break;
11546 :
11547 6 : case GFC_ISYM_COMPLEX:
11548 6 : gfc_conv_intrinsic_cmplx (se, expr, 1);
11549 6 : break;
11550 :
11551 257 : case GFC_ISYM_CONJG:
11552 257 : gfc_conv_intrinsic_conjg (se, expr);
11553 257 : break;
11554 :
11555 16 : case GFC_ISYM_COSHAPE:
11556 16 : conv_intrinsic_cobound (se, expr);
11557 16 : break;
11558 :
11559 143 : case GFC_ISYM_COUNT:
11560 143 : gfc_conv_intrinsic_count (se, expr);
11561 143 : break;
11562 :
11563 0 : case GFC_ISYM_CTIME:
11564 0 : gfc_conv_intrinsic_ctime (se, expr);
11565 0 : break;
11566 :
11567 96 : case GFC_ISYM_DIM:
11568 96 : gfc_conv_intrinsic_dim (se, expr);
11569 96 : break;
11570 :
11571 113 : case GFC_ISYM_DOT_PRODUCT:
11572 113 : gfc_conv_intrinsic_dot_product (se, expr);
11573 113 : break;
11574 :
11575 13 : case GFC_ISYM_DPROD:
11576 13 : gfc_conv_intrinsic_dprod (se, expr);
11577 13 : break;
11578 :
11579 66 : case GFC_ISYM_DSHIFTL:
11580 66 : gfc_conv_intrinsic_dshift (se, expr, true);
11581 66 : break;
11582 :
11583 66 : case GFC_ISYM_DSHIFTR:
11584 66 : gfc_conv_intrinsic_dshift (se, expr, false);
11585 66 : break;
11586 :
11587 0 : case GFC_ISYM_FDATE:
11588 0 : gfc_conv_intrinsic_fdate (se, expr);
11589 0 : break;
11590 :
11591 60 : case GFC_ISYM_FRACTION:
11592 60 : gfc_conv_intrinsic_fraction (se, expr);
11593 60 : break;
11594 :
11595 24 : case GFC_ISYM_IALL:
11596 24 : gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
11597 24 : break;
11598 :
11599 606 : case GFC_ISYM_IAND:
11600 606 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
11601 606 : break;
11602 :
11603 12 : case GFC_ISYM_IANY:
11604 12 : gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
11605 12 : break;
11606 :
11607 168 : case GFC_ISYM_IBCLR:
11608 168 : gfc_conv_intrinsic_singlebitop (se, expr, 0);
11609 168 : break;
11610 :
11611 27 : case GFC_ISYM_IBITS:
11612 27 : gfc_conv_intrinsic_ibits (se, expr);
11613 27 : break;
11614 :
11615 138 : case GFC_ISYM_IBSET:
11616 138 : gfc_conv_intrinsic_singlebitop (se, expr, 1);
11617 138 : break;
11618 :
11619 2033 : case GFC_ISYM_IACHAR:
11620 2033 : case GFC_ISYM_ICHAR:
11621 : /* We assume ASCII character sequence. */
11622 2033 : gfc_conv_intrinsic_ichar (se, expr);
11623 2033 : break;
11624 :
11625 2 : case GFC_ISYM_IARGC:
11626 2 : gfc_conv_intrinsic_iargc (se, expr);
11627 2 : break;
11628 :
11629 694 : case GFC_ISYM_IEOR:
11630 694 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11631 694 : break;
11632 :
11633 341 : case GFC_ISYM_INDEX:
11634 341 : kind = expr->value.function.actual->expr->ts.kind;
11635 341 : if (kind == 1)
11636 275 : fndecl = gfor_fndecl_string_index;
11637 66 : else if (kind == 4)
11638 66 : fndecl = gfor_fndecl_string_index_char4;
11639 : else
11640 0 : gcc_unreachable ();
11641 :
11642 341 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
11643 341 : break;
11644 :
11645 495 : case GFC_ISYM_IOR:
11646 495 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11647 495 : break;
11648 :
11649 12 : case GFC_ISYM_IPARITY:
11650 12 : gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
11651 12 : break;
11652 :
11653 6 : case GFC_ISYM_IS_IOSTAT_END:
11654 6 : gfc_conv_has_intvalue (se, expr, LIBERROR_END);
11655 6 : break;
11656 :
11657 18 : case GFC_ISYM_IS_IOSTAT_EOR:
11658 18 : gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
11659 18 : break;
11660 :
11661 748 : case GFC_ISYM_IS_CONTIGUOUS:
11662 748 : gfc_conv_intrinsic_is_contiguous (se, expr);
11663 748 : break;
11664 :
11665 432 : case GFC_ISYM_ISNAN:
11666 432 : gfc_conv_intrinsic_isnan (se, expr);
11667 432 : break;
11668 :
11669 8 : case GFC_ISYM_KILL:
11670 8 : conv_intrinsic_kill (se, expr);
11671 8 : break;
11672 :
11673 90 : case GFC_ISYM_LSHIFT:
11674 90 : gfc_conv_intrinsic_shift (se, expr, false, false);
11675 90 : break;
11676 :
11677 24 : case GFC_ISYM_RSHIFT:
11678 24 : gfc_conv_intrinsic_shift (se, expr, true, true);
11679 24 : break;
11680 :
11681 78 : case GFC_ISYM_SHIFTA:
11682 78 : gfc_conv_intrinsic_shift (se, expr, true, true);
11683 78 : break;
11684 :
11685 234 : case GFC_ISYM_SHIFTL:
11686 234 : gfc_conv_intrinsic_shift (se, expr, false, false);
11687 234 : break;
11688 :
11689 66 : case GFC_ISYM_SHIFTR:
11690 66 : gfc_conv_intrinsic_shift (se, expr, true, false);
11691 66 : break;
11692 :
11693 318 : case GFC_ISYM_ISHFT:
11694 318 : gfc_conv_intrinsic_ishft (se, expr);
11695 318 : break;
11696 :
11697 658 : case GFC_ISYM_ISHFTC:
11698 658 : gfc_conv_intrinsic_ishftc (se, expr);
11699 658 : break;
11700 :
11701 270 : case GFC_ISYM_LEADZ:
11702 270 : gfc_conv_intrinsic_leadz (se, expr);
11703 270 : break;
11704 :
11705 282 : case GFC_ISYM_TRAILZ:
11706 282 : gfc_conv_intrinsic_trailz (se, expr);
11707 282 : break;
11708 :
11709 103 : case GFC_ISYM_POPCNT:
11710 103 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
11711 103 : break;
11712 :
11713 31 : case GFC_ISYM_POPPAR:
11714 31 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
11715 31 : break;
11716 :
11717 5589 : case GFC_ISYM_LBOUND:
11718 5589 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
11719 5589 : break;
11720 :
11721 237 : case GFC_ISYM_LCOBOUND:
11722 237 : conv_intrinsic_cobound (se, expr);
11723 237 : break;
11724 :
11725 774 : case GFC_ISYM_TRANSPOSE:
11726 : /* The scalarizer has already been set up for reversed dimension access
11727 : order ; now we just get the argument value normally. */
11728 774 : gfc_conv_expr (se, expr->value.function.actual->expr);
11729 774 : break;
11730 :
11731 5946 : case GFC_ISYM_LEN:
11732 5946 : gfc_conv_intrinsic_len (se, expr);
11733 5946 : break;
11734 :
11735 2340 : case GFC_ISYM_LEN_TRIM:
11736 2340 : gfc_conv_intrinsic_len_trim (se, expr);
11737 2340 : break;
11738 :
11739 18 : case GFC_ISYM_LGE:
11740 18 : gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
11741 18 : break;
11742 :
11743 36 : case GFC_ISYM_LGT:
11744 36 : gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
11745 36 : break;
11746 :
11747 18 : case GFC_ISYM_LLE:
11748 18 : gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
11749 18 : break;
11750 :
11751 27 : case GFC_ISYM_LLT:
11752 27 : gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
11753 27 : break;
11754 :
11755 16 : case GFC_ISYM_MALLOC:
11756 16 : gfc_conv_intrinsic_malloc (se, expr);
11757 16 : break;
11758 :
11759 32 : case GFC_ISYM_MASKL:
11760 32 : gfc_conv_intrinsic_mask (se, expr, 1);
11761 32 : break;
11762 :
11763 32 : case GFC_ISYM_MASKR:
11764 32 : gfc_conv_intrinsic_mask (se, expr, 0);
11765 32 : break;
11766 :
11767 1051 : case GFC_ISYM_MAX:
11768 1051 : if (expr->ts.type == BT_CHARACTER)
11769 138 : gfc_conv_intrinsic_minmax_char (se, expr, 1);
11770 : else
11771 913 : gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
11772 : break;
11773 :
11774 6348 : case GFC_ISYM_MAXLOC:
11775 6348 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11776 6348 : break;
11777 :
11778 216 : case GFC_ISYM_FINDLOC:
11779 216 : gfc_conv_intrinsic_findloc (se, expr);
11780 216 : break;
11781 :
11782 1101 : case GFC_ISYM_MAXVAL:
11783 1101 : gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
11784 1101 : break;
11785 :
11786 953 : case GFC_ISYM_MERGE:
11787 953 : gfc_conv_intrinsic_merge (se, expr);
11788 953 : break;
11789 :
11790 42 : case GFC_ISYM_MERGE_BITS:
11791 42 : gfc_conv_intrinsic_merge_bits (se, expr);
11792 42 : break;
11793 :
11794 598 : case GFC_ISYM_MIN:
11795 598 : if (expr->ts.type == BT_CHARACTER)
11796 144 : gfc_conv_intrinsic_minmax_char (se, expr, -1);
11797 : else
11798 454 : gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
11799 : break;
11800 :
11801 7176 : case GFC_ISYM_MINLOC:
11802 7176 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11803 7176 : break;
11804 :
11805 1316 : case GFC_ISYM_MINVAL:
11806 1316 : gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
11807 1316 : break;
11808 :
11809 1595 : case GFC_ISYM_NEAREST:
11810 1595 : gfc_conv_intrinsic_nearest (se, expr);
11811 1595 : break;
11812 :
11813 68 : case GFC_ISYM_NORM2:
11814 68 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
11815 68 : break;
11816 :
11817 230 : case GFC_ISYM_NOT:
11818 230 : gfc_conv_intrinsic_not (se, expr);
11819 230 : break;
11820 :
11821 12 : case GFC_ISYM_OR:
11822 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11823 12 : break;
11824 :
11825 468 : case GFC_ISYM_OUT_OF_RANGE:
11826 468 : gfc_conv_intrinsic_out_of_range (se, expr);
11827 468 : break;
11828 :
11829 36 : case GFC_ISYM_PARITY:
11830 36 : gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
11831 36 : break;
11832 :
11833 5202 : case GFC_ISYM_PRESENT:
11834 5202 : gfc_conv_intrinsic_present (se, expr);
11835 5202 : break;
11836 :
11837 358 : case GFC_ISYM_PRODUCT:
11838 358 : gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
11839 358 : break;
11840 :
11841 13376 : case GFC_ISYM_RANK:
11842 13376 : gfc_conv_intrinsic_rank (se, expr);
11843 13376 : break;
11844 :
11845 48 : case GFC_ISYM_RRSPACING:
11846 48 : gfc_conv_intrinsic_rrspacing (se, expr);
11847 48 : break;
11848 :
11849 262 : case GFC_ISYM_SET_EXPONENT:
11850 262 : gfc_conv_intrinsic_set_exponent (se, expr);
11851 262 : break;
11852 :
11853 72 : case GFC_ISYM_SCALE:
11854 72 : gfc_conv_intrinsic_scale (se, expr);
11855 72 : break;
11856 :
11857 5012 : case GFC_ISYM_SHAPE:
11858 5012 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
11859 5012 : break;
11860 :
11861 423 : case GFC_ISYM_SIGN:
11862 423 : gfc_conv_intrinsic_sign (se, expr);
11863 423 : break;
11864 :
11865 15667 : case GFC_ISYM_SIZE:
11866 15667 : gfc_conv_intrinsic_size (se, expr);
11867 15667 : break;
11868 :
11869 1309 : case GFC_ISYM_SIZEOF:
11870 1309 : case GFC_ISYM_C_SIZEOF:
11871 1309 : gfc_conv_intrinsic_sizeof (se, expr);
11872 1309 : break;
11873 :
11874 865 : case GFC_ISYM_STORAGE_SIZE:
11875 865 : gfc_conv_intrinsic_storage_size (se, expr);
11876 865 : break;
11877 :
11878 70 : case GFC_ISYM_SPACING:
11879 70 : gfc_conv_intrinsic_spacing (se, expr);
11880 70 : break;
11881 :
11882 2429 : case GFC_ISYM_STRIDE:
11883 2429 : conv_intrinsic_stride (se, expr);
11884 2429 : break;
11885 :
11886 2017 : case GFC_ISYM_SUM:
11887 2017 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
11888 2017 : break;
11889 :
11890 49 : case GFC_ISYM_TEAM_NUMBER:
11891 49 : conv_intrinsic_team_number (se, expr);
11892 49 : break;
11893 :
11894 4272 : case GFC_ISYM_TRANSFER:
11895 4272 : if (se->ss && se->ss->info->useflags)
11896 : /* Access the previously obtained result. */
11897 281 : gfc_conv_tmp_array_ref (se);
11898 : else
11899 3991 : gfc_conv_intrinsic_transfer (se, expr);
11900 : break;
11901 :
11902 0 : case GFC_ISYM_TTYNAM:
11903 0 : gfc_conv_intrinsic_ttynam (se, expr);
11904 0 : break;
11905 :
11906 5748 : case GFC_ISYM_UBOUND:
11907 5748 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
11908 5748 : break;
11909 :
11910 272 : case GFC_ISYM_UCOBOUND:
11911 272 : conv_intrinsic_cobound (se, expr);
11912 272 : break;
11913 :
11914 18 : case GFC_ISYM_XOR:
11915 18 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11916 18 : break;
11917 :
11918 8993 : case GFC_ISYM_LOC:
11919 8993 : gfc_conv_intrinsic_loc (se, expr);
11920 8993 : break;
11921 :
11922 1578 : case GFC_ISYM_THIS_IMAGE:
11923 : /* For num_images() == 1, handle as LCOBOUND. */
11924 1578 : if (expr->value.function.actual->expr
11925 542 : && flag_coarray == GFC_FCOARRAY_SINGLE)
11926 212 : conv_intrinsic_cobound (se, expr);
11927 : else
11928 1366 : trans_this_image (se, expr);
11929 : break;
11930 :
11931 257 : case GFC_ISYM_IMAGE_INDEX:
11932 257 : trans_image_index (se, expr);
11933 257 : break;
11934 :
11935 32 : case GFC_ISYM_IMAGE_STATUS:
11936 32 : conv_intrinsic_image_status (se, expr);
11937 32 : break;
11938 :
11939 890 : case GFC_ISYM_NUM_IMAGES:
11940 890 : trans_num_images (se, expr);
11941 890 : break;
11942 :
11943 1430 : case GFC_ISYM_ACCESS:
11944 1430 : case GFC_ISYM_CHDIR:
11945 1430 : case GFC_ISYM_CHMOD:
11946 1430 : case GFC_ISYM_DTIME:
11947 1430 : case GFC_ISYM_ETIME:
11948 1430 : case GFC_ISYM_EXTENDS_TYPE_OF:
11949 1430 : case GFC_ISYM_FGET:
11950 1430 : case GFC_ISYM_FGETC:
11951 1430 : case GFC_ISYM_FNUM:
11952 1430 : case GFC_ISYM_FPUT:
11953 1430 : case GFC_ISYM_FPUTC:
11954 1430 : case GFC_ISYM_FSTAT:
11955 1430 : case GFC_ISYM_FTELL:
11956 1430 : case GFC_ISYM_GETCWD:
11957 1430 : case GFC_ISYM_GETGID:
11958 1430 : case GFC_ISYM_GETPID:
11959 1430 : case GFC_ISYM_GETUID:
11960 1430 : case GFC_ISYM_GET_TEAM:
11961 1430 : case GFC_ISYM_HOSTNM:
11962 1430 : case GFC_ISYM_IERRNO:
11963 1430 : case GFC_ISYM_IRAND:
11964 1430 : case GFC_ISYM_ISATTY:
11965 1430 : case GFC_ISYM_JN2:
11966 1430 : case GFC_ISYM_LINK:
11967 1430 : case GFC_ISYM_LSTAT:
11968 1430 : case GFC_ISYM_MATMUL:
11969 1430 : case GFC_ISYM_MCLOCK:
11970 1430 : case GFC_ISYM_MCLOCK8:
11971 1430 : case GFC_ISYM_RAND:
11972 1430 : case GFC_ISYM_REDUCE:
11973 1430 : case GFC_ISYM_RENAME:
11974 1430 : case GFC_ISYM_SECOND:
11975 1430 : case GFC_ISYM_SECNDS:
11976 1430 : case GFC_ISYM_SIGNAL:
11977 1430 : case GFC_ISYM_STAT:
11978 1430 : case GFC_ISYM_SYMLNK:
11979 1430 : case GFC_ISYM_SYSTEM:
11980 1430 : case GFC_ISYM_TIME:
11981 1430 : case GFC_ISYM_TIME8:
11982 1430 : case GFC_ISYM_UMASK:
11983 1430 : case GFC_ISYM_UNLINK:
11984 1430 : case GFC_ISYM_YN2:
11985 1430 : gfc_conv_intrinsic_funcall (se, expr);
11986 1430 : break;
11987 :
11988 0 : case GFC_ISYM_EOSHIFT:
11989 0 : case GFC_ISYM_PACK:
11990 0 : case GFC_ISYM_RESHAPE:
11991 : /* For those, expr->rank should always be >0 and thus the if above the
11992 : switch should have matched. */
11993 0 : gcc_unreachable ();
11994 3929 : break;
11995 :
11996 3929 : default:
11997 3929 : gfc_conv_intrinsic_lib_function (se, expr);
11998 3929 : break;
11999 : }
12000 : }
12001 :
12002 :
12003 : static gfc_ss *
12004 1674 : walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
12005 : {
12006 1674 : gfc_ss *arg_ss, *tmp_ss;
12007 1674 : gfc_actual_arglist *arg;
12008 :
12009 1674 : arg = expr->value.function.actual;
12010 :
12011 1674 : gcc_assert (arg->expr);
12012 :
12013 1674 : arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
12014 1674 : gcc_assert (arg_ss != gfc_ss_terminator);
12015 :
12016 : for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
12017 : {
12018 1785 : if (tmp_ss->info->type != GFC_SS_SCALAR
12019 : && tmp_ss->info->type != GFC_SS_REFERENCE)
12020 : {
12021 1742 : gcc_assert (tmp_ss->dimen == 2);
12022 :
12023 : /* We just invert dimensions. */
12024 1742 : std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
12025 : }
12026 :
12027 : /* Stop when tmp_ss points to the last valid element of the chain... */
12028 1785 : if (tmp_ss->next == gfc_ss_terminator)
12029 : break;
12030 : }
12031 :
12032 : /* ... so that we can attach the rest of the chain to it. */
12033 1674 : tmp_ss->next = ss;
12034 :
12035 1674 : return arg_ss;
12036 : }
12037 :
12038 :
12039 : /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
12040 : This has the side effect of reversing the nested list, so there is no
12041 : need to call gfc_reverse_ss on it (the given list is assumed not to be
12042 : reversed yet). */
12043 :
12044 : static gfc_ss *
12045 3371 : nest_loop_dimension (gfc_ss *ss, int dim)
12046 : {
12047 3371 : int ss_dim, i;
12048 3371 : gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
12049 3371 : gfc_loopinfo *new_loop;
12050 :
12051 3371 : gcc_assert (ss != gfc_ss_terminator);
12052 :
12053 8118 : for (; ss != gfc_ss_terminator; ss = ss->next)
12054 : {
12055 4747 : new_ss = gfc_get_ss ();
12056 4747 : new_ss->next = prev_ss;
12057 4747 : new_ss->parent = ss;
12058 4747 : new_ss->info = ss->info;
12059 4747 : new_ss->info->refcount++;
12060 4747 : if (ss->dimen != 0)
12061 : {
12062 4684 : gcc_assert (ss->info->type != GFC_SS_SCALAR
12063 : && ss->info->type != GFC_SS_REFERENCE);
12064 :
12065 4684 : new_ss->dimen = 1;
12066 4684 : new_ss->dim[0] = ss->dim[dim];
12067 :
12068 4684 : gcc_assert (dim < ss->dimen);
12069 :
12070 4684 : ss_dim = --ss->dimen;
12071 10430 : for (i = dim; i < ss_dim; i++)
12072 5746 : ss->dim[i] = ss->dim[i + 1];
12073 :
12074 4684 : ss->dim[ss_dim] = 0;
12075 : }
12076 4747 : prev_ss = new_ss;
12077 :
12078 4747 : if (ss->nested_ss)
12079 : {
12080 81 : ss->nested_ss->parent = new_ss;
12081 81 : new_ss->nested_ss = ss->nested_ss;
12082 : }
12083 4747 : ss->nested_ss = new_ss;
12084 : }
12085 :
12086 3371 : new_loop = gfc_get_loopinfo ();
12087 3371 : gfc_init_loopinfo (new_loop);
12088 :
12089 3371 : gcc_assert (prev_ss != NULL);
12090 3371 : gcc_assert (prev_ss != gfc_ss_terminator);
12091 3371 : gfc_add_ss_to_loop (new_loop, prev_ss);
12092 3371 : return new_ss->parent;
12093 : }
12094 :
12095 :
12096 : /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
12097 : is to be inlined. */
12098 :
12099 : static gfc_ss *
12100 575 : walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
12101 : {
12102 575 : gfc_ss *tmp_ss, *tail, *array_ss;
12103 575 : gfc_actual_arglist *arg1, *arg2, *arg3;
12104 575 : int sum_dim;
12105 575 : bool scalar_mask = false;
12106 :
12107 : /* The rank of the result will be determined later. */
12108 575 : arg1 = expr->value.function.actual;
12109 575 : arg2 = arg1->next;
12110 575 : arg3 = arg2->next;
12111 575 : gcc_assert (arg3 != NULL);
12112 :
12113 575 : if (expr->rank == 0)
12114 : return ss;
12115 :
12116 575 : tmp_ss = gfc_ss_terminator;
12117 :
12118 575 : if (arg3->expr)
12119 : {
12120 118 : gfc_ss *mask_ss;
12121 :
12122 118 : mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
12123 118 : if (mask_ss == tmp_ss)
12124 34 : scalar_mask = 1;
12125 :
12126 : tmp_ss = mask_ss;
12127 : }
12128 :
12129 575 : array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
12130 575 : gcc_assert (array_ss != tmp_ss);
12131 :
12132 : /* Odd thing: If the mask is scalar, it is used by the frontend after
12133 : the array (to make an if around the nested loop). Thus it shall
12134 : be after array_ss once the gfc_ss list is reversed. */
12135 575 : if (scalar_mask)
12136 34 : tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
12137 : else
12138 : tmp_ss = array_ss;
12139 :
12140 : /* "Hide" the dimension on which we will sum in the first arg's scalarization
12141 : chain. */
12142 575 : sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
12143 575 : tail = nest_loop_dimension (tmp_ss, sum_dim);
12144 575 : tail->next = ss;
12145 :
12146 575 : return tmp_ss;
12147 : }
12148 :
12149 :
12150 : /* Create the gfc_ss list for the arguments to MINLOC or MAXLOC when the
12151 : function is to be inlined. */
12152 :
12153 : static gfc_ss *
12154 6085 : walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
12155 : {
12156 6085 : if (expr->rank == 0)
12157 : return ss;
12158 :
12159 6085 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12160 6085 : gfc_actual_arglist *dim_arg = array_arg->next;
12161 6085 : gfc_actual_arglist *mask_arg = dim_arg->next;
12162 6085 : gfc_actual_arglist *kind_arg = mask_arg->next;
12163 6085 : gfc_actual_arglist *back_arg = kind_arg->next;
12164 :
12165 6085 : gfc_expr *array = array_arg->expr;
12166 6085 : gfc_expr *dim = dim_arg->expr;
12167 6085 : gfc_expr *mask = mask_arg->expr;
12168 6085 : gfc_expr *back = back_arg->expr;
12169 :
12170 6085 : if (dim == nullptr)
12171 3289 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12172 :
12173 2796 : gfc_ss *tmp_ss = gfc_ss_terminator;
12174 :
12175 2796 : bool scalar_mask = false;
12176 2796 : if (mask)
12177 : {
12178 1866 : gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
12179 1866 : if (mask_ss == tmp_ss)
12180 : scalar_mask = true;
12181 1174 : else if (maybe_absent_optional_variable (mask))
12182 20 : mask_ss->info->can_be_null_ref = true;
12183 :
12184 : tmp_ss = mask_ss;
12185 : }
12186 :
12187 2796 : gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
12188 2796 : gcc_assert (array_ss != tmp_ss);
12189 :
12190 2796 : tmp_ss = array_ss;
12191 :
12192 : /* Move the dimension on which we will sum to a separate nested scalarization
12193 : chain, "hiding" that dimension from the outer scalarization. */
12194 2796 : int dim_val = mpz_get_si (dim->value.integer);
12195 2796 : gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
12196 :
12197 2796 : if (back && array->rank > 1)
12198 : {
12199 : /* If there are nested scalarization loops, include BACK in the
12200 : scalarization chains to avoid evaluating it multiple times in a loop.
12201 : Otherwise, prefer to handle it outside of scalarization. */
12202 2796 : gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
12203 2796 : back_ss->info->type = GFC_SS_REFERENCE;
12204 2796 : if (maybe_absent_optional_variable (back))
12205 16 : back_ss->info->can_be_null_ref = true;
12206 :
12207 2796 : tail->next = back_ss;
12208 2796 : }
12209 : else
12210 0 : tail->next = ss;
12211 :
12212 2796 : if (scalar_mask)
12213 : {
12214 692 : tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
12215 : /* MASK can be a forwarded optional argument, so make the necessary setup
12216 : to avoid the scalarizer generating any unguarded pointer dereference in
12217 : that case. */
12218 692 : tmp_ss->info->type = GFC_SS_REFERENCE;
12219 692 : if (maybe_absent_optional_variable (mask))
12220 4 : tmp_ss->info->can_be_null_ref = true;
12221 : }
12222 :
12223 : return tmp_ss;
12224 : }
12225 :
12226 :
12227 : static gfc_ss *
12228 8334 : walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
12229 : {
12230 :
12231 8334 : switch (expr->value.function.isym->id)
12232 : {
12233 575 : case GFC_ISYM_PRODUCT:
12234 575 : case GFC_ISYM_SUM:
12235 575 : return walk_inline_intrinsic_arith (ss, expr);
12236 :
12237 1674 : case GFC_ISYM_TRANSPOSE:
12238 1674 : return walk_inline_intrinsic_transpose (ss, expr);
12239 :
12240 6085 : case GFC_ISYM_MAXLOC:
12241 6085 : case GFC_ISYM_MINLOC:
12242 6085 : return walk_inline_intrinsic_minmaxloc (ss, expr);
12243 :
12244 0 : default:
12245 0 : gcc_unreachable ();
12246 : }
12247 : gcc_unreachable ();
12248 : }
12249 :
12250 :
12251 : /* This generates code to execute before entering the scalarization loop.
12252 : Currently does nothing. */
12253 :
12254 : void
12255 11676 : gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
12256 : {
12257 11676 : switch (ss->info->expr->value.function.isym->id)
12258 : {
12259 11676 : case GFC_ISYM_UBOUND:
12260 11676 : case GFC_ISYM_LBOUND:
12261 11676 : case GFC_ISYM_COSHAPE:
12262 11676 : case GFC_ISYM_UCOBOUND:
12263 11676 : case GFC_ISYM_LCOBOUND:
12264 11676 : case GFC_ISYM_MAXLOC:
12265 11676 : case GFC_ISYM_MINLOC:
12266 11676 : case GFC_ISYM_THIS_IMAGE:
12267 11676 : case GFC_ISYM_SHAPE:
12268 11676 : break;
12269 :
12270 0 : default:
12271 0 : gcc_unreachable ();
12272 : }
12273 11676 : }
12274 :
12275 :
12276 : /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
12277 : one parameter are expanded into code inside the scalarization loop. */
12278 :
12279 : static gfc_ss *
12280 10256 : gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
12281 : {
12282 10256 : if (expr->value.function.actual->expr->ts.type == BT_CLASS)
12283 453 : gfc_add_class_array_ref (expr->value.function.actual->expr);
12284 :
12285 : /* The two argument version returns a scalar. */
12286 10256 : if (expr->value.function.isym->id != GFC_ISYM_SHAPE
12287 3593 : && expr->value.function.isym->id != GFC_ISYM_COSHAPE
12288 3577 : && expr->value.function.actual->next->expr)
12289 : return ss;
12290 :
12291 10256 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
12292 : }
12293 :
12294 :
12295 : /* Walk an intrinsic array libcall. */
12296 :
12297 : static gfc_ss *
12298 14518 : gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
12299 : {
12300 14518 : gcc_assert (expr->rank > 0);
12301 14518 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
12302 : }
12303 :
12304 :
12305 : /* Return whether the function call expression EXPR will be expanded
12306 : inline by gfc_conv_intrinsic_function. */
12307 :
12308 : bool
12309 305897 : gfc_inline_intrinsic_function_p (gfc_expr *expr)
12310 : {
12311 305897 : gfc_actual_arglist *args, *dim_arg, *mask_arg;
12312 305897 : gfc_expr *maskexpr;
12313 :
12314 305897 : gfc_intrinsic_sym *isym = expr->value.function.isym;
12315 305897 : if (!isym)
12316 : return false;
12317 :
12318 305855 : switch (isym->id)
12319 : {
12320 5116 : case GFC_ISYM_PRODUCT:
12321 5116 : case GFC_ISYM_SUM:
12322 : /* Disable inline expansion if code size matters. */
12323 5116 : if (optimize_size)
12324 : return false;
12325 :
12326 4259 : args = expr->value.function.actual;
12327 4259 : dim_arg = args->next;
12328 :
12329 : /* We need to be able to subset the SUM argument at compile-time. */
12330 4259 : if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
12331 : return false;
12332 :
12333 : /* FIXME: If MASK is optional for a more than two-dimensional
12334 : argument, the scalarizer gets confused if the mask is
12335 : absent. See PR 82995. For now, fall back to the library
12336 : function. */
12337 :
12338 3647 : mask_arg = dim_arg->next;
12339 3647 : maskexpr = mask_arg->expr;
12340 :
12341 3647 : if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
12342 276 : && maskexpr->symtree->n.sym->attr.dummy
12343 48 : && maskexpr->symtree->n.sym->attr.optional)
12344 : return false;
12345 :
12346 : return true;
12347 :
12348 : case GFC_ISYM_TRANSPOSE:
12349 : return true;
12350 :
12351 57188 : case GFC_ISYM_MINLOC:
12352 57188 : case GFC_ISYM_MAXLOC:
12353 57188 : {
12354 57188 : if ((isym->id == GFC_ISYM_MINLOC
12355 30521 : && (flag_inline_intrinsics
12356 30521 : & GFC_FLAG_INLINE_INTRINSIC_MINLOC) == 0)
12357 46611 : || (isym->id == GFC_ISYM_MAXLOC
12358 26667 : && (flag_inline_intrinsics
12359 26667 : & GFC_FLAG_INLINE_INTRINSIC_MAXLOC) == 0))
12360 : return false;
12361 :
12362 37638 : gfc_actual_arglist *array_arg = expr->value.function.actual;
12363 37638 : gfc_actual_arglist *dim_arg = array_arg->next;
12364 :
12365 37638 : gfc_expr *array = array_arg->expr;
12366 37638 : gfc_expr *dim = dim_arg->expr;
12367 :
12368 37638 : if (!(array->ts.type == BT_INTEGER
12369 : || array->ts.type == BT_REAL))
12370 : return false;
12371 :
12372 34658 : if (array->rank == 1)
12373 : return true;
12374 :
12375 20711 : if (dim != nullptr
12376 13372 : && dim->expr_type != EXPR_CONSTANT)
12377 : return false;
12378 :
12379 : return true;
12380 : }
12381 :
12382 : default:
12383 : return false;
12384 : }
12385 : }
12386 :
12387 :
12388 : /* Returns nonzero if the specified intrinsic function call maps directly to
12389 : an external library call. Should only be used for functions that return
12390 : arrays. */
12391 :
12392 : int
12393 88281 : gfc_is_intrinsic_libcall (gfc_expr * expr)
12394 : {
12395 88281 : gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
12396 88281 : gcc_assert (expr->rank > 0);
12397 :
12398 88281 : if (gfc_inline_intrinsic_function_p (expr))
12399 : return 0;
12400 :
12401 73664 : switch (expr->value.function.isym->id)
12402 : {
12403 : case GFC_ISYM_ALL:
12404 : case GFC_ISYM_ANY:
12405 : case GFC_ISYM_COUNT:
12406 : case GFC_ISYM_FINDLOC:
12407 : case GFC_ISYM_JN2:
12408 : case GFC_ISYM_IANY:
12409 : case GFC_ISYM_IALL:
12410 : case GFC_ISYM_IPARITY:
12411 : case GFC_ISYM_MATMUL:
12412 : case GFC_ISYM_MAXLOC:
12413 : case GFC_ISYM_MAXVAL:
12414 : case GFC_ISYM_MINLOC:
12415 : case GFC_ISYM_MINVAL:
12416 : case GFC_ISYM_NORM2:
12417 : case GFC_ISYM_PARITY:
12418 : case GFC_ISYM_PRODUCT:
12419 : case GFC_ISYM_SUM:
12420 : case GFC_ISYM_SPREAD:
12421 : case GFC_ISYM_YN2:
12422 : /* Ignore absent optional parameters. */
12423 : return 1;
12424 :
12425 15873 : case GFC_ISYM_CSHIFT:
12426 15873 : case GFC_ISYM_EOSHIFT:
12427 15873 : case GFC_ISYM_GET_TEAM:
12428 15873 : case GFC_ISYM_FAILED_IMAGES:
12429 15873 : case GFC_ISYM_STOPPED_IMAGES:
12430 15873 : case GFC_ISYM_PACK:
12431 15873 : case GFC_ISYM_REDUCE:
12432 15873 : case GFC_ISYM_RESHAPE:
12433 15873 : case GFC_ISYM_UNPACK:
12434 : /* Pass absent optional parameters. */
12435 15873 : return 2;
12436 :
12437 : default:
12438 : return 0;
12439 : }
12440 : }
12441 :
12442 : /* Walk an intrinsic function. */
12443 : gfc_ss *
12444 56044 : gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
12445 : gfc_intrinsic_sym * isym)
12446 : {
12447 56044 : gcc_assert (isym);
12448 :
12449 56044 : if (isym->elemental)
12450 18438 : return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
12451 : expr->value.function.isym,
12452 18438 : GFC_SS_SCALAR);
12453 :
12454 37606 : if (expr->rank == 0 && expr->corank == 0)
12455 : return ss;
12456 :
12457 33108 : if (gfc_inline_intrinsic_function_p (expr))
12458 8334 : return walk_inline_intrinsic_function (ss, expr);
12459 :
12460 24774 : if (expr->rank != 0 && gfc_is_intrinsic_libcall (expr))
12461 13529 : return gfc_walk_intrinsic_libfunc (ss, expr);
12462 :
12463 : /* Special cases. */
12464 11245 : switch (isym->id)
12465 : {
12466 10256 : case GFC_ISYM_COSHAPE:
12467 10256 : case GFC_ISYM_LBOUND:
12468 10256 : case GFC_ISYM_LCOBOUND:
12469 10256 : case GFC_ISYM_UBOUND:
12470 10256 : case GFC_ISYM_UCOBOUND:
12471 10256 : case GFC_ISYM_THIS_IMAGE:
12472 10256 : case GFC_ISYM_SHAPE:
12473 10256 : return gfc_walk_intrinsic_bound (ss, expr);
12474 :
12475 989 : case GFC_ISYM_TRANSFER:
12476 989 : case GFC_ISYM_CAF_GET:
12477 989 : return gfc_walk_intrinsic_libfunc (ss, expr);
12478 :
12479 0 : default:
12480 : /* This probably meant someone forgot to add an intrinsic to the above
12481 : list(s) when they implemented it, or something's gone horribly
12482 : wrong. */
12483 0 : gcc_unreachable ();
12484 : }
12485 : }
12486 :
12487 : static tree
12488 100 : conv_co_collective (gfc_code *code)
12489 : {
12490 100 : gfc_se argse;
12491 100 : stmtblock_t block, post_block;
12492 100 : tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
12493 100 : gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
12494 :
12495 100 : gfc_start_block (&block);
12496 100 : gfc_init_block (&post_block);
12497 :
12498 100 : if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
12499 : {
12500 17 : opr_expr = code->ext.actual->next->expr;
12501 17 : image_idx_expr = code->ext.actual->next->next->expr;
12502 17 : stat_expr = code->ext.actual->next->next->next->expr;
12503 17 : errmsg_expr = code->ext.actual->next->next->next->next->expr;
12504 : }
12505 : else
12506 : {
12507 83 : opr_expr = NULL;
12508 83 : image_idx_expr = code->ext.actual->next->expr;
12509 83 : stat_expr = code->ext.actual->next->next->expr;
12510 83 : errmsg_expr = code->ext.actual->next->next->next->expr;
12511 : }
12512 :
12513 : /* stat. */
12514 100 : if (stat_expr)
12515 : {
12516 68 : gfc_init_se (&argse, NULL);
12517 68 : gfc_conv_expr (&argse, stat_expr);
12518 68 : gfc_add_block_to_block (&block, &argse.pre);
12519 68 : gfc_add_block_to_block (&post_block, &argse.post);
12520 68 : stat = argse.expr;
12521 68 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
12522 38 : stat = gfc_build_addr_expr (NULL_TREE, stat);
12523 : }
12524 32 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
12525 : stat = NULL_TREE;
12526 : else
12527 22 : stat = null_pointer_node;
12528 :
12529 : /* Early exit for GFC_FCOARRAY_SINGLE. */
12530 100 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
12531 : {
12532 40 : if (stat != NULL_TREE)
12533 : {
12534 : /* For optional stats, check the pointer is valid before zero'ing. */
12535 30 : if (gfc_expr_attr (stat_expr).optional)
12536 : {
12537 12 : tree tmp;
12538 12 : stmtblock_t ass_block;
12539 12 : gfc_start_block (&ass_block);
12540 12 : gfc_add_modify (&ass_block, stat,
12541 12 : fold_convert (TREE_TYPE (stat),
12542 : integer_zero_node));
12543 12 : tmp = fold_build2 (NE_EXPR, logical_type_node,
12544 : gfc_build_addr_expr (NULL_TREE, stat),
12545 : null_pointer_node);
12546 12 : tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
12547 : gfc_finish_block (&ass_block),
12548 : build_empty_stmt (input_location));
12549 12 : gfc_add_expr_to_block (&block, tmp);
12550 : }
12551 : else
12552 18 : gfc_add_modify (&block, stat,
12553 18 : fold_convert (TREE_TYPE (stat), integer_zero_node));
12554 : }
12555 40 : return gfc_finish_block (&block);
12556 : }
12557 :
12558 5 : gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
12559 60 : ? code->ext.actual->expr->ts.u.derived : NULL;
12560 :
12561 : /* Handle the array. */
12562 60 : gfc_init_se (&argse, NULL);
12563 60 : if (!derived || !derived->attr.alloc_comp
12564 1 : || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
12565 : {
12566 59 : if (code->ext.actual->expr->rank == 0)
12567 : {
12568 28 : symbol_attribute attr;
12569 28 : gfc_clear_attr (&attr);
12570 28 : gfc_init_se (&argse, NULL);
12571 28 : gfc_conv_expr (&argse, code->ext.actual->expr);
12572 28 : gfc_add_block_to_block (&block, &argse.pre);
12573 28 : gfc_add_block_to_block (&post_block, &argse.post);
12574 28 : array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
12575 28 : array = gfc_build_addr_expr (NULL_TREE, array);
12576 : }
12577 : else
12578 : {
12579 31 : argse.want_pointer = 1;
12580 31 : gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
12581 31 : array = argse.expr;
12582 : }
12583 : }
12584 :
12585 60 : gfc_add_block_to_block (&block, &argse.pre);
12586 60 : gfc_add_block_to_block (&post_block, &argse.post);
12587 :
12588 60 : if (code->ext.actual->expr->ts.type == BT_CHARACTER)
12589 15 : strlen = argse.string_length;
12590 : else
12591 45 : strlen = integer_zero_node;
12592 :
12593 : /* image_index. */
12594 60 : if (image_idx_expr)
12595 : {
12596 37 : gfc_init_se (&argse, NULL);
12597 37 : gfc_conv_expr (&argse, image_idx_expr);
12598 37 : gfc_add_block_to_block (&block, &argse.pre);
12599 37 : gfc_add_block_to_block (&post_block, &argse.post);
12600 37 : image_index = fold_convert (integer_type_node, argse.expr);
12601 : }
12602 : else
12603 23 : image_index = integer_zero_node;
12604 :
12605 : /* errmsg. */
12606 60 : if (errmsg_expr)
12607 : {
12608 25 : gfc_init_se (&argse, NULL);
12609 25 : gfc_conv_expr (&argse, errmsg_expr);
12610 25 : gfc_add_block_to_block (&block, &argse.pre);
12611 25 : gfc_add_block_to_block (&post_block, &argse.post);
12612 25 : errmsg = argse.expr;
12613 25 : errmsg_len = fold_convert (size_type_node, argse.string_length);
12614 : }
12615 : else
12616 : {
12617 35 : errmsg = null_pointer_node;
12618 35 : errmsg_len = build_zero_cst (size_type_node);
12619 : }
12620 :
12621 : /* Generate the function call. */
12622 60 : switch (code->resolved_isym->id)
12623 : {
12624 22 : case GFC_ISYM_CO_BROADCAST:
12625 22 : fndecl = gfor_fndecl_co_broadcast;
12626 22 : break;
12627 8 : case GFC_ISYM_CO_MAX:
12628 8 : fndecl = gfor_fndecl_co_max;
12629 8 : break;
12630 6 : case GFC_ISYM_CO_MIN:
12631 6 : fndecl = gfor_fndecl_co_min;
12632 6 : break;
12633 12 : case GFC_ISYM_CO_REDUCE:
12634 12 : fndecl = gfor_fndecl_co_reduce;
12635 12 : break;
12636 12 : case GFC_ISYM_CO_SUM:
12637 12 : fndecl = gfor_fndecl_co_sum;
12638 12 : break;
12639 0 : default:
12640 0 : gcc_unreachable ();
12641 : }
12642 :
12643 60 : if (derived && derived->attr.alloc_comp
12644 1 : && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12645 : /* The derived type has the attribute 'alloc_comp'. */
12646 : {
12647 2 : tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
12648 1 : code->ext.actual->expr->rank,
12649 : image_index, stat, errmsg, errmsg_len);
12650 1 : gfc_add_expr_to_block (&block, tmp);
12651 1 : }
12652 : else
12653 : {
12654 59 : if (code->resolved_isym->id == GFC_ISYM_CO_SUM
12655 47 : || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
12656 33 : fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
12657 : image_index, stat, errmsg, errmsg_len);
12658 26 : else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
12659 14 : fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
12660 : image_index, stat, errmsg,
12661 : strlen, errmsg_len);
12662 : else
12663 : {
12664 12 : tree opr, opr_flags;
12665 :
12666 : // FIXME: Handle TS29113's bind(C) strings with descriptor.
12667 12 : int opr_flag_int;
12668 12 : if (gfc_is_proc_ptr_comp (opr_expr))
12669 : {
12670 0 : gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
12671 0 : opr_flag_int = sym->attr.dimension
12672 0 : || (sym->ts.type == BT_CHARACTER
12673 0 : && !sym->attr.is_bind_c)
12674 0 : ? GFC_CAF_BYREF : 0;
12675 0 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12676 0 : && !sym->attr.is_bind_c
12677 0 : ? GFC_CAF_HIDDENLEN : 0;
12678 0 : opr_flag_int |= sym->formal->sym->attr.value
12679 0 : ? GFC_CAF_ARG_VALUE : 0;
12680 : }
12681 : else
12682 : {
12683 12 : opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
12684 12 : ? GFC_CAF_BYREF : 0;
12685 24 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
12686 0 : && !opr_expr->symtree->n.sym->attr.is_bind_c
12687 12 : ? GFC_CAF_HIDDENLEN : 0;
12688 12 : opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
12689 12 : ? GFC_CAF_ARG_VALUE : 0;
12690 : }
12691 12 : opr_flags = build_int_cst (integer_type_node, opr_flag_int);
12692 12 : gfc_conv_expr (&argse, opr_expr);
12693 12 : opr = argse.expr;
12694 12 : fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
12695 : opr_flags, image_index, stat, errmsg,
12696 : strlen, errmsg_len);
12697 : }
12698 : }
12699 :
12700 60 : gfc_add_expr_to_block (&block, fndecl);
12701 60 : gfc_add_block_to_block (&block, &post_block);
12702 :
12703 60 : return gfc_finish_block (&block);
12704 : }
12705 :
12706 :
12707 : static tree
12708 95 : conv_intrinsic_atomic_op (gfc_code *code)
12709 : {
12710 95 : gfc_se argse;
12711 95 : tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
12712 95 : stmtblock_t block, post_block;
12713 95 : gfc_expr *atom_expr = code->ext.actual->expr;
12714 95 : gfc_expr *stat_expr;
12715 95 : built_in_function fn;
12716 :
12717 95 : if (atom_expr->expr_type == EXPR_FUNCTION
12718 0 : && atom_expr->value.function.isym
12719 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12720 0 : atom_expr = atom_expr->value.function.actual->expr;
12721 :
12722 95 : gfc_start_block (&block);
12723 95 : gfc_init_block (&post_block);
12724 :
12725 95 : gfc_init_se (&argse, NULL);
12726 95 : argse.want_pointer = 1;
12727 95 : gfc_conv_expr (&argse, atom_expr);
12728 95 : gfc_add_block_to_block (&block, &argse.pre);
12729 95 : gfc_add_block_to_block (&post_block, &argse.post);
12730 95 : atom = argse.expr;
12731 :
12732 95 : gfc_init_se (&argse, NULL);
12733 95 : if (flag_coarray == GFC_FCOARRAY_LIB
12734 56 : && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
12735 54 : argse.want_pointer = 1;
12736 95 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12737 95 : gfc_add_block_to_block (&block, &argse.pre);
12738 95 : gfc_add_block_to_block (&post_block, &argse.post);
12739 95 : value = argse.expr;
12740 :
12741 95 : switch (code->resolved_isym->id)
12742 : {
12743 58 : case GFC_ISYM_ATOMIC_ADD:
12744 58 : case GFC_ISYM_ATOMIC_AND:
12745 58 : case GFC_ISYM_ATOMIC_DEF:
12746 58 : case GFC_ISYM_ATOMIC_OR:
12747 58 : case GFC_ISYM_ATOMIC_XOR:
12748 58 : stat_expr = code->ext.actual->next->next->expr;
12749 58 : if (flag_coarray == GFC_FCOARRAY_LIB)
12750 34 : old = null_pointer_node;
12751 : break;
12752 37 : default:
12753 37 : gfc_init_se (&argse, NULL);
12754 37 : if (flag_coarray == GFC_FCOARRAY_LIB)
12755 22 : argse.want_pointer = 1;
12756 37 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12757 37 : gfc_add_block_to_block (&block, &argse.pre);
12758 37 : gfc_add_block_to_block (&post_block, &argse.post);
12759 37 : old = argse.expr;
12760 37 : stat_expr = code->ext.actual->next->next->next->expr;
12761 : }
12762 :
12763 : /* STAT= */
12764 95 : if (stat_expr != NULL)
12765 : {
12766 82 : gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
12767 82 : gfc_init_se (&argse, NULL);
12768 82 : if (flag_coarray == GFC_FCOARRAY_LIB)
12769 48 : argse.want_pointer = 1;
12770 82 : gfc_conv_expr_val (&argse, stat_expr);
12771 82 : gfc_add_block_to_block (&block, &argse.pre);
12772 82 : gfc_add_block_to_block (&post_block, &argse.post);
12773 82 : stat = argse.expr;
12774 : }
12775 13 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12776 8 : stat = null_pointer_node;
12777 :
12778 95 : if (flag_coarray == GFC_FCOARRAY_LIB)
12779 : {
12780 56 : tree image_index, caf_decl, offset, token;
12781 56 : int op;
12782 :
12783 56 : switch (code->resolved_isym->id)
12784 : {
12785 : case GFC_ISYM_ATOMIC_ADD:
12786 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12787 : op = (int) GFC_CAF_ATOMIC_ADD;
12788 : break;
12789 12 : case GFC_ISYM_ATOMIC_AND:
12790 12 : case GFC_ISYM_ATOMIC_FETCH_AND:
12791 12 : op = (int) GFC_CAF_ATOMIC_AND;
12792 12 : break;
12793 12 : case GFC_ISYM_ATOMIC_OR:
12794 12 : case GFC_ISYM_ATOMIC_FETCH_OR:
12795 12 : op = (int) GFC_CAF_ATOMIC_OR;
12796 12 : break;
12797 12 : case GFC_ISYM_ATOMIC_XOR:
12798 12 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12799 12 : op = (int) GFC_CAF_ATOMIC_XOR;
12800 12 : break;
12801 11 : case GFC_ISYM_ATOMIC_DEF:
12802 11 : op = 0; /* Unused. */
12803 11 : break;
12804 0 : default:
12805 0 : gcc_unreachable ();
12806 : }
12807 :
12808 56 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12809 56 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12810 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12811 :
12812 56 : if (gfc_is_coindexed (atom_expr))
12813 48 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12814 : else
12815 8 : image_index = integer_zero_node;
12816 :
12817 : /* Ensure VALUE names addressable storage: taking the address of a
12818 : constant is invalid in C, and scalars need a temporary as well. */
12819 56 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12820 : {
12821 42 : tree elem
12822 42 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value);
12823 42 : elem = gfc_trans_force_lval (&block, elem);
12824 42 : value = gfc_build_addr_expr (NULL_TREE, elem);
12825 : }
12826 14 : else if (TREE_CODE (value) == ADDR_EXPR
12827 14 : && TREE_CONSTANT (TREE_OPERAND (value, 0)))
12828 : {
12829 0 : tree elem
12830 0 : = fold_convert (TREE_TYPE (TREE_TYPE (atom)),
12831 : build_fold_indirect_ref (value));
12832 0 : elem = gfc_trans_force_lval (&block, elem);
12833 0 : value = gfc_build_addr_expr (NULL_TREE, elem);
12834 : }
12835 :
12836 56 : gfc_init_se (&argse, NULL);
12837 56 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12838 : atom_expr);
12839 :
12840 56 : gfc_add_block_to_block (&block, &argse.pre);
12841 56 : if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
12842 11 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
12843 : token, offset, image_index, value, stat,
12844 : build_int_cst (integer_type_node,
12845 11 : (int) atom_expr->ts.type),
12846 : build_int_cst (integer_type_node,
12847 11 : (int) atom_expr->ts.kind));
12848 : else
12849 45 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
12850 45 : build_int_cst (integer_type_node, op),
12851 : token, offset, image_index, value, old, stat,
12852 : build_int_cst (integer_type_node,
12853 45 : (int) atom_expr->ts.type),
12854 : build_int_cst (integer_type_node,
12855 45 : (int) atom_expr->ts.kind));
12856 :
12857 56 : gfc_add_expr_to_block (&block, tmp);
12858 56 : gfc_add_block_to_block (&block, &argse.post);
12859 56 : gfc_add_block_to_block (&block, &post_block);
12860 56 : return gfc_finish_block (&block);
12861 : }
12862 :
12863 :
12864 39 : switch (code->resolved_isym->id)
12865 : {
12866 : case GFC_ISYM_ATOMIC_ADD:
12867 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12868 : fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
12869 : break;
12870 8 : case GFC_ISYM_ATOMIC_AND:
12871 8 : case GFC_ISYM_ATOMIC_FETCH_AND:
12872 8 : fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12873 8 : break;
12874 9 : case GFC_ISYM_ATOMIC_DEF:
12875 9 : fn = BUILT_IN_ATOMIC_STORE_N;
12876 9 : break;
12877 8 : case GFC_ISYM_ATOMIC_OR:
12878 8 : case GFC_ISYM_ATOMIC_FETCH_OR:
12879 8 : fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12880 8 : break;
12881 8 : case GFC_ISYM_ATOMIC_XOR:
12882 8 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12883 8 : fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12884 8 : break;
12885 0 : default:
12886 0 : gcc_unreachable ();
12887 : }
12888 :
12889 39 : tmp = TREE_TYPE (TREE_TYPE (atom));
12890 78 : fn = (built_in_function) ((int) fn
12891 39 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12892 39 : + 1);
12893 39 : tree itype = TREE_TYPE (TREE_TYPE (atom));
12894 39 : tmp = builtin_decl_explicit (fn);
12895 :
12896 39 : switch (code->resolved_isym->id)
12897 : {
12898 24 : case GFC_ISYM_ATOMIC_ADD:
12899 24 : case GFC_ISYM_ATOMIC_AND:
12900 24 : case GFC_ISYM_ATOMIC_DEF:
12901 24 : case GFC_ISYM_ATOMIC_OR:
12902 24 : case GFC_ISYM_ATOMIC_XOR:
12903 24 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12904 : fold_convert (itype, value),
12905 : build_int_cst (integer_type_node, MEMMODEL_RELAXED));
12906 24 : gfc_add_expr_to_block (&block, tmp);
12907 24 : break;
12908 15 : default:
12909 15 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12910 : fold_convert (itype, value),
12911 : build_int_cst (integer_type_node, MEMMODEL_RELAXED));
12912 15 : gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12913 15 : break;
12914 : }
12915 :
12916 39 : if (stat != NULL_TREE)
12917 34 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12918 39 : gfc_add_block_to_block (&block, &post_block);
12919 39 : return gfc_finish_block (&block);
12920 : }
12921 :
12922 :
12923 : static tree
12924 176 : conv_intrinsic_atomic_ref (gfc_code *code)
12925 : {
12926 176 : gfc_se argse;
12927 176 : tree tmp, atom, value, stat = NULL_TREE;
12928 176 : stmtblock_t block, post_block;
12929 176 : built_in_function fn;
12930 176 : gfc_expr *atom_expr = code->ext.actual->next->expr;
12931 :
12932 176 : if (atom_expr->expr_type == EXPR_FUNCTION
12933 0 : && atom_expr->value.function.isym
12934 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12935 0 : atom_expr = atom_expr->value.function.actual->expr;
12936 :
12937 176 : gfc_start_block (&block);
12938 176 : gfc_init_block (&post_block);
12939 176 : gfc_init_se (&argse, NULL);
12940 176 : argse.want_pointer = 1;
12941 176 : gfc_conv_expr (&argse, atom_expr);
12942 176 : gfc_add_block_to_block (&block, &argse.pre);
12943 176 : gfc_add_block_to_block (&post_block, &argse.post);
12944 176 : atom = argse.expr;
12945 :
12946 176 : gfc_init_se (&argse, NULL);
12947 176 : if (flag_coarray == GFC_FCOARRAY_LIB
12948 115 : && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12949 109 : argse.want_pointer = 1;
12950 176 : gfc_conv_expr (&argse, code->ext.actual->expr);
12951 176 : gfc_add_block_to_block (&block, &argse.pre);
12952 176 : gfc_add_block_to_block (&post_block, &argse.post);
12953 176 : value = argse.expr;
12954 :
12955 : /* STAT= */
12956 176 : if (code->ext.actual->next->next->expr != NULL)
12957 : {
12958 164 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12959 : == EXPR_VARIABLE);
12960 164 : gfc_init_se (&argse, NULL);
12961 164 : if (flag_coarray == GFC_FCOARRAY_LIB)
12962 108 : argse.want_pointer = 1;
12963 164 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12964 164 : gfc_add_block_to_block (&block, &argse.pre);
12965 164 : gfc_add_block_to_block (&post_block, &argse.post);
12966 164 : stat = argse.expr;
12967 : }
12968 12 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12969 7 : stat = null_pointer_node;
12970 :
12971 176 : if (flag_coarray == GFC_FCOARRAY_LIB)
12972 : {
12973 115 : tree image_index, caf_decl, offset, token;
12974 115 : tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12975 :
12976 115 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12977 115 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12978 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12979 :
12980 115 : if (gfc_is_coindexed (atom_expr))
12981 103 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12982 : else
12983 12 : image_index = integer_zero_node;
12984 :
12985 115 : gfc_init_se (&argse, NULL);
12986 115 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12987 : atom_expr);
12988 115 : gfc_add_block_to_block (&block, &argse.pre);
12989 :
12990 : /* Different type, need type conversion. */
12991 115 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12992 : {
12993 6 : vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12994 6 : orig_value = value;
12995 6 : value = gfc_build_addr_expr (NULL_TREE, vardecl);
12996 : }
12997 :
12998 115 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12999 : token, offset, image_index, value, stat,
13000 : build_int_cst (integer_type_node,
13001 115 : (int) atom_expr->ts.type),
13002 : build_int_cst (integer_type_node,
13003 115 : (int) atom_expr->ts.kind));
13004 115 : gfc_add_expr_to_block (&block, tmp);
13005 115 : if (vardecl != NULL_TREE)
13006 6 : gfc_add_modify (&block, orig_value,
13007 6 : fold_convert (TREE_TYPE (orig_value), vardecl));
13008 115 : gfc_add_block_to_block (&block, &argse.post);
13009 115 : gfc_add_block_to_block (&block, &post_block);
13010 115 : return gfc_finish_block (&block);
13011 : }
13012 :
13013 61 : tmp = TREE_TYPE (TREE_TYPE (atom));
13014 122 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
13015 61 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
13016 61 : + 1);
13017 61 : tmp = builtin_decl_explicit (fn);
13018 61 : tmp = build_call_expr_loc (input_location, tmp, 2, atom,
13019 : build_int_cst (integer_type_node,
13020 : MEMMODEL_RELAXED));
13021 61 : gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
13022 :
13023 61 : if (stat != NULL_TREE)
13024 56 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
13025 61 : gfc_add_block_to_block (&block, &post_block);
13026 61 : return gfc_finish_block (&block);
13027 : }
13028 :
13029 :
13030 : static tree
13031 14 : conv_intrinsic_atomic_cas (gfc_code *code)
13032 : {
13033 14 : gfc_se argse;
13034 14 : tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
13035 14 : stmtblock_t block, post_block;
13036 14 : built_in_function fn;
13037 14 : gfc_expr *atom_expr = code->ext.actual->expr;
13038 :
13039 14 : if (atom_expr->expr_type == EXPR_FUNCTION
13040 0 : && atom_expr->value.function.isym
13041 0 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
13042 0 : atom_expr = atom_expr->value.function.actual->expr;
13043 :
13044 14 : gfc_init_block (&block);
13045 14 : gfc_init_block (&post_block);
13046 14 : gfc_init_se (&argse, NULL);
13047 14 : argse.want_pointer = 1;
13048 14 : gfc_conv_expr (&argse, atom_expr);
13049 14 : atom = argse.expr;
13050 :
13051 14 : gfc_init_se (&argse, NULL);
13052 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13053 8 : argse.want_pointer = 1;
13054 14 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
13055 14 : gfc_add_block_to_block (&block, &argse.pre);
13056 14 : gfc_add_block_to_block (&post_block, &argse.post);
13057 14 : old = argse.expr;
13058 :
13059 14 : gfc_init_se (&argse, NULL);
13060 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13061 8 : argse.want_pointer = 1;
13062 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
13063 14 : gfc_add_block_to_block (&block, &argse.pre);
13064 14 : gfc_add_block_to_block (&post_block, &argse.post);
13065 14 : comp = argse.expr;
13066 :
13067 14 : gfc_init_se (&argse, NULL);
13068 14 : if (flag_coarray == GFC_FCOARRAY_LIB
13069 8 : && code->ext.actual->next->next->next->expr->ts.kind
13070 8 : == atom_expr->ts.kind)
13071 8 : argse.want_pointer = 1;
13072 14 : gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
13073 14 : gfc_add_block_to_block (&block, &argse.pre);
13074 14 : gfc_add_block_to_block (&post_block, &argse.post);
13075 14 : new_val = argse.expr;
13076 :
13077 : /* STAT= */
13078 14 : if (code->ext.actual->next->next->next->next->expr != NULL)
13079 : {
13080 14 : gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
13081 : == EXPR_VARIABLE);
13082 14 : gfc_init_se (&argse, NULL);
13083 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13084 8 : argse.want_pointer = 1;
13085 14 : gfc_conv_expr_val (&argse,
13086 14 : code->ext.actual->next->next->next->next->expr);
13087 14 : gfc_add_block_to_block (&block, &argse.pre);
13088 14 : gfc_add_block_to_block (&post_block, &argse.post);
13089 14 : stat = argse.expr;
13090 : }
13091 0 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13092 0 : stat = null_pointer_node;
13093 :
13094 14 : if (flag_coarray == GFC_FCOARRAY_LIB)
13095 : {
13096 8 : tree image_index, caf_decl, offset, token;
13097 :
13098 8 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
13099 8 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
13100 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
13101 :
13102 8 : if (gfc_is_coindexed (atom_expr))
13103 8 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
13104 : else
13105 0 : image_index = integer_zero_node;
13106 :
13107 8 : if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
13108 : {
13109 0 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
13110 0 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
13111 0 : new_val = gfc_build_addr_expr (NULL_TREE, tmp);
13112 : }
13113 :
13114 8 : gfc_init_se (&argse, NULL);
13115 8 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
13116 : atom_expr);
13117 8 : gfc_add_block_to_block (&block, &argse.pre);
13118 :
13119 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
13120 : token, offset, image_index, old, comp, new_val,
13121 : stat, build_int_cst (integer_type_node,
13122 8 : (int) atom_expr->ts.type),
13123 : build_int_cst (integer_type_node,
13124 8 : (int) atom_expr->ts.kind));
13125 8 : gfc_add_expr_to_block (&block, tmp);
13126 8 : gfc_add_block_to_block (&block, &argse.post);
13127 8 : gfc_add_block_to_block (&block, &post_block);
13128 8 : return gfc_finish_block (&block);
13129 : }
13130 :
13131 6 : tmp = TREE_TYPE (TREE_TYPE (atom));
13132 12 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
13133 6 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
13134 6 : + 1);
13135 6 : tmp = builtin_decl_explicit (fn);
13136 :
13137 6 : gfc_add_modify (&block, old, comp);
13138 12 : tmp = build_call_expr_loc (input_location, tmp, 6, atom,
13139 : gfc_build_addr_expr (NULL, old),
13140 6 : fold_convert (TREE_TYPE (old), new_val),
13141 : boolean_false_node,
13142 : build_int_cst (integer_type_node, MEMMODEL_RELAXED),
13143 : build_int_cst (integer_type_node, MEMMODEL_RELAXED));
13144 6 : gfc_add_expr_to_block (&block, tmp);
13145 :
13146 6 : if (stat != NULL_TREE)
13147 6 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
13148 6 : gfc_add_block_to_block (&block, &post_block);
13149 6 : return gfc_finish_block (&block);
13150 : }
13151 :
13152 : static tree
13153 105 : conv_intrinsic_event_query (gfc_code *code)
13154 : {
13155 105 : gfc_se se, argse;
13156 105 : tree stat = NULL_TREE, stat2 = NULL_TREE;
13157 105 : tree count = NULL_TREE, count2 = NULL_TREE;
13158 :
13159 105 : gfc_expr *event_expr = code->ext.actual->expr;
13160 :
13161 105 : if (code->ext.actual->next->next->expr)
13162 : {
13163 18 : gcc_assert (code->ext.actual->next->next->expr->expr_type
13164 : == EXPR_VARIABLE);
13165 18 : gfc_init_se (&argse, NULL);
13166 18 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
13167 18 : stat = argse.expr;
13168 : }
13169 87 : else if (flag_coarray == GFC_FCOARRAY_LIB)
13170 58 : stat = null_pointer_node;
13171 :
13172 105 : if (code->ext.actual->next->expr)
13173 : {
13174 105 : gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
13175 105 : gfc_init_se (&argse, NULL);
13176 105 : gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
13177 105 : count = argse.expr;
13178 : }
13179 :
13180 105 : gfc_start_block (&se.pre);
13181 105 : if (flag_coarray == GFC_FCOARRAY_LIB)
13182 : {
13183 70 : tree tmp, token, image_index;
13184 70 : tree index = build_zero_cst (gfc_array_index_type);
13185 :
13186 70 : if (event_expr->expr_type == EXPR_FUNCTION
13187 0 : && event_expr->value.function.isym
13188 0 : && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
13189 0 : event_expr = event_expr->value.function.actual->expr;
13190 :
13191 70 : tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
13192 :
13193 70 : if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
13194 70 : || event_expr->symtree->n.sym->ts.u.derived->from_intmod
13195 : != INTMOD_ISO_FORTRAN_ENV
13196 70 : || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
13197 : != ISOFORTRAN_EVENT_TYPE)
13198 : {
13199 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
13200 : "yet supported", &event_expr->where);
13201 0 : return NULL_TREE;
13202 : }
13203 :
13204 70 : if (gfc_is_coindexed (event_expr))
13205 : {
13206 0 : gfc_error ("The event variable at %L shall not be coindexed",
13207 : &event_expr->where);
13208 0 : return NULL_TREE;
13209 : }
13210 :
13211 70 : image_index = integer_zero_node;
13212 :
13213 70 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
13214 : event_expr);
13215 :
13216 : /* For arrays, obtain the array index. */
13217 70 : if (gfc_expr_attr (event_expr).dimension)
13218 : {
13219 52 : tree desc, tmp, extent, lbound, ubound;
13220 52 : gfc_array_ref *ar, ar2;
13221 52 : int i;
13222 :
13223 : /* TODO: Extend this, once DT components are supported. */
13224 52 : ar = &event_expr->ref->u.ar;
13225 52 : ar2 = *ar;
13226 52 : memset (ar, '\0', sizeof (*ar));
13227 52 : ar->as = ar2.as;
13228 52 : ar->type = AR_FULL;
13229 :
13230 52 : gfc_init_se (&argse, NULL);
13231 52 : argse.descriptor_only = 1;
13232 52 : gfc_conv_expr_descriptor (&argse, event_expr);
13233 52 : gfc_add_block_to_block (&se.pre, &argse.pre);
13234 52 : desc = argse.expr;
13235 52 : *ar = ar2;
13236 :
13237 52 : extent = build_one_cst (gfc_array_index_type);
13238 156 : for (i = 0; i < ar->dimen; i++)
13239 : {
13240 52 : gfc_init_se (&argse, NULL);
13241 52 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
13242 52 : gfc_add_block_to_block (&argse.pre, &argse.pre);
13243 52 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
13244 52 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
13245 52 : TREE_TYPE (lbound), argse.expr, lbound);
13246 52 : tmp = fold_build2_loc (input_location, MULT_EXPR,
13247 52 : TREE_TYPE (tmp), extent, tmp);
13248 52 : index = fold_build2_loc (input_location, PLUS_EXPR,
13249 52 : TREE_TYPE (tmp), index, tmp);
13250 52 : if (i < ar->dimen - 1)
13251 : {
13252 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
13253 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
13254 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
13255 0 : TREE_TYPE (tmp), extent, tmp);
13256 : }
13257 : }
13258 : }
13259 :
13260 70 : if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
13261 : {
13262 0 : count2 = count;
13263 0 : count = gfc_create_var (integer_type_node, "count");
13264 : }
13265 :
13266 70 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
13267 : {
13268 0 : stat2 = stat;
13269 0 : stat = gfc_create_var (integer_type_node, "stat");
13270 : }
13271 :
13272 70 : index = fold_convert (size_type_node, index);
13273 140 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
13274 : token, index, image_index, count
13275 70 : ? gfc_build_addr_expr (NULL, count) : count,
13276 70 : stat != null_pointer_node
13277 12 : ? gfc_build_addr_expr (NULL, stat) : stat);
13278 70 : gfc_add_expr_to_block (&se.pre, tmp);
13279 :
13280 70 : if (count2 != NULL_TREE)
13281 0 : gfc_add_modify (&se.pre, count2,
13282 0 : fold_convert (TREE_TYPE (count2), count));
13283 :
13284 70 : if (stat2 != NULL_TREE)
13285 0 : gfc_add_modify (&se.pre, stat2,
13286 0 : fold_convert (TREE_TYPE (stat2), stat));
13287 :
13288 70 : return gfc_finish_block (&se.pre);
13289 : }
13290 :
13291 35 : gfc_init_se (&argse, NULL);
13292 35 : gfc_conv_expr_val (&argse, code->ext.actual->expr);
13293 35 : gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
13294 :
13295 35 : if (stat != NULL_TREE)
13296 6 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
13297 :
13298 35 : return gfc_finish_block (&se.pre);
13299 : }
13300 :
13301 :
13302 : /* This is a peculiar case because of the need to do dependency checking.
13303 : It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
13304 : a special case and this function called instead of
13305 : gfc_conv_procedure_call. */
13306 : void
13307 197 : gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
13308 : gfc_loopinfo *loop)
13309 : {
13310 197 : gfc_actual_arglist *actual;
13311 197 : gfc_se argse[5];
13312 197 : gfc_expr *arg[5];
13313 197 : gfc_ss *lss;
13314 197 : int n;
13315 :
13316 197 : tree from, frompos, len, to, topos;
13317 197 : tree lenmask, oldbits, newbits, bitsize;
13318 197 : tree type, utype, above, mask1, mask2;
13319 :
13320 197 : if (loop)
13321 67 : lss = loop->ss;
13322 : else
13323 130 : lss = gfc_ss_terminator;
13324 :
13325 197 : actual = actual_args;
13326 1182 : for (n = 0; n < 5; n++, actual = actual->next)
13327 : {
13328 985 : arg[n] = actual->expr;
13329 985 : gfc_init_se (&argse[n], NULL);
13330 :
13331 985 : if (lss != gfc_ss_terminator)
13332 : {
13333 335 : gfc_copy_loopinfo_to_se (&argse[n], loop);
13334 : /* Find the ss for the expression if it is there. */
13335 335 : argse[n].ss = lss;
13336 335 : gfc_mark_ss_chain_used (lss, 1);
13337 : }
13338 :
13339 985 : gfc_conv_expr (&argse[n], arg[n]);
13340 :
13341 985 : if (loop)
13342 335 : lss = argse[n].ss;
13343 : }
13344 :
13345 197 : from = argse[0].expr;
13346 197 : frompos = argse[1].expr;
13347 197 : len = argse[2].expr;
13348 197 : to = argse[3].expr;
13349 197 : topos = argse[4].expr;
13350 :
13351 : /* The type of the result (TO). */
13352 197 : type = TREE_TYPE (to);
13353 197 : bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
13354 :
13355 : /* Optionally generate code for runtime argument check. */
13356 197 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
13357 : {
13358 18 : tree nbits, below, ccond;
13359 18 : tree fp = fold_convert (long_integer_type_node, frompos);
13360 18 : tree ln = fold_convert (long_integer_type_node, len);
13361 18 : tree tp = fold_convert (long_integer_type_node, topos);
13362 18 : below = fold_build2_loc (input_location, LT_EXPR,
13363 : logical_type_node, frompos,
13364 18 : build_int_cst (TREE_TYPE (frompos), 0));
13365 18 : above = fold_build2_loc (input_location, GT_EXPR,
13366 : logical_type_node, frompos,
13367 18 : fold_convert (TREE_TYPE (frompos), bitsize));
13368 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13369 : logical_type_node, below, above);
13370 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13371 18 : &arg[1]->where,
13372 : "FROMPOS argument (%ld) out of range 0:%d "
13373 : "in intrinsic MVBITS", fp, bitsize);
13374 18 : below = fold_build2_loc (input_location, LT_EXPR,
13375 : logical_type_node, len,
13376 18 : build_int_cst (TREE_TYPE (len), 0));
13377 18 : above = fold_build2_loc (input_location, GT_EXPR,
13378 : logical_type_node, len,
13379 18 : fold_convert (TREE_TYPE (len), bitsize));
13380 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13381 : logical_type_node, below, above);
13382 18 : gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
13383 18 : &arg[2]->where,
13384 : "LEN argument (%ld) out of range 0:%d "
13385 : "in intrinsic MVBITS", ln, bitsize);
13386 18 : below = fold_build2_loc (input_location, LT_EXPR,
13387 : logical_type_node, topos,
13388 18 : build_int_cst (TREE_TYPE (topos), 0));
13389 18 : above = fold_build2_loc (input_location, GT_EXPR,
13390 : logical_type_node, topos,
13391 18 : fold_convert (TREE_TYPE (topos), bitsize));
13392 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
13393 : logical_type_node, below, above);
13394 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13395 18 : &arg[4]->where,
13396 : "TOPOS argument (%ld) out of range 0:%d "
13397 : "in intrinsic MVBITS", tp, bitsize);
13398 :
13399 : /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
13400 : integers. Additions below cannot overflow. */
13401 18 : nbits = fold_convert (long_integer_type_node, bitsize);
13402 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13403 : long_integer_type_node, fp, ln);
13404 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13405 : logical_type_node, above, nbits);
13406 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
13407 : &arg[1]->where,
13408 : "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13409 : "in intrinsic MVBITS", fp, ln, bitsize);
13410 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
13411 : long_integer_type_node, tp, ln);
13412 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
13413 : logical_type_node, above, nbits);
13414 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
13415 : &arg[4]->where,
13416 : "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
13417 : "in intrinsic MVBITS", tp, ln, bitsize);
13418 : }
13419 :
13420 1182 : for (n = 0; n < 5; n++)
13421 : {
13422 985 : gfc_add_block_to_block (&se->pre, &argse[n].pre);
13423 985 : gfc_add_block_to_block (&se->post, &argse[n].post);
13424 : }
13425 :
13426 : /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
13427 197 : above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
13428 197 : len, fold_convert (TREE_TYPE (len), bitsize));
13429 197 : mask1 = build_int_cst (type, -1);
13430 197 : mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13431 : build_int_cst (type, 1), len);
13432 197 : mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
13433 : mask2, build_int_cst (type, 1));
13434 197 : lenmask = fold_build3_loc (input_location, COND_EXPR, type,
13435 : above, mask1, mask2);
13436 :
13437 : /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
13438 : * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
13439 : * not strictly necessary; artificial bits from rshift will be masked. */
13440 197 : utype = unsigned_type_for (type);
13441 197 : newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
13442 : fold_convert (utype, from), frompos);
13443 197 : newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
13444 : fold_convert (type, newbits), lenmask);
13445 197 : newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13446 : newbits, topos);
13447 :
13448 : /* oldbits = TO & (~(lenmask << TOPOS)). */
13449 197 : oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
13450 : lenmask, topos);
13451 197 : oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
13452 197 : oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
13453 :
13454 : /* TO = newbits | oldbits. */
13455 197 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
13456 : oldbits, newbits);
13457 :
13458 : /* Return the assignment. */
13459 197 : se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
13460 : void_type_node, to, se->expr);
13461 197 : }
13462 :
13463 : /* Comes from trans-stmt.cc, but we don't want the whole header included. */
13464 : extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se,
13465 : tree *stat, tree *errmsg, tree *errmsg_len);
13466 :
13467 : static tree
13468 269 : conv_intrinsic_move_alloc (gfc_code *code)
13469 : {
13470 269 : stmtblock_t block;
13471 269 : gfc_expr *from_expr, *to_expr;
13472 269 : gfc_se from_se, to_se;
13473 269 : tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE;
13474 269 : bool coarray, from_is_class, from_is_scalar;
13475 269 : gfc_actual_arglist *arg = code->ext.actual;
13476 269 : sync_stat tmp_sync_stat = {nullptr, nullptr};
13477 :
13478 269 : gfc_start_block (&block);
13479 :
13480 269 : from_expr = arg->expr;
13481 269 : arg = arg->next;
13482 269 : to_expr = arg->expr;
13483 269 : arg = arg->next;
13484 :
13485 807 : while (arg)
13486 : {
13487 538 : if (arg->expr)
13488 : {
13489 0 : if (!strcmp ("stat", arg->name))
13490 0 : tmp_sync_stat.stat = arg->expr;
13491 0 : else if (!strcmp ("errmsg", arg->name))
13492 0 : tmp_sync_stat.errmsg = arg->expr;
13493 : }
13494 538 : arg = arg->next;
13495 : }
13496 :
13497 269 : gfc_init_se (&from_se, NULL);
13498 269 : gfc_init_se (&to_se, NULL);
13499 :
13500 269 : gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len);
13501 269 : if (stat != null_pointer_node)
13502 0 : fin_label = gfc_build_label_decl (NULL_TREE);
13503 :
13504 269 : gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS);
13505 269 : coarray = from_expr->corank != 0;
13506 :
13507 269 : from_is_class = from_expr->ts.type == BT_CLASS;
13508 269 : from_is_scalar = from_expr->rank == 0 && !coarray;
13509 269 : if (to_expr->ts.type == BT_CLASS || from_is_scalar)
13510 : {
13511 169 : from_se.want_pointer = 1;
13512 169 : if (from_is_scalar)
13513 121 : gfc_conv_expr (&from_se, from_expr);
13514 : else
13515 48 : gfc_conv_expr_descriptor (&from_se, from_expr);
13516 169 : if (from_is_class)
13517 64 : from_tree = gfc_class_data_get (from_se.expr);
13518 : else
13519 : {
13520 105 : gfc_symbol *vtab;
13521 105 : from_tree = from_se.expr;
13522 :
13523 105 : if (to_expr->ts.type == BT_CLASS)
13524 : {
13525 42 : vtab = gfc_find_vtab (&from_expr->ts);
13526 42 : gcc_assert (vtab);
13527 42 : from_se.expr = gfc_get_symbol_decl (vtab);
13528 : }
13529 : }
13530 169 : gfc_add_block_to_block (&block, &from_se.pre);
13531 :
13532 169 : to_se.want_pointer = 1;
13533 169 : if (to_expr->rank == 0)
13534 121 : gfc_conv_expr (&to_se, to_expr);
13535 : else
13536 48 : gfc_conv_expr_descriptor (&to_se, to_expr);
13537 169 : if (to_expr->ts.type == BT_CLASS)
13538 106 : to_tree = gfc_class_data_get (to_se.expr);
13539 : else
13540 63 : to_tree = to_se.expr;
13541 169 : gfc_add_block_to_block (&block, &to_se.pre);
13542 :
13543 : /* Deallocate "to". */
13544 169 : if (to_expr->rank == 0)
13545 : {
13546 121 : tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label,
13547 : true, to_expr, to_expr->ts,
13548 : NULL_TREE, false, true,
13549 : errmsg, errmsg_len);
13550 121 : gfc_add_expr_to_block (&block, tmp);
13551 : }
13552 :
13553 169 : if (from_is_scalar)
13554 : {
13555 : /* Assign (_data) pointers. */
13556 121 : gfc_add_modify_loc (input_location, &block, to_tree,
13557 121 : fold_convert (TREE_TYPE (to_tree), from_tree));
13558 :
13559 : /* Set "from" to NULL. */
13560 121 : gfc_add_modify_loc (input_location, &block, from_tree,
13561 121 : fold_convert (TREE_TYPE (from_tree),
13562 : null_pointer_node));
13563 :
13564 121 : gfc_add_block_to_block (&block, &from_se.post);
13565 : }
13566 169 : gfc_add_block_to_block (&block, &to_se.post);
13567 :
13568 : /* Set _vptr. */
13569 169 : if (to_expr->ts.type == BT_CLASS)
13570 : {
13571 106 : gfc_class_set_vptr (&block, to_se.expr, from_se.expr);
13572 106 : if (from_is_class)
13573 64 : gfc_reset_vptr (&block, from_expr);
13574 106 : if (UNLIMITED_POLY (to_expr))
13575 : {
13576 20 : tree to_len = gfc_class_len_get (to_se.class_container);
13577 20 : tmp = from_expr->ts.type == BT_CHARACTER && from_se.string_length
13578 20 : ? from_se.string_length
13579 : : size_zero_node;
13580 20 : gfc_add_modify_loc (input_location, &block, to_len,
13581 20 : fold_convert (TREE_TYPE (to_len), tmp));
13582 : }
13583 : }
13584 :
13585 169 : if (from_is_scalar)
13586 : {
13587 121 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13588 : {
13589 6 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13590 6 : fold_convert (TREE_TYPE (to_se.string_length),
13591 : from_se.string_length));
13592 6 : if (from_expr->ts.deferred)
13593 6 : gfc_add_modify_loc (
13594 : input_location, &block, from_se.string_length,
13595 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13596 : }
13597 121 : if (UNLIMITED_POLY (from_expr))
13598 2 : gfc_reset_len (&block, from_expr);
13599 :
13600 121 : return gfc_finish_block (&block);
13601 : }
13602 :
13603 48 : gfc_init_se (&to_se, NULL);
13604 48 : gfc_init_se (&from_se, NULL);
13605 : }
13606 :
13607 : /* Deallocate "to". */
13608 148 : if (from_expr->rank == 0)
13609 : {
13610 4 : to_se.want_coarray = 1;
13611 4 : from_se.want_coarray = 1;
13612 : }
13613 148 : gfc_conv_expr_descriptor (&to_se, to_expr);
13614 148 : gfc_conv_expr_descriptor (&from_se, from_expr);
13615 148 : gfc_add_block_to_block (&block, &to_se.pre);
13616 148 : gfc_add_block_to_block (&block, &from_se.pre);
13617 :
13618 : /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
13619 : is an image control "statement", cf. IR F08/0040 in 12-006A. */
13620 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13621 : {
13622 6 : tree cond;
13623 :
13624 6 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13625 : fin_label, true, to_expr,
13626 : GFC_CAF_COARRAY_DEALLOCATE_ONLY,
13627 : NULL_TREE, NULL_TREE,
13628 : gfc_conv_descriptor_token (to_se.expr),
13629 : true);
13630 6 : gfc_add_expr_to_block (&block, tmp);
13631 :
13632 6 : tmp = gfc_conv_descriptor_data_get (to_se.expr);
13633 6 : cond = fold_build2_loc (input_location, EQ_EXPR,
13634 : logical_type_node, tmp,
13635 6 : fold_convert (TREE_TYPE (tmp),
13636 : null_pointer_node));
13637 6 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
13638 : 3, null_pointer_node, null_pointer_node,
13639 : integer_zero_node);
13640 :
13641 6 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
13642 : tmp, build_empty_stmt (input_location));
13643 6 : gfc_add_expr_to_block (&block, tmp);
13644 6 : }
13645 : else
13646 : {
13647 142 : if (to_expr->ts.type == BT_DERIVED
13648 25 : && to_expr->ts.u.derived->attr.alloc_comp)
13649 : {
13650 19 : tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
13651 : to_se.expr, to_expr->rank);
13652 19 : gfc_add_expr_to_block (&block, tmp);
13653 : }
13654 :
13655 142 : tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len,
13656 : fin_label, true, to_expr,
13657 : GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE,
13658 : NULL_TREE, NULL_TREE, true);
13659 142 : gfc_add_expr_to_block (&block, tmp);
13660 : }
13661 :
13662 : /* Copy the array descriptor data. */
13663 148 : gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
13664 :
13665 : /* Set "from" to NULL. */
13666 148 : gfc_conv_descriptor_data_set (&block, from_se.expr, null_pointer_node);
13667 :
13668 148 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
13669 : {
13670 : /* Copy the array descriptor data has overwritten the to-token and cleared
13671 : from.data. Now also clear the from.token. */
13672 6 : gfc_conv_descriptor_token_set (&block, from_se.expr, null_pointer_node);
13673 : }
13674 :
13675 148 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
13676 : {
13677 7 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
13678 7 : fold_convert (TREE_TYPE (to_se.string_length),
13679 : from_se.string_length));
13680 7 : if (from_expr->ts.deferred)
13681 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
13682 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
13683 : }
13684 148 : if (fin_label)
13685 0 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
13686 :
13687 148 : gfc_add_block_to_block (&block, &to_se.post);
13688 148 : gfc_add_block_to_block (&block, &from_se.post);
13689 :
13690 148 : return gfc_finish_block (&block);
13691 : }
13692 :
13693 :
13694 : tree
13695 7010 : gfc_conv_intrinsic_subroutine (gfc_code *code)
13696 : {
13697 7010 : tree res;
13698 :
13699 7010 : gcc_assert (code->resolved_isym);
13700 :
13701 7010 : switch (code->resolved_isym->id)
13702 : {
13703 269 : case GFC_ISYM_MOVE_ALLOC:
13704 269 : res = conv_intrinsic_move_alloc (code);
13705 269 : break;
13706 :
13707 14 : case GFC_ISYM_ATOMIC_CAS:
13708 14 : res = conv_intrinsic_atomic_cas (code);
13709 14 : break;
13710 :
13711 95 : case GFC_ISYM_ATOMIC_ADD:
13712 95 : case GFC_ISYM_ATOMIC_AND:
13713 95 : case GFC_ISYM_ATOMIC_DEF:
13714 95 : case GFC_ISYM_ATOMIC_OR:
13715 95 : case GFC_ISYM_ATOMIC_XOR:
13716 95 : case GFC_ISYM_ATOMIC_FETCH_ADD:
13717 95 : case GFC_ISYM_ATOMIC_FETCH_AND:
13718 95 : case GFC_ISYM_ATOMIC_FETCH_OR:
13719 95 : case GFC_ISYM_ATOMIC_FETCH_XOR:
13720 95 : res = conv_intrinsic_atomic_op (code);
13721 95 : break;
13722 :
13723 176 : case GFC_ISYM_ATOMIC_REF:
13724 176 : res = conv_intrinsic_atomic_ref (code);
13725 176 : break;
13726 :
13727 105 : case GFC_ISYM_EVENT_QUERY:
13728 105 : res = conv_intrinsic_event_query (code);
13729 105 : break;
13730 :
13731 3370 : case GFC_ISYM_C_F_POINTER:
13732 3370 : case GFC_ISYM_C_F_PROCPOINTER:
13733 3370 : res = conv_isocbinding_subroutine (code);
13734 3370 : break;
13735 :
13736 60 : case GFC_ISYM_C_F_STRPOINTER:
13737 60 : res = conv_isocbinding_subroutine_strpointer (code);
13738 60 : break;
13739 :
13740 360 : case GFC_ISYM_CAF_SEND:
13741 360 : res = conv_caf_send_to_remote (code);
13742 360 : break;
13743 :
13744 140 : case GFC_ISYM_CAF_SENDGET:
13745 140 : res = conv_caf_sendget (code);
13746 140 : break;
13747 :
13748 100 : case GFC_ISYM_CO_BROADCAST:
13749 100 : case GFC_ISYM_CO_MIN:
13750 100 : case GFC_ISYM_CO_MAX:
13751 100 : case GFC_ISYM_CO_REDUCE:
13752 100 : case GFC_ISYM_CO_SUM:
13753 100 : res = conv_co_collective (code);
13754 100 : break;
13755 :
13756 10 : case GFC_ISYM_FREE:
13757 10 : res = conv_intrinsic_free (code);
13758 10 : break;
13759 :
13760 55 : case GFC_ISYM_FSTAT:
13761 55 : case GFC_ISYM_LSTAT:
13762 55 : case GFC_ISYM_STAT:
13763 55 : res = conv_intrinsic_fstat_lstat_stat_sub (code);
13764 55 : break;
13765 :
13766 90 : case GFC_ISYM_RANDOM_INIT:
13767 90 : res = conv_intrinsic_random_init (code);
13768 90 : break;
13769 :
13770 15 : case GFC_ISYM_KILL:
13771 15 : res = conv_intrinsic_kill_sub (code);
13772 15 : break;
13773 :
13774 : case GFC_ISYM_MVBITS:
13775 : res = NULL_TREE;
13776 : break;
13777 :
13778 196 : case GFC_ISYM_SYSTEM_CLOCK:
13779 196 : res = conv_intrinsic_system_clock (code);
13780 196 : break;
13781 :
13782 102 : case GFC_ISYM_SPLIT:
13783 102 : res = conv_intrinsic_split (code);
13784 102 : break;
13785 :
13786 : default:
13787 : res = NULL_TREE;
13788 : break;
13789 : }
13790 :
13791 7010 : return res;
13792 : }
13793 :
13794 : #include "gt-fortran-trans-intrinsic.h"
|
