Branch data Line data Source code
1 : : /* Intrinsic translation
2 : : Copyright (C) 2002-2024 Free Software Foundation, Inc.
3 : : Contributed by Paul Brook <paul@nowt.org>
4 : : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 : :
6 : : This file is part of GCC.
7 : :
8 : : GCC is free software; you can redistribute it and/or modify it under
9 : : the terms of the GNU General Public License as published by the Free
10 : : Software Foundation; either version 3, or (at your option) any later
11 : : version.
12 : :
13 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : : for more details.
17 : :
18 : : You should have received a copy of the GNU General Public License
19 : : along with GCC; see the file COPYING3. If not see
20 : : <http://www.gnu.org/licenses/>. */
21 : :
22 : : /* trans-intrinsic.cc-- generate GENERIC trees for calls to intrinsics. */
23 : :
24 : : #include "config.h"
25 : : #include "system.h"
26 : : #include "coretypes.h"
27 : : #include "memmodel.h"
28 : : #include "tm.h" /* For UNITS_PER_WORD. */
29 : : #include "tree.h"
30 : : #include "gfortran.h"
31 : : #include "trans.h"
32 : : #include "stringpool.h"
33 : : #include "fold-const.h"
34 : : #include "internal-fn.h"
35 : : #include "tree-nested.h"
36 : : #include "stor-layout.h"
37 : : #include "toplev.h" /* For rest_of_decl_compilation. */
38 : : #include "arith.h"
39 : : #include "trans-const.h"
40 : : #include "trans-types.h"
41 : : #include "trans-array.h"
42 : : #include "dependency.h" /* For CAF array alias analysis. */
43 : : #include "attribs.h"
44 : : #include "realmpfr.h"
45 : :
46 : : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
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 : 10732 : builtin_decl_for_precision (enum built_in_function base_built_in,
146 : : int precision)
147 : : {
148 : 10732 : enum built_in_function i = END_BUILTINS;
149 : :
150 : 10732 : gfc_intrinsic_map_t *m;
151 : 378257 : for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
152 : : ;
153 : :
154 : 10732 : if (precision == TYPE_PRECISION (float_type_node))
155 : 5152 : i = m->float_built_in;
156 : 5580 : 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 : 10608 : return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
170 : : }
171 : :
172 : :
173 : : tree
174 : 10048 : gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
175 : : int kind)
176 : : {
177 : 10048 : int i = gfc_validate_kind (BT_REAL, kind, false);
178 : :
179 : 10048 : 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 : 29987 : for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
185 : : ;
186 : :
187 : 905 : return m->real16_decl;
188 : : }
189 : :
190 : 9143 : return builtin_decl_for_precision (double_built_in,
191 : 9143 : 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 : 69597 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
202 : : tree *argarray, int nargs)
203 : : {
204 : 69597 : gfc_actual_arglist *actual;
205 : 69597 : gfc_expr *e;
206 : 69597 : gfc_intrinsic_arg *formal;
207 : 69597 : gfc_se argse;
208 : 69597 : int curr_arg;
209 : :
210 : 69597 : formal = expr->value.function.isym->formal;
211 : 69597 : actual = expr->value.function.actual;
212 : :
213 : 157037 : for (curr_arg = 0; curr_arg < nargs; curr_arg++,
214 : 87440 : actual = actual->next,
215 : 87440 : formal = formal ? formal->next : NULL)
216 : : {
217 : 87440 : gcc_assert (actual);
218 : 87440 : e = actual->expr;
219 : : /* Skip omitted optional arguments. */
220 : 87440 : if (!e)
221 : : {
222 : 31 : --curr_arg;
223 : 31 : continue;
224 : : }
225 : :
226 : : /* Evaluate the parameter. This will substitute scalarized
227 : : references automatically. */
228 : 87409 : gfc_init_se (&argse, se);
229 : :
230 : 87409 : if (e->ts.type == BT_CHARACTER)
231 : : {
232 : 9355 : gfc_conv_expr (&argse, e);
233 : 9355 : gfc_conv_string_parameter (&argse);
234 : 9355 : argarray[curr_arg++] = argse.string_length;
235 : 9355 : gcc_assert (curr_arg < nargs);
236 : : }
237 : : else
238 : 78054 : 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 : 87409 : if (e->expr_type == EXPR_VARIABLE
243 : 47158 : && e->symtree->n.sym->attr.optional
244 : 143 : && formal
245 : 93 : && formal->optional)
246 : 50 : gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
247 : :
248 : 87409 : gfc_add_block_to_block (&se->pre, &argse.pre);
249 : 87409 : gfc_add_block_to_block (&se->post, &argse.post);
250 : 87409 : argarray[curr_arg] = argse.expr;
251 : : }
252 : 69597 : }
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 : 46239 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
259 : : {
260 : 46239 : int n = 0;
261 : 46239 : gfc_actual_arglist *actual;
262 : :
263 : 105745 : for (actual = expr->value.function.actual; actual; actual = actual->next)
264 : : {
265 : 59506 : if (!actual->expr)
266 : 5858 : continue;
267 : :
268 : 53648 : if (actual->expr->ts.type == BT_CHARACTER)
269 : 4412 : n += 2;
270 : : else
271 : 49236 : n++;
272 : : }
273 : :
274 : 46239 : 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 : 31503 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
283 : : {
284 : 31503 : tree type;
285 : 31503 : tree *args;
286 : 31503 : int nargs;
287 : :
288 : 31503 : nargs = gfc_intrinsic_argument_list_length (expr);
289 : 31503 : 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 : 31503 : type = gfc_typenode_for_spec (&expr->ts);
295 : 31503 : gcc_assert (expr->value.function.actual->expr);
296 : 31503 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
297 : :
298 : : /* Conversion between character kinds involves a call to a library
299 : : function. */
300 : 31503 : if (expr->ts.type == BT_CHARACTER)
301 : : {
302 : 172 : tree fndecl, var, addr, tmp;
303 : :
304 : 172 : if (expr->ts.kind == 1
305 : 59 : && expr->value.function.actual->expr->ts.kind == 4)
306 : 59 : fndecl = gfor_fndecl_convert_char4_to_char1;
307 : 113 : else if (expr->ts.kind == 4
308 : 113 : && expr->value.function.actual->expr->ts.kind == 1)
309 : 113 : fndecl = gfor_fndecl_convert_char1_to_char4;
310 : : else
311 : 0 : gcc_unreachable ();
312 : :
313 : : /* Create the variable storing the converted value. */
314 : 172 : type = gfc_get_pchar_type (expr->ts.kind);
315 : 172 : var = gfc_create_var (type, "str");
316 : 172 : addr = gfc_build_addr_expr (build_pointer_type (type), var);
317 : :
318 : : /* Call the library function that will perform the conversion. */
319 : 172 : gcc_assert (nargs >= 2);
320 : 172 : tmp = build_call_expr_loc (input_location,
321 : : fndecl, 3, addr, args[0], args[1]);
322 : 172 : gfc_add_expr_to_block (&se->pre, tmp);
323 : :
324 : : /* Free the temporary afterwards. */
325 : 172 : tmp = gfc_call_free (var);
326 : 172 : gfc_add_expr_to_block (&se->post, tmp);
327 : :
328 : 172 : se->expr = var;
329 : 172 : se->string_length = args[0];
330 : :
331 : 172 : return;
332 : : }
333 : :
334 : : /* Conversion from complex to non-complex involves taking the real
335 : : component of the value. */
336 : 31331 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
337 : 31331 : && expr->ts.type != BT_COMPLEX)
338 : : {
339 : 581 : tree artype;
340 : :
341 : 581 : artype = TREE_TYPE (TREE_TYPE (args[0]));
342 : 581 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
343 : : args[0]);
344 : : }
345 : :
346 : 31331 : 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 : 132 : 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 : 161 : build_round_expr (tree arg, tree restype)
383 : : {
384 : 161 : tree argtype;
385 : 161 : tree fn;
386 : 161 : int argprec, resprec;
387 : :
388 : 161 : argtype = TREE_TYPE (arg);
389 : 161 : argprec = TYPE_PRECISION (argtype);
390 : 161 : 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 : 298 : if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
399 : 127 : fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
400 : 38 : else if (resprec <= LONG_TYPE_SIZE)
401 : 22 : fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
402 : 12 : else if (resprec <= LONG_LONG_TYPE_SIZE)
403 : 0 : fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
404 : 12 : else if (resprec >= argprec)
405 : 12 : fn = builtin_decl_for_precision (BUILT_IN_ROUND, argprec);
406 : : else
407 : 0 : gcc_unreachable ();
408 : :
409 : 161 : return convert (restype, build_call_expr_loc (input_location,
410 : 161 : fn, 1, arg));
411 : : }
412 : :
413 : :
414 : : /* Convert a real to an integer using a specific rounding mode.
415 : : Ideally we would just build the corresponding GENERIC node,
416 : : however the RTL expander only actually supports FIX_TRUNC_EXPR. */
417 : :
418 : : static tree
419 : 1396 : build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
420 : : enum rounding_mode op)
421 : : {
422 : 1396 : switch (op)
423 : : {
424 : 116 : case RND_FLOOR:
425 : 116 : return build_fixbound_expr (pblock, arg, type, 0);
426 : :
427 : 16 : case RND_CEIL:
428 : 16 : return build_fixbound_expr (pblock, arg, type, 1);
429 : :
430 : 161 : case RND_ROUND:
431 : 161 : return build_round_expr (arg, type);
432 : :
433 : 1103 : case RND_TRUNC:
434 : 1103 : return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
435 : :
436 : 0 : default:
437 : 0 : gcc_unreachable ();
438 : : }
439 : : }
440 : :
441 : :
442 : : /* Round a real value using the specified rounding mode.
443 : : We use a temporary integer of that same kind size as the result.
444 : : Values larger than those that can be represented by this kind are
445 : : unchanged, as they will not be accurate enough to represent the
446 : : rounding.
447 : : huge = HUGE (KIND (a))
448 : : aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
449 : : */
450 : :
451 : : static void
452 : 220 : gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
453 : : {
454 : 220 : tree type;
455 : 220 : tree itype;
456 : 220 : tree arg[2];
457 : 220 : tree tmp;
458 : 220 : tree cond;
459 : 220 : tree decl;
460 : 220 : mpfr_t huge;
461 : 220 : int n, nargs;
462 : 220 : int kind;
463 : :
464 : 220 : kind = expr->ts.kind;
465 : 220 : nargs = gfc_intrinsic_argument_list_length (expr);
466 : :
467 : 220 : decl = NULL_TREE;
468 : : /* We have builtin functions for some cases. */
469 : 220 : switch (op)
470 : : {
471 : 74 : case RND_ROUND:
472 : 74 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
473 : 74 : break;
474 : :
475 : 146 : case RND_TRUNC:
476 : 146 : decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
477 : 146 : break;
478 : :
479 : 0 : default:
480 : 0 : gcc_unreachable ();
481 : : }
482 : :
483 : : /* Evaluate the argument. */
484 : 220 : gcc_assert (expr->value.function.actual->expr);
485 : 220 : gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
486 : :
487 : : /* Use a builtin function if one exists. */
488 : 220 : if (decl != NULL_TREE)
489 : : {
490 : 220 : se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
491 : 220 : return;
492 : : }
493 : :
494 : : /* This code is probably redundant, but we'll keep it lying around just
495 : : in case. */
496 : 0 : type = gfc_typenode_for_spec (&expr->ts);
497 : 0 : arg[0] = gfc_evaluate_now (arg[0], &se->pre);
498 : :
499 : : /* Test if the value is too large to handle sensibly. */
500 : 0 : gfc_set_model_kind (kind);
501 : 0 : mpfr_init (huge);
502 : 0 : n = gfc_validate_kind (BT_INTEGER, kind, false);
503 : 0 : mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
504 : 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
505 : 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
506 : : tmp);
507 : :
508 : 0 : mpfr_neg (huge, huge, GFC_RND_MODE);
509 : 0 : tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
510 : 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
511 : : tmp);
512 : 0 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
513 : : cond, tmp);
514 : 0 : itype = gfc_get_int_type (kind);
515 : :
516 : 0 : tmp = build_fix_expr (&se->pre, arg[0], itype, op);
517 : 0 : tmp = convert (type, tmp);
518 : 0 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
519 : : arg[0]);
520 : 0 : mpfr_clear (huge);
521 : : }
522 : :
523 : :
524 : : /* Convert to an integer using the specified rounding mode. */
525 : :
526 : : static void
527 : 2556 : gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
528 : : {
529 : 2556 : tree type;
530 : 2556 : tree *args;
531 : 2556 : int nargs;
532 : :
533 : 2556 : nargs = gfc_intrinsic_argument_list_length (expr);
534 : 2556 : args = XALLOCAVEC (tree, nargs);
535 : :
536 : : /* Evaluate the argument, we process all arguments even though we only
537 : : use the first one for code generation purposes. */
538 : 2556 : type = gfc_typenode_for_spec (&expr->ts);
539 : 2556 : gcc_assert (expr->value.function.actual->expr);
540 : 2556 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
541 : :
542 : 2556 : if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
543 : : {
544 : : /* Conversion to a different integer kind. */
545 : 1160 : se->expr = convert (type, args[0]);
546 : : }
547 : : else
548 : : {
549 : : /* Conversion from complex to non-complex involves taking the real
550 : : component of the value. */
551 : 1396 : if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
552 : 1396 : && expr->ts.type != BT_COMPLEX)
553 : : {
554 : 186 : tree artype;
555 : :
556 : 186 : artype = TREE_TYPE (TREE_TYPE (args[0]));
557 : 186 : args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
558 : : args[0]);
559 : : }
560 : :
561 : 1396 : se->expr = build_fix_expr (&se->pre, args[0], type, op);
562 : : }
563 : 2556 : }
564 : :
565 : :
566 : : /* Get the imaginary component of a value. */
567 : :
568 : : static void
569 : 432 : gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
570 : : {
571 : 432 : tree arg;
572 : :
573 : 432 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
574 : 432 : se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
575 : 432 : TREE_TYPE (TREE_TYPE (arg)), arg);
576 : 432 : }
577 : :
578 : :
579 : : /* Get the complex conjugate of a value. */
580 : :
581 : : static void
582 : 255 : gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
583 : : {
584 : 255 : tree arg;
585 : :
586 : 255 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
587 : 255 : se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
588 : 255 : }
589 : :
590 : :
591 : :
592 : : static tree
593 : 620277 : define_quad_builtin (const char *name, tree type, bool is_const)
594 : : {
595 : 620277 : tree fndecl;
596 : 620277 : fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
597 : : type);
598 : :
599 : : /* Mark the decl as external. */
600 : 620277 : DECL_EXTERNAL (fndecl) = 1;
601 : 620277 : TREE_PUBLIC (fndecl) = 1;
602 : :
603 : : /* Mark it __attribute__((const)). */
604 : 620277 : TREE_READONLY (fndecl) = is_const;
605 : :
606 : 620277 : rest_of_decl_compilation (fndecl, 1, 0);
607 : :
608 : 620277 : return fndecl;
609 : : }
610 : :
611 : : /* Add SIMD attribute for FNDECL built-in if the built-in
612 : : name is in VECTORIZED_BUILTINS. */
613 : :
614 : : static void
615 : 35338160 : add_simd_flag_for_built_in (tree fndecl)
616 : : {
617 : 35338160 : if (gfc_vectorized_builtins == NULL
618 : 15002000 : || fndecl == NULL_TREE)
619 : 28587260 : return;
620 : :
621 : 6750900 : const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
622 : 6750900 : int *clauses = gfc_vectorized_builtins->get (name);
623 : 6750900 : if (clauses)
624 : : {
625 : 4615388 : for (unsigned i = 0; i < 3; i++)
626 : 3461541 : if (*clauses & (1 << i))
627 : : {
628 : 1153852 : gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
629 : 1153852 : tree omp_clause = NULL_TREE;
630 : 1153852 : if (simd_type == SIMD_NONE)
631 : : ; /* No SIMD clause. */
632 : : else
633 : : {
634 : 2307704 : omp_clause_code code
635 : : = (simd_type == SIMD_INBRANCH
636 : 1153852 : ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
637 : 1153852 : omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
638 : 1153852 : omp_clause = build_tree_list (NULL_TREE, omp_clause);
639 : : }
640 : :
641 : 1153852 : DECL_ATTRIBUTES (fndecl)
642 : 2307704 : = tree_cons (get_identifier ("omp declare simd"), omp_clause,
643 : 1153852 : DECL_ATTRIBUTES (fndecl));
644 : : }
645 : : }
646 : : }
647 : :
648 : : /* Set SIMD attribute to all built-in functions that are mentioned
649 : : in gfc_vectorized_builtins vector. */
650 : :
651 : : void
652 : 67958 : gfc_adjust_builtins (void)
653 : : {
654 : 67958 : gfc_intrinsic_map_t *m;
655 : 3601774 : for (m = gfc_intrinsic_map;
656 : 3601774 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
657 : : {
658 : 3533816 : add_simd_flag_for_built_in (m->real4_decl);
659 : 3533816 : add_simd_flag_for_built_in (m->complex4_decl);
660 : 3533816 : add_simd_flag_for_built_in (m->real8_decl);
661 : 3533816 : add_simd_flag_for_built_in (m->complex8_decl);
662 : 3533816 : add_simd_flag_for_built_in (m->real10_decl);
663 : 3533816 : add_simd_flag_for_built_in (m->complex10_decl);
664 : 3533816 : add_simd_flag_for_built_in (m->real16_decl);
665 : 3533816 : add_simd_flag_for_built_in (m->complex16_decl);
666 : 3533816 : add_simd_flag_for_built_in (m->real16_decl);
667 : 3533816 : add_simd_flag_for_built_in (m->complex16_decl);
668 : : }
669 : :
670 : : /* Release all strings. */
671 : 67958 : if (gfc_vectorized_builtins != NULL)
672 : : {
673 : 1586541 : for (hash_map<nofree_string_hash, int>::iterator it
674 : 28850 : = gfc_vectorized_builtins->begin ();
675 : 1586541 : it != gfc_vectorized_builtins->end (); ++it)
676 : 1557691 : free (CONST_CAST (char *, (*it).first));
677 : :
678 : 57700 : delete gfc_vectorized_builtins;
679 : 28850 : gfc_vectorized_builtins = NULL;
680 : : }
681 : 67958 : }
682 : :
683 : : /* Initialize function decls for library functions. The external functions
684 : : are created as required. Builtin functions are added here. */
685 : :
686 : : void
687 : 29537 : gfc_build_intrinsic_lib_fndecls (void)
688 : : {
689 : 29537 : gfc_intrinsic_map_t *m;
690 : 29537 : tree quad_decls[END_BUILTINS + 1];
691 : :
692 : 29537 : if (gfc_real16_is_float128)
693 : : {
694 : : /* If we have soft-float types, we create the decls for their
695 : : C99-like library functions. For now, we only handle _Float128
696 : : q-suffixed or IEC 60559 f128-suffixed functions. */
697 : :
698 : 29537 : tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
699 : 29537 : tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
700 : :
701 : 29537 : memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
702 : :
703 : 29537 : type = gfc_float128_type_node;
704 : 29537 : complex_type = gfc_complex_float128_type_node;
705 : : /* type (*) (type) */
706 : 29537 : func_1 = build_function_type_list (type, type, NULL_TREE);
707 : : /* int (*) (type) */
708 : 29537 : func_iround = build_function_type_list (integer_type_node,
709 : : type, NULL_TREE);
710 : : /* long (*) (type) */
711 : 29537 : func_lround = build_function_type_list (long_integer_type_node,
712 : : type, NULL_TREE);
713 : : /* long long (*) (type) */
714 : 29537 : func_llround = build_function_type_list (long_long_integer_type_node,
715 : : type, NULL_TREE);
716 : : /* type (*) (type, type) */
717 : 29537 : func_2 = build_function_type_list (type, type, type, NULL_TREE);
718 : : /* type (*) (type, type, type) */
719 : 29537 : func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
720 : : /* type (*) (type, &int) */
721 : 29537 : func_frexp
722 : 29537 : = build_function_type_list (type,
723 : : type,
724 : : build_pointer_type (integer_type_node),
725 : : NULL_TREE);
726 : : /* type (*) (type, int) */
727 : 29537 : func_scalbn = build_function_type_list (type,
728 : : type, integer_type_node, NULL_TREE);
729 : : /* type (*) (complex type) */
730 : 29537 : func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
731 : : /* complex type (*) (complex type, complex type) */
732 : 29537 : func_cpow
733 : 29537 : = build_function_type_list (complex_type,
734 : : complex_type, complex_type, NULL_TREE);
735 : :
736 : : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
737 : : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
738 : : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
739 : :
740 : : /* Only these built-ins are actually needed here. These are used directly
741 : : from the code, when calling builtin_decl_for_precision() or
742 : : builtin_decl_for_float_type(). The others are all constructed by
743 : : gfc_get_intrinsic_lib_fndecl(). */
744 : : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
745 : : quad_decls[BUILT_IN_ ## ID] \
746 : : = define_quad_builtin (gfc_real16_use_iec_60559 \
747 : : ? NAME "f128" : NAME "q", func_ ## TYPE, \
748 : : CONST);
749 : :
750 : : #include "mathbuiltins.def"
751 : :
752 : : #undef OTHER_BUILTIN
753 : : #undef LIB_FUNCTION
754 : : #undef DEFINE_MATH_BUILTIN
755 : : #undef DEFINE_MATH_BUILTIN_C
756 : :
757 : : /* There is one built-in we defined manually, because it gets called
758 : : with builtin_decl_for_precision() or builtin_decl_for_float_type()
759 : : even though it is not an OTHER_BUILTIN: it is SQRT. */
760 : 29537 : quad_decls[BUILT_IN_SQRT]
761 : 29537 : = define_quad_builtin (gfc_real16_use_iec_60559
762 : : ? "sqrtf128" : "sqrtq", func_1, true);
763 : : }
764 : :
765 : : /* Add GCC builtin functions. */
766 : 1535924 : for (m = gfc_intrinsic_map;
767 : 1565461 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
768 : : {
769 : 1535924 : if (m->float_built_in != END_BUILTINS)
770 : 1417776 : m->real4_decl = builtin_decl_explicit (m->float_built_in);
771 : 1535924 : if (m->complex_float_built_in != END_BUILTINS)
772 : 472592 : m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
773 : 1535924 : if (m->double_built_in != END_BUILTINS)
774 : 1417776 : m->real8_decl = builtin_decl_explicit (m->double_built_in);
775 : 1535924 : if (m->complex_double_built_in != END_BUILTINS)
776 : 472592 : m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
777 : :
778 : : /* If real(kind=10) exists, it is always long double. */
779 : 1535924 : if (m->long_double_built_in != END_BUILTINS)
780 : 1417776 : m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
781 : 1535924 : if (m->complex_long_double_built_in != END_BUILTINS)
782 : 472592 : m->complex10_decl
783 : 472592 : = builtin_decl_explicit (m->complex_long_double_built_in);
784 : :
785 : 1535924 : if (!gfc_real16_is_float128)
786 : : {
787 : 0 : if (m->long_double_built_in != END_BUILTINS)
788 : 0 : m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
789 : 0 : if (m->complex_long_double_built_in != END_BUILTINS)
790 : 0 : m->complex16_decl
791 : 0 : = builtin_decl_explicit (m->complex_long_double_built_in);
792 : : }
793 : 1535924 : else if (quad_decls[m->double_built_in] != NULL_TREE)
794 : : {
795 : : /* Quad-precision function calls are constructed when first
796 : : needed by builtin_decl_for_precision(), except for those
797 : : that will be used directly (define by OTHER_BUILTIN). */
798 : 620277 : m->real16_decl = quad_decls[m->double_built_in];
799 : : }
800 : 915647 : else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
801 : : {
802 : : /* Same thing for the complex ones. */
803 : 0 : m->complex16_decl = quad_decls[m->double_built_in];
804 : : }
805 : : }
806 : 29537 : }
807 : :
808 : :
809 : : /* Create a fndecl for a simple intrinsic library function. */
810 : :
811 : : static tree
812 : 4351 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
813 : : {
814 : 4351 : tree type;
815 : 4351 : vec<tree, va_gc> *argtypes;
816 : 4351 : tree fndecl;
817 : 4351 : gfc_actual_arglist *actual;
818 : 4351 : tree *pdecl;
819 : 4351 : gfc_typespec *ts;
820 : 4351 : char name[GFC_MAX_SYMBOL_LEN + 3];
821 : :
822 : 4351 : ts = &expr->ts;
823 : 4351 : if (ts->type == BT_REAL)
824 : : {
825 : 3507 : switch (ts->kind)
826 : : {
827 : 1249 : case 4:
828 : 1249 : pdecl = &m->real4_decl;
829 : 1249 : break;
830 : 1293 : case 8:
831 : 1293 : pdecl = &m->real8_decl;
832 : 1293 : break;
833 : 547 : case 10:
834 : 547 : pdecl = &m->real10_decl;
835 : 547 : break;
836 : 418 : case 16:
837 : 418 : pdecl = &m->real16_decl;
838 : 418 : break;
839 : 0 : default:
840 : 0 : gcc_unreachable ();
841 : : }
842 : : }
843 : 844 : else if (ts->type == BT_COMPLEX)
844 : : {
845 : 844 : gcc_assert (m->complex_available);
846 : :
847 : 844 : switch (ts->kind)
848 : : {
849 : 386 : case 4:
850 : 386 : pdecl = &m->complex4_decl;
851 : 386 : break;
852 : 387 : case 8:
853 : 387 : pdecl = &m->complex8_decl;
854 : 387 : break;
855 : 51 : case 10:
856 : 51 : pdecl = &m->complex10_decl;
857 : 51 : break;
858 : 20 : case 16:
859 : 20 : pdecl = &m->complex16_decl;
860 : 20 : break;
861 : 0 : default:
862 : 0 : gcc_unreachable ();
863 : : }
864 : : }
865 : : else
866 : 0 : gcc_unreachable ();
867 : :
868 : 4351 : if (*pdecl)
869 : : return *pdecl;
870 : :
871 : 339 : if (m->libm_name)
872 : : {
873 : 162 : int n = gfc_validate_kind (BT_REAL, ts->kind, false);
874 : 162 : if (gfc_real_kinds[n].c_float)
875 : 0 : snprintf (name, sizeof (name), "%s%s%s",
876 : 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
877 : 162 : else if (gfc_real_kinds[n].c_double)
878 : 0 : snprintf (name, sizeof (name), "%s%s",
879 : 0 : ts->type == BT_COMPLEX ? "c" : "", m->name);
880 : 162 : else if (gfc_real_kinds[n].c_long_double)
881 : 0 : snprintf (name, sizeof (name), "%s%s%s",
882 : 0 : ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
883 : 162 : else if (gfc_real_kinds[n].c_float128)
884 : 162 : snprintf (name, sizeof (name), "%s%s%s",
885 : 162 : ts->type == BT_COMPLEX ? "c" : "", m->name,
886 : 162 : gfc_real_kinds[n].use_iec_60559 ? "f128" : "q");
887 : : else
888 : 0 : gcc_unreachable ();
889 : : }
890 : : else
891 : : {
892 : 354 : snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
893 : 177 : ts->type == BT_COMPLEX ? 'c' : 'r',
894 : : gfc_type_abi_kind (ts));
895 : : }
896 : :
897 : 339 : argtypes = NULL;
898 : 694 : for (actual = expr->value.function.actual; actual; actual = actual->next)
899 : : {
900 : 355 : type = gfc_typenode_for_spec (&actual->expr->ts);
901 : 355 : vec_safe_push (argtypes, type);
902 : : }
903 : 1017 : type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
904 : 339 : fndecl = build_decl (input_location,
905 : : FUNCTION_DECL, get_identifier (name), type);
906 : :
907 : : /* Mark the decl as external. */
908 : 339 : DECL_EXTERNAL (fndecl) = 1;
909 : 339 : TREE_PUBLIC (fndecl) = 1;
910 : :
911 : : /* Mark it __attribute__((const)), if possible. */
912 : 339 : TREE_READONLY (fndecl) = m->is_constant;
913 : :
914 : 339 : rest_of_decl_compilation (fndecl, 1, 0);
915 : :
916 : 339 : (*pdecl) = fndecl;
917 : 339 : return fndecl;
918 : : }
919 : :
920 : :
921 : : /* Convert an intrinsic function into an external or builtin call. */
922 : :
923 : : static void
924 : 3853 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
925 : : {
926 : 3853 : gfc_intrinsic_map_t *m;
927 : 3853 : tree fndecl;
928 : 3853 : tree rettype;
929 : 3853 : tree *args;
930 : 3853 : unsigned int num_args;
931 : 3853 : gfc_isym_id id;
932 : :
933 : 3853 : id = expr->value.function.isym->id;
934 : : /* Find the entry for this function. */
935 : 55838 : for (m = gfc_intrinsic_map;
936 : 55838 : m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
937 : : {
938 : 55838 : if (id == m->id)
939 : : break;
940 : : }
941 : :
942 : 3853 : if (m->id == GFC_ISYM_NONE)
943 : : {
944 : 0 : gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
945 : : expr->value.function.name, id);
946 : : }
947 : :
948 : : /* Get the decl and generate the call. */
949 : 3853 : num_args = gfc_intrinsic_argument_list_length (expr);
950 : 3853 : args = XALLOCAVEC (tree, num_args);
951 : :
952 : 3853 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
953 : 3853 : fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
954 : 3853 : rettype = TREE_TYPE (TREE_TYPE (fndecl));
955 : :
956 : 3853 : fndecl = build_addr (fndecl);
957 : 3853 : se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
958 : 3853 : }
959 : :
960 : :
961 : : /* If bounds-checking is enabled, create code to verify at runtime that the
962 : : string lengths for both expressions are the same (needed for e.g. MERGE).
963 : : If bounds-checking is not enabled, does nothing. */
964 : :
965 : : void
966 : 1415 : gfc_trans_same_strlen_check (const char* intr_name, locus* where,
967 : : tree a, tree b, stmtblock_t* target)
968 : : {
969 : 1415 : tree cond;
970 : 1415 : tree name;
971 : :
972 : : /* If bounds-checking is disabled, do nothing. */
973 : 1415 : if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
974 : : return;
975 : :
976 : : /* Compare the two string lengths. */
977 : 92 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
978 : :
979 : : /* Output the runtime-check. */
980 : 92 : name = gfc_build_cstring_const (intr_name);
981 : 92 : name = gfc_build_addr_expr (pchar_type_node, name);
982 : 92 : gfc_trans_runtime_check (true, false, cond, target, where,
983 : : "Unequal character lengths (%ld/%ld) in %s",
984 : : fold_convert (long_integer_type_node, a),
985 : : fold_convert (long_integer_type_node, b), name);
986 : : }
987 : :
988 : :
989 : : /* The EXPONENT(X) intrinsic function is translated into
990 : : int ret;
991 : : return isfinite(X) ? (frexp (X, &ret) , ret) : huge
992 : : so that if X is a NaN or infinity, the result is HUGE(0).
993 : : */
994 : :
995 : : static void
996 : 228 : gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
997 : : {
998 : 228 : tree arg, type, res, tmp, frexp, cond, huge;
999 : 228 : int i;
1000 : :
1001 : 456 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
1002 : 228 : expr->value.function.actual->expr->ts.kind);
1003 : :
1004 : 228 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1005 : 228 : arg = gfc_evaluate_now (arg, &se->pre);
1006 : :
1007 : 228 : i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
1008 : 228 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
1009 : 228 : cond = build_call_expr_loc (input_location,
1010 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
1011 : : 1, arg);
1012 : :
1013 : 228 : res = gfc_create_var (integer_type_node, NULL);
1014 : 228 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
1015 : : gfc_build_addr_expr (NULL_TREE, res));
1016 : 228 : tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
1017 : : tmp, res);
1018 : 228 : se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1019 : : cond, tmp, huge);
1020 : :
1021 : 228 : type = gfc_typenode_for_spec (&expr->ts);
1022 : 228 : se->expr = fold_convert (type, se->expr);
1023 : 228 : }
1024 : :
1025 : :
1026 : : /* Fill in the following structure
1027 : : struct caf_vector_t {
1028 : : size_t nvec; // size of the vector
1029 : : union {
1030 : : struct {
1031 : : void *vector;
1032 : : int kind;
1033 : : } v;
1034 : : struct {
1035 : : ptrdiff_t lower_bound;
1036 : : ptrdiff_t upper_bound;
1037 : : ptrdiff_t stride;
1038 : : } triplet;
1039 : : } u;
1040 : : } */
1041 : :
1042 : : static void
1043 : 0 : conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
1044 : : tree lower, tree upper, tree stride,
1045 : : tree vector, int kind, tree nvec)
1046 : : {
1047 : 0 : tree field, type, tmp;
1048 : :
1049 : 0 : desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
1050 : 0 : type = TREE_TYPE (desc);
1051 : :
1052 : 0 : field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1053 : 0 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1054 : : desc, field, NULL_TREE);
1055 : 0 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
1056 : :
1057 : : /* Access union. */
1058 : 0 : field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1059 : 0 : desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1060 : : desc, field, NULL_TREE);
1061 : 0 : type = TREE_TYPE (desc);
1062 : :
1063 : : /* Access the inner struct. */
1064 : 0 : field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
1065 : 0 : desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1066 : : desc, field, NULL_TREE);
1067 : 0 : type = TREE_TYPE (desc);
1068 : :
1069 : 0 : if (vector != NULL_TREE)
1070 : : {
1071 : : /* Set vector and kind. */
1072 : 0 : field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1073 : 0 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1074 : : desc, field, NULL_TREE);
1075 : 0 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
1076 : 0 : field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1077 : 0 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1078 : : desc, field, NULL_TREE);
1079 : 0 : gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
1080 : : }
1081 : : else
1082 : : {
1083 : : /* Set dim.lower/upper/stride. */
1084 : 0 : field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1085 : 0 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1086 : : desc, field, NULL_TREE);
1087 : 0 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
1088 : :
1089 : 0 : field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1090 : 0 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1091 : : desc, field, NULL_TREE);
1092 : 0 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
1093 : :
1094 : 0 : field = gfc_advance_chain (TYPE_FIELDS (type), 2);
1095 : 0 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1096 : : desc, field, NULL_TREE);
1097 : 0 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
1098 : : }
1099 : 0 : }
1100 : :
1101 : :
1102 : : static tree
1103 : 0 : conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
1104 : : {
1105 : 0 : gfc_se argse;
1106 : 0 : tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
1107 : 0 : tree lbound, ubound, tmp;
1108 : 0 : int i;
1109 : :
1110 : 0 : var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
1111 : :
1112 : 0 : for (i = 0; i < ar->dimen; i++)
1113 : 0 : switch (ar->dimen_type[i])
1114 : : {
1115 : 0 : case DIMEN_RANGE:
1116 : 0 : if (ar->end[i])
1117 : : {
1118 : 0 : gfc_init_se (&argse, NULL);
1119 : 0 : gfc_conv_expr (&argse, ar->end[i]);
1120 : 0 : gfc_add_block_to_block (block, &argse.pre);
1121 : 0 : upper = gfc_evaluate_now (argse.expr, block);
1122 : : }
1123 : : else
1124 : 0 : upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1125 : 0 : if (ar->stride[i])
1126 : : {
1127 : 0 : gfc_init_se (&argse, NULL);
1128 : 0 : gfc_conv_expr (&argse, ar->stride[i]);
1129 : 0 : gfc_add_block_to_block (block, &argse.pre);
1130 : 0 : stride = gfc_evaluate_now (argse.expr, block);
1131 : : }
1132 : : else
1133 : 0 : stride = gfc_index_one_node;
1134 : :
1135 : : /* Fall through. */
1136 : 0 : case DIMEN_ELEMENT:
1137 : 0 : if (ar->start[i])
1138 : : {
1139 : 0 : gfc_init_se (&argse, NULL);
1140 : 0 : gfc_conv_expr (&argse, ar->start[i]);
1141 : 0 : gfc_add_block_to_block (block, &argse.pre);
1142 : 0 : lower = gfc_evaluate_now (argse.expr, block);
1143 : : }
1144 : : else
1145 : 0 : lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1146 : 0 : if (ar->dimen_type[i] == DIMEN_ELEMENT)
1147 : : {
1148 : 0 : upper = lower;
1149 : 0 : stride = gfc_index_one_node;
1150 : : }
1151 : 0 : vector = NULL_TREE;
1152 : 0 : nvec = size_zero_node;
1153 : 0 : conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1154 : : vector, 0, nvec);
1155 : 0 : break;
1156 : :
1157 : 0 : case DIMEN_VECTOR:
1158 : 0 : gfc_init_se (&argse, NULL);
1159 : 0 : argse.descriptor_only = 1;
1160 : 0 : gfc_conv_expr_descriptor (&argse, ar->start[i]);
1161 : 0 : gfc_add_block_to_block (block, &argse.pre);
1162 : 0 : vector = argse.expr;
1163 : 0 : lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
1164 : 0 : ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
1165 : 0 : nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1166 : 0 : tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
1167 : 0 : nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1168 : 0 : TREE_TYPE (nvec), nvec, tmp);
1169 : 0 : lower = gfc_index_zero_node;
1170 : 0 : upper = gfc_index_zero_node;
1171 : 0 : stride = gfc_index_zero_node;
1172 : 0 : vector = gfc_conv_descriptor_data_get (vector);
1173 : 0 : conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1174 : 0 : vector, ar->start[i]->ts.kind, nvec);
1175 : 0 : break;
1176 : 0 : default:
1177 : 0 : gcc_unreachable();
1178 : : }
1179 : 0 : return gfc_build_addr_expr (NULL_TREE, var);
1180 : : }
1181 : :
1182 : :
1183 : : static tree
1184 : 1846 : compute_component_offset (tree field, tree type)
1185 : : {
1186 : 1846 : tree tmp;
1187 : 1846 : if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
1188 : 1846 : && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
1189 : : {
1190 : 1106 : tmp = fold_build2 (TRUNC_DIV_EXPR, type,
1191 : : DECL_FIELD_BIT_OFFSET (field),
1192 : : bitsize_unit_node);
1193 : 1106 : return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
1194 : : }
1195 : : else
1196 : 740 : return DECL_FIELD_OFFSET (field);
1197 : : }
1198 : :
1199 : :
1200 : : static tree
1201 : 749 : conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
1202 : : {
1203 : 749 : gfc_ref *ref = expr->ref, *last_comp_ref;
1204 : 749 : tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
1205 : : field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
1206 : : start, end, stride, vector, nvec;
1207 : 749 : gfc_se se;
1208 : 749 : bool ref_static_array = false;
1209 : 749 : tree last_component_ref_tree = NULL_TREE;
1210 : 749 : int i, last_type_n;
1211 : :
1212 : 749 : if (expr->symtree)
1213 : : {
1214 : 749 : last_component_ref_tree = expr->symtree->n.sym->backend_decl;
1215 : 749 : ref_static_array = !expr->symtree->n.sym->attr.allocatable
1216 : 749 : && !expr->symtree->n.sym->attr.pointer;
1217 : : }
1218 : :
1219 : : /* Prevent uninit-warning. */
1220 : 749 : reference_type = NULL_TREE;
1221 : :
1222 : : /* Skip refs upto the first coarray-ref. */
1223 : 749 : last_comp_ref = NULL;
1224 : 761 : while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
1225 : : {
1226 : : /* Remember the type of components skipped. */
1227 : 12 : if (ref->type == REF_COMPONENT)
1228 : 12 : last_comp_ref = ref;
1229 : 12 : ref = ref->next;
1230 : : }
1231 : : /* When a component was skipped, get the type information of the last
1232 : : component ref, else get the type from the symbol. */
1233 : 749 : if (last_comp_ref)
1234 : : {
1235 : 12 : last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
1236 : 12 : last_type_n = last_comp_ref->u.c.component->ts.type;
1237 : : }
1238 : : else
1239 : : {
1240 : 737 : last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
1241 : 737 : last_type_n = expr->symtree->n.sym->ts.type;
1242 : : }
1243 : :
1244 : 3236 : while (ref)
1245 : : {
1246 : 2487 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
1247 : 749 : && ref->u.ar.dimen == 0)
1248 : : {
1249 : : /* Skip pure coindexes. */
1250 : 746 : ref = ref->next;
1251 : 746 : continue;
1252 : : }
1253 : 1741 : tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1254 : 1741 : reference_type = TREE_TYPE (tmp);
1255 : :
1256 : 1741 : if (caf_ref == NULL_TREE)
1257 : 749 : caf_ref = tmp;
1258 : :
1259 : : /* Construct the chain of refs. */
1260 : 1741 : if (prev_caf_ref != NULL_TREE)
1261 : : {
1262 : 992 : field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1263 : 992 : tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1264 : 992 : TREE_TYPE (field), prev_caf_ref, field,
1265 : : NULL_TREE);
1266 : 992 : gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
1267 : : tmp));
1268 : : }
1269 : 1741 : prev_caf_ref = tmp;
1270 : :
1271 : 1741 : switch (ref->type)
1272 : : {
1273 : 1076 : case REF_COMPONENT:
1274 : 1076 : last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
1275 : 1076 : last_type_n = ref->u.c.component->ts.type;
1276 : : /* Set the type of the ref. */
1277 : 1076 : field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1278 : 1076 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
1279 : 1076 : TREE_TYPE (field), prev_caf_ref, field,
1280 : : NULL_TREE);
1281 : 1076 : gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1282 : 1076 : GFC_CAF_REF_COMPONENT));
1283 : :
1284 : : /* Ref the c in union u. */
1285 : 1076 : field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1286 : 1076 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
1287 : 1076 : TREE_TYPE (field), prev_caf_ref, field,
1288 : : NULL_TREE);
1289 : 1076 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
1290 : 1076 : inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1291 : 1076 : TREE_TYPE (field), tmp, field,
1292 : : NULL_TREE);
1293 : :
1294 : : /* Set the offset. */
1295 : 1076 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1296 : 1076 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
1297 : 1076 : TREE_TYPE (field), inner_struct, field,
1298 : : NULL_TREE);
1299 : : /* Computing the offset is somewhat harder. The bit_offset has to be
1300 : : taken into account. When the bit_offset in the field_decl is non-
1301 : : null, divide it by the bitsize_unit and add it to the regular
1302 : : offset. */
1303 : 1076 : tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
1304 : 1076 : TREE_TYPE (tmp));
1305 : 1076 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1306 : :
1307 : : /* Set caf_token_offset. */
1308 : 1076 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
1309 : 1076 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
1310 : 1076 : TREE_TYPE (field), inner_struct, field,
1311 : : NULL_TREE);
1312 : 1076 : if ((ref->u.c.component->attr.allocatable
1313 : 1076 : || ref->u.c.component->attr.pointer)
1314 : 770 : && ref->u.c.component->attr.dimension)
1315 : : {
1316 : 464 : tree arr_desc_token_offset;
1317 : : /* Get the token field from the descriptor. */
1318 : 464 : arr_desc_token_offset = TREE_OPERAND (
1319 : : gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1);
1320 : 464 : arr_desc_token_offset
1321 : 464 : = compute_component_offset (arr_desc_token_offset,
1322 : 464 : TREE_TYPE (tmp));
1323 : 464 : tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
1324 : 464 : TREE_TYPE (tmp2), tmp2,
1325 : : arr_desc_token_offset);
1326 : 464 : }
1327 : 612 : else if (ref->u.c.component->caf_token)
1328 : 306 : tmp2 = compute_component_offset (ref->u.c.component->caf_token,
1329 : 306 : TREE_TYPE (tmp));
1330 : : else
1331 : 306 : tmp2 = integer_zero_node;
1332 : 1076 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1333 : :
1334 : : /* Remember whether this ref was to a non-allocatable/non-pointer
1335 : : component so the next array ref can be tailored correctly. */
1336 : 1076 : ref_static_array = !ref->u.c.component->attr.allocatable
1337 : 1076 : && !ref->u.c.component->attr.pointer;
1338 : 1076 : last_component_ref_tree = ref_static_array
1339 : 1076 : ? ref->u.c.component->backend_decl : NULL_TREE;
1340 : : break;
1341 : 665 : case REF_ARRAY:
1342 : 665 : if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
1343 : 467 : ref_static_array = false;
1344 : : /* Set the type of the ref. */
1345 : 665 : field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1346 : 665 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
1347 : 665 : TREE_TYPE (field), prev_caf_ref, field,
1348 : : NULL_TREE);
1349 : 665 : gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1350 : : ref_static_array
1351 : 1132 : ? GFC_CAF_REF_STATIC_ARRAY
1352 : : : GFC_CAF_REF_ARRAY));
1353 : :
1354 : : /* Ref the a in union u. */
1355 : 665 : field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1356 : 665 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
1357 : 665 : TREE_TYPE (field), prev_caf_ref, field,
1358 : : NULL_TREE);
1359 : 665 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
1360 : 665 : inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1361 : 665 : TREE_TYPE (field), tmp, field,
1362 : : NULL_TREE);
1363 : :
1364 : : /* Set the static_array_type in a for static arrays. */
1365 : 665 : if (ref_static_array)
1366 : : {
1367 : 198 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
1368 : : 1);
1369 : 198 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
1370 : 198 : TREE_TYPE (field), inner_struct, field,
1371 : : NULL_TREE);
1372 : 198 : gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
1373 : : last_type_n));
1374 : : }
1375 : : /* Ref the mode in the inner_struct. */
1376 : 665 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1377 : 665 : mode = fold_build3_loc (input_location, COMPONENT_REF,
1378 : 665 : TREE_TYPE (field), inner_struct, field,
1379 : : NULL_TREE);
1380 : : /* Ref the dim in the inner_struct. */
1381 : 665 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
1382 : 1330 : dim_array = fold_build3_loc (input_location, COMPONENT_REF,
1383 : 665 : TREE_TYPE (field), inner_struct, field,
1384 : : NULL_TREE);
1385 : 2398 : for (i = 0; i < ref->u.ar.dimen; ++i)
1386 : : {
1387 : : /* Ref dim i. */
1388 : 1068 : dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
1389 : 1068 : dim_type = TREE_TYPE (dim);
1390 : 1068 : mode_rhs = start = end = stride = NULL_TREE;
1391 : 1068 : switch (ref->u.ar.dimen_type[i])
1392 : : {
1393 : 810 : case DIMEN_RANGE:
1394 : 810 : if (ref->u.ar.end[i])
1395 : : {
1396 : 92 : gfc_init_se (&se, NULL);
1397 : 92 : gfc_conv_expr (&se, ref->u.ar.end[i]);
1398 : 92 : gfc_add_block_to_block (block, &se.pre);
1399 : 92 : if (ref_static_array)
1400 : : {
1401 : : /* Make the index zero-based, when reffing a static
1402 : : array. */
1403 : 42 : end = se.expr;
1404 : 42 : gfc_init_se (&se, NULL);
1405 : 42 : gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1406 : 42 : gfc_add_block_to_block (block, &se.pre);
1407 : 42 : se.expr = fold_build2 (MINUS_EXPR,
1408 : : gfc_array_index_type,
1409 : : end, fold_convert (
1410 : : gfc_array_index_type,
1411 : : se.expr));
1412 : : }
1413 : 92 : end = gfc_evaluate_now (fold_convert (
1414 : : gfc_array_index_type,
1415 : : se.expr),
1416 : : block);
1417 : : }
1418 : 718 : else if (ref_static_array)
1419 : 324 : end = fold_build2 (MINUS_EXPR,
1420 : : gfc_array_index_type,
1421 : : gfc_conv_array_ubound (
1422 : : last_component_ref_tree, i),
1423 : : gfc_conv_array_lbound (
1424 : : last_component_ref_tree, i));
1425 : : else
1426 : : {
1427 : 394 : end = NULL_TREE;
1428 : 394 : mode_rhs = build_int_cst (unsigned_char_type_node,
1429 : 394 : GFC_CAF_ARR_REF_OPEN_END);
1430 : : }
1431 : 810 : if (ref->u.ar.stride[i])
1432 : : {
1433 : 96 : gfc_init_se (&se, NULL);
1434 : 96 : gfc_conv_expr (&se, ref->u.ar.stride[i]);
1435 : 96 : gfc_add_block_to_block (block, &se.pre);
1436 : 96 : stride = gfc_evaluate_now (fold_convert (
1437 : : gfc_array_index_type,
1438 : : se.expr),
1439 : : block);
1440 : 96 : if (ref_static_array)
1441 : : {
1442 : : /* Make the index zero-based, when reffing a static
1443 : : array. */
1444 : 24 : stride = fold_build2 (MULT_EXPR,
1445 : : gfc_array_index_type,
1446 : : gfc_conv_array_stride (
1447 : : last_component_ref_tree,
1448 : : i),
1449 : : stride);
1450 : 24 : gcc_assert (end != NULL_TREE);
1451 : : /* Multiply with the product of array's stride and
1452 : : the step of the ref to a virtual upper bound.
1453 : : We cannot compute the actual upper bound here or
1454 : : the caflib would compute the extend
1455 : : incorrectly. */
1456 : 24 : end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1457 : : end, gfc_conv_array_stride (
1458 : : last_component_ref_tree,
1459 : : i));
1460 : 24 : end = gfc_evaluate_now (end, block);
1461 : 24 : stride = gfc_evaluate_now (stride, block);
1462 : : }
1463 : : }
1464 : 714 : else if (ref_static_array)
1465 : : {
1466 : 342 : stride = gfc_conv_array_stride (last_component_ref_tree,
1467 : : i);
1468 : 342 : end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1469 : : end, stride);
1470 : 342 : end = gfc_evaluate_now (end, block);
1471 : : }
1472 : : else
1473 : : /* Always set a ref stride of one to make caflib's
1474 : : handling easier. */
1475 : 372 : stride = gfc_index_one_node;
1476 : :
1477 : : /* Fall through. */
1478 : 1044 : case DIMEN_ELEMENT:
1479 : 1044 : if (ref->u.ar.start[i])
1480 : : {
1481 : 302 : gfc_init_se (&se, NULL);
1482 : 302 : gfc_conv_expr (&se, ref->u.ar.start[i]);
1483 : 302 : gfc_add_block_to_block (block, &se.pre);
1484 : 302 : if (ref_static_array)
1485 : : {
1486 : : /* Make the index zero-based, when reffing a static
1487 : : array. */
1488 : 18 : start = fold_convert (gfc_array_index_type, se.expr);
1489 : 18 : gfc_init_se (&se, NULL);
1490 : 18 : gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1491 : 18 : gfc_add_block_to_block (block, &se.pre);
1492 : 18 : se.expr = fold_build2 (MINUS_EXPR,
1493 : : gfc_array_index_type,
1494 : : start, fold_convert (
1495 : : gfc_array_index_type,
1496 : : se.expr));
1497 : : /* Multiply with the stride. */
1498 : 18 : se.expr = fold_build2 (MULT_EXPR,
1499 : : gfc_array_index_type,
1500 : : se.expr,
1501 : : gfc_conv_array_stride (
1502 : : last_component_ref_tree,
1503 : : i));
1504 : : }
1505 : 302 : start = gfc_evaluate_now (fold_convert (
1506 : : gfc_array_index_type,
1507 : : se.expr),
1508 : : block);
1509 : 302 : if (mode_rhs == NULL_TREE)
1510 : 290 : mode_rhs = build_int_cst (unsigned_char_type_node,
1511 : 290 : ref->u.ar.dimen_type[i]
1512 : : == DIMEN_ELEMENT
1513 : 346 : ? GFC_CAF_ARR_REF_SINGLE
1514 : : : GFC_CAF_ARR_REF_RANGE);
1515 : : }
1516 : 742 : else if (ref_static_array)
1517 : : {
1518 : 348 : start = integer_zero_node;
1519 : 348 : mode_rhs = build_int_cst (unsigned_char_type_node,
1520 : : ref->u.ar.start[i] == NULL
1521 : 348 : ? GFC_CAF_ARR_REF_FULL
1522 : : : GFC_CAF_ARR_REF_RANGE);
1523 : : }
1524 : 394 : else if (end == NULL_TREE)
1525 : 382 : mode_rhs = build_int_cst (unsigned_char_type_node,
1526 : 382 : GFC_CAF_ARR_REF_FULL);
1527 : : else
1528 : 12 : mode_rhs = build_int_cst (unsigned_char_type_node,
1529 : 12 : GFC_CAF_ARR_REF_OPEN_START);
1530 : :
1531 : : /* Ref the s in dim. */
1532 : 1044 : field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
1533 : 1044 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
1534 : 1044 : TREE_TYPE (field), dim, field,
1535 : : NULL_TREE);
1536 : :
1537 : : /* Set start in s. */
1538 : 1044 : if (start != NULL_TREE)
1539 : : {
1540 : 650 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1541 : : 0);
1542 : 650 : tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1543 : 650 : TREE_TYPE (field), tmp, field,
1544 : : NULL_TREE);
1545 : 650 : gfc_add_modify (block, tmp2,
1546 : 650 : fold_convert (TREE_TYPE (tmp2), start));
1547 : : }
1548 : :
1549 : : /* Set end in s. */
1550 : 1044 : if (end != NULL_TREE)
1551 : : {
1552 : 416 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1553 : : 1);
1554 : 416 : tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1555 : 416 : TREE_TYPE (field), tmp, field,
1556 : : NULL_TREE);
1557 : 416 : gfc_add_modify (block, tmp2,
1558 : 416 : fold_convert (TREE_TYPE (tmp2), end));
1559 : : }
1560 : :
1561 : : /* Set end in s. */
1562 : 1044 : if (stride != NULL_TREE)
1563 : : {
1564 : 810 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1565 : : 2);
1566 : 810 : tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1567 : 810 : TREE_TYPE (field), tmp, field,
1568 : : NULL_TREE);
1569 : 810 : gfc_add_modify (block, tmp2,
1570 : 810 : fold_convert (TREE_TYPE (tmp2), stride));
1571 : : }
1572 : : break;
1573 : 24 : case DIMEN_VECTOR:
1574 : : /* TODO: In case of static array. */
1575 : 24 : gcc_assert (!ref_static_array);
1576 : 48 : mode_rhs = build_int_cst (unsigned_char_type_node,
1577 : 24 : GFC_CAF_ARR_REF_VECTOR);
1578 : 24 : gfc_init_se (&se, NULL);
1579 : 24 : se.descriptor_only = 1;
1580 : 24 : gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
1581 : 24 : gfc_add_block_to_block (block, &se.pre);
1582 : 24 : vector = se.expr;
1583 : 24 : tmp = gfc_conv_descriptor_lbound_get (vector,
1584 : : gfc_rank_cst[0]);
1585 : 24 : tmp2 = gfc_conv_descriptor_ubound_get (vector,
1586 : : gfc_rank_cst[0]);
1587 : 24 : nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL);
1588 : 24 : tmp = gfc_conv_descriptor_stride_get (vector,
1589 : : gfc_rank_cst[0]);
1590 : 24 : nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1591 : 24 : TREE_TYPE (nvec), nvec, tmp);
1592 : 24 : vector = gfc_conv_descriptor_data_get (vector);
1593 : :
1594 : : /* Ref the v in dim. */
1595 : 24 : field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
1596 : 24 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
1597 : 24 : TREE_TYPE (field), dim, field,
1598 : : NULL_TREE);
1599 : :
1600 : : /* Set vector in v. */
1601 : 24 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
1602 : 24 : tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1603 : 24 : TREE_TYPE (field), tmp, field,
1604 : : NULL_TREE);
1605 : 24 : gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1606 : : vector));
1607 : :
1608 : : /* Set nvec in v. */
1609 : 24 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
1610 : 24 : tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1611 : 24 : TREE_TYPE (field), tmp, field,
1612 : : NULL_TREE);
1613 : 24 : gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1614 : : nvec));
1615 : :
1616 : : /* Set kind in v. */
1617 : 24 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
1618 : 24 : tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1619 : 24 : TREE_TYPE (field), tmp, field,
1620 : : NULL_TREE);
1621 : 24 : gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
1622 : 24 : ref->u.ar.start[i]->ts.kind));
1623 : 24 : break;
1624 : 0 : default:
1625 : 0 : gcc_unreachable ();
1626 : : }
1627 : : /* Set the mode for dim i. */
1628 : 1068 : tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1629 : 1068 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
1630 : : mode_rhs));
1631 : : }
1632 : :
1633 : : /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1634 : 665 : if (i < GFC_MAX_DIMENSIONS)
1635 : : {
1636 : 665 : tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1637 : 665 : gfc_add_modify (block, tmp,
1638 : : build_int_cst (unsigned_char_type_node,
1639 : 665 : GFC_CAF_ARR_REF_NONE));
1640 : : }
1641 : : break;
1642 : 0 : default:
1643 : 0 : gcc_unreachable ();
1644 : : }
1645 : :
1646 : : /* Set the size of the current type. */
1647 : 1741 : field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
1648 : 1741 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1649 : : prev_caf_ref, field, NULL_TREE);
1650 : 1741 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1651 : : TYPE_SIZE_UNIT (last_type)));
1652 : :
1653 : 1741 : ref = ref->next;
1654 : : }
1655 : :
1656 : 749 : if (prev_caf_ref != NULL_TREE)
1657 : : {
1658 : 749 : field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1659 : 749 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1660 : : prev_caf_ref, field, NULL_TREE);
1661 : 749 : gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1662 : : null_pointer_node));
1663 : : }
1664 : 749 : return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
1665 : 749 : : NULL_TREE;
1666 : : }
1667 : :
1668 : : /* Get data from a remote coarray. */
1669 : :
1670 : : static void
1671 : 791 : gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
1672 : : tree may_require_tmp, bool may_realloc,
1673 : : symbol_attribute *caf_attr)
1674 : : {
1675 : 791 : gfc_expr *array_expr, *tmp_stat;
1676 : 791 : gfc_se argse;
1677 : 791 : tree caf_decl, token, offset, image_index, tmp;
1678 : 791 : tree res_var, dst_var, type, kind, vec, stat;
1679 : 791 : tree caf_reference;
1680 : 791 : symbol_attribute caf_attr_store;
1681 : :
1682 : 791 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1683 : :
1684 : 791 : if (se->ss && se->ss->info->useflags)
1685 : : {
1686 : : /* Access the previously obtained result. */
1687 : 272 : gfc_conv_tmp_array_ref (se);
1688 : 915 : return;
1689 : : }
1690 : :
1691 : : /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1692 : 519 : array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
1693 : 519 : type = gfc_typenode_for_spec (&array_expr->ts);
1694 : :
1695 : 519 : if (caf_attr == NULL)
1696 : : {
1697 : 370 : caf_attr_store = gfc_caf_attr (array_expr);
1698 : 370 : caf_attr = &caf_attr_store;
1699 : : }
1700 : :
1701 : 519 : res_var = lhs;
1702 : 519 : dst_var = lhs;
1703 : :
1704 : 519 : vec = null_pointer_node;
1705 : 519 : tmp_stat = gfc_find_stat_co (expr);
1706 : :
1707 : 519 : if (tmp_stat)
1708 : : {
1709 : 11 : gfc_se stat_se;
1710 : 11 : gfc_init_se (&stat_se, NULL);
1711 : 11 : gfc_conv_expr_reference (&stat_se, tmp_stat);
1712 : 11 : stat = stat_se.expr;
1713 : 11 : gfc_add_block_to_block (&se->pre, &stat_se.pre);
1714 : 11 : gfc_add_block_to_block (&se->post, &stat_se.post);
1715 : : }
1716 : : else
1717 : 508 : stat = null_pointer_node;
1718 : :
1719 : : /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1720 : : is reallocatable or the right-hand side has allocatable components. */
1721 : 519 : if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
1722 : : {
1723 : : /* Get using caf_get_by_ref. */
1724 : 371 : caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
1725 : :
1726 : 371 : if (caf_reference != NULL_TREE)
1727 : : {
1728 : 371 : if (lhs == NULL_TREE)
1729 : : {
1730 : 320 : if (array_expr->ts.type == BT_CHARACTER)
1731 : 0 : gfc_init_se (&argse, NULL);
1732 : 320 : if (array_expr->rank == 0)
1733 : : {
1734 : 78 : symbol_attribute attr;
1735 : 78 : gfc_clear_attr (&attr);
1736 : 78 : if (array_expr->ts.type == BT_CHARACTER)
1737 : : {
1738 : 0 : res_var = gfc_conv_string_tmp (se,
1739 : : build_pointer_type (type),
1740 : 0 : array_expr->ts.u.cl->backend_decl);
1741 : 0 : argse.string_length = array_expr->ts.u.cl->backend_decl;
1742 : : }
1743 : : else
1744 : 78 : res_var = gfc_create_var (type, "caf_res");
1745 : 78 : dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
1746 : 78 : dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1747 : : }
1748 : : else
1749 : : {
1750 : : /* Create temporary. */
1751 : 242 : if (array_expr->ts.type == BT_CHARACTER)
1752 : 0 : gfc_conv_expr_descriptor (&argse, array_expr);
1753 : 242 : may_realloc = gfc_trans_create_temp_array (&se->pre,
1754 : : &se->post,
1755 : : se->ss, type,
1756 : : NULL_TREE, false,
1757 : : false, false,
1758 : : &array_expr->where)
1759 : : == NULL_TREE;
1760 : 242 : res_var = se->ss->info->data.array.descriptor;
1761 : 242 : dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1762 : 242 : if (may_realloc)
1763 : : {
1764 : 26 : tmp = gfc_conv_descriptor_data_get (res_var);
1765 : 26 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
1766 : : NULL_TREE, NULL_TREE,
1767 : : NULL_TREE, true,
1768 : : NULL,
1769 : : GFC_CAF_COARRAY_NOCOARRAY);
1770 : 26 : gfc_add_expr_to_block (&se->post, tmp);
1771 : : }
1772 : : }
1773 : : }
1774 : :
1775 : 371 : kind = build_int_cst (integer_type_node, expr->ts.kind);
1776 : 371 : if (lhs_kind == NULL_TREE)
1777 : 320 : lhs_kind = kind;
1778 : :
1779 : 371 : caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1780 : 371 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1781 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1782 : 371 : image_index = gfc_caf_get_image_index (&se->pre, array_expr,
1783 : : caf_decl);
1784 : 371 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
1785 : : array_expr);
1786 : :
1787 : : /* No overlap possible as we have generated a temporary. */
1788 : 371 : if (lhs == NULL_TREE)
1789 : 320 : may_require_tmp = boolean_false_node;
1790 : :
1791 : : /* It guarantees memory consistency within the same segment. */
1792 : 371 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1793 : 371 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1794 : : gfc_build_string_const (1, ""), NULL_TREE,
1795 : : NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE),
1796 : : NULL_TREE);
1797 : 371 : ASM_VOLATILE_P (tmp) = 1;
1798 : 371 : gfc_add_expr_to_block (&se->pre, tmp);
1799 : :
1800 : 371 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
1801 : : 10, token, image_index, dst_var,
1802 : : caf_reference, lhs_kind, kind,
1803 : : may_require_tmp,
1804 : : may_realloc ? boolean_true_node :
1805 : : boolean_false_node,
1806 : : stat, build_int_cst (integer_type_node,
1807 : 371 : array_expr->ts.type));
1808 : :
1809 : 371 : gfc_add_expr_to_block (&se->pre, tmp);
1810 : :
1811 : 371 : if (se->ss)
1812 : 242 : gfc_advance_se_ss_chain (se);
1813 : :
1814 : 371 : se->expr = res_var;
1815 : 371 : if (array_expr->ts.type == BT_CHARACTER)
1816 : 0 : se->string_length = argse.string_length;
1817 : :
1818 : 371 : return;
1819 : : }
1820 : : }
1821 : :
1822 : 148 : gfc_init_se (&argse, NULL);
1823 : 148 : if (array_expr->rank == 0)
1824 : : {
1825 : 73 : symbol_attribute attr;
1826 : :
1827 : 73 : gfc_clear_attr (&attr);
1828 : 73 : gfc_conv_expr (&argse, array_expr);
1829 : :
1830 : 73 : if (lhs == NULL_TREE)
1831 : : {
1832 : 19 : gfc_clear_attr (&attr);
1833 : 19 : if (array_expr->ts.type == BT_CHARACTER)
1834 : 9 : res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
1835 : : argse.string_length);
1836 : : else
1837 : 10 : res_var = gfc_create_var (type, "caf_res");
1838 : 19 : dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
1839 : 19 : dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1840 : : }
1841 : 73 : argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
1842 : 73 : argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1843 : : }
1844 : : else
1845 : : {
1846 : : /* If has_vector, pass descriptor for whole array and the
1847 : : vector bounds separately. */
1848 : 75 : gfc_array_ref *ar, ar2;
1849 : 75 : bool has_vector = false;
1850 : :
1851 : 75 : if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
1852 : : {
1853 : 0 : has_vector = true;
1854 : 0 : ar = gfc_find_array_ref (expr);
1855 : 0 : ar2 = *ar;
1856 : 0 : memset (ar, '\0', sizeof (*ar));
1857 : 0 : ar->as = ar2.as;
1858 : 0 : ar->type = AR_FULL;
1859 : : }
1860 : : // TODO: Check whether argse.want_coarray = 1 can help with the below.
1861 : 75 : gfc_conv_expr_descriptor (&argse, array_expr);
1862 : : /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1863 : : has the wrong type if component references are done. */
1864 : 75 : gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
1865 : : gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1866 : : : array_expr->rank,
1867 : : type));
1868 : 75 : if (has_vector)
1869 : : {
1870 : 0 : vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
1871 : 0 : *ar = ar2;
1872 : : }
1873 : :
1874 : 75 : if (lhs == NULL_TREE)
1875 : : {
1876 : : /* Create temporary. */
1877 : 62 : for (int n = 0; n < se->ss->loop->dimen; n++)
1878 : 31 : if (se->loop->to[n] == NULL_TREE)
1879 : : {
1880 : 12 : se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
1881 : : gfc_rank_cst[n]);
1882 : 12 : se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
1883 : : gfc_rank_cst[n]);
1884 : : }
1885 : 31 : gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
1886 : : NULL_TREE, false, true, false,
1887 : : &array_expr->where);
1888 : 31 : res_var = se->ss->info->data.array.descriptor;
1889 : 31 : dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1890 : : }
1891 : 75 : argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1892 : : }
1893 : :
1894 : 148 : kind = build_int_cst (integer_type_node, expr->ts.kind);
1895 : 148 : if (lhs_kind == NULL_TREE)
1896 : 50 : lhs_kind = kind;
1897 : :
1898 : 148 : gfc_add_block_to_block (&se->pre, &argse.pre);
1899 : 148 : gfc_add_block_to_block (&se->post, &argse.post);
1900 : :
1901 : 148 : caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1902 : 148 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1903 : 1 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1904 : 148 : image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1905 : 148 : gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
1906 : : array_expr);
1907 : :
1908 : : /* No overlap possible as we have generated a temporary. */
1909 : 148 : if (lhs == NULL_TREE)
1910 : 50 : may_require_tmp = boolean_false_node;
1911 : :
1912 : : /* It guarantees memory consistency within the same segment. */
1913 : 148 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1914 : 148 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1915 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1916 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1917 : 148 : ASM_VOLATILE_P (tmp) = 1;
1918 : 148 : gfc_add_expr_to_block (&se->pre, tmp);
1919 : :
1920 : 148 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
1921 : : token, offset, image_index, argse.expr, vec,
1922 : : dst_var, kind, lhs_kind, may_require_tmp, stat);
1923 : :
1924 : 148 : gfc_add_expr_to_block (&se->pre, tmp);
1925 : :
1926 : 148 : if (se->ss)
1927 : 31 : gfc_advance_se_ss_chain (se);
1928 : :
1929 : 148 : se->expr = res_var;
1930 : 148 : if (array_expr->ts.type == BT_CHARACTER)
1931 : 25 : se->string_length = argse.string_length;
1932 : : }
1933 : :
1934 : :
1935 : : /* Send data to a remote coarray. */
1936 : :
1937 : : static tree
1938 : 528 : conv_caf_send (gfc_code *code) {
1939 : 528 : gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
1940 : 528 : gfc_se lhs_se, rhs_se;
1941 : 528 : stmtblock_t block;
1942 : 528 : tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
1943 : 528 : tree may_require_tmp, src_stat, dst_stat, dst_team;
1944 : 528 : tree lhs_type = NULL_TREE;
1945 : 528 : tree vec = null_pointer_node, rhs_vec = null_pointer_node;
1946 : 528 : symbol_attribute lhs_caf_attr, rhs_caf_attr;
1947 : :
1948 : 528 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1949 : :
1950 : 528 : lhs_expr = code->ext.actual->expr;
1951 : 528 : rhs_expr = code->ext.actual->next->expr;
1952 : 528 : may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
1953 : 528 : ? boolean_false_node : boolean_true_node;
1954 : 528 : gfc_init_block (&block);
1955 : :
1956 : 528 : lhs_caf_attr = gfc_caf_attr (lhs_expr);
1957 : 528 : rhs_caf_attr = gfc_caf_attr (rhs_expr);
1958 : 528 : src_stat = dst_stat = null_pointer_node;
1959 : 528 : dst_team = null_pointer_node;
1960 : :
1961 : : /* LHS. */
1962 : 528 : gfc_init_se (&lhs_se, NULL);
1963 : 528 : if (lhs_expr->rank == 0)
1964 : : {
1965 : 217 : if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
1966 : : {
1967 : 4 : lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
1968 : 4 : lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1969 : : }
1970 : : else
1971 : : {
1972 : 213 : symbol_attribute attr;
1973 : 213 : gfc_clear_attr (&attr);
1974 : 213 : gfc_conv_expr (&lhs_se, lhs_expr);
1975 : 213 : lhs_type = TREE_TYPE (lhs_se.expr);
1976 : 213 : lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
1977 : : attr);
1978 : 213 : lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1979 : : }
1980 : : }
1981 : 311 : else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
1982 : 168 : && lhs_caf_attr.codimension)
1983 : : {
1984 : 168 : lhs_se.want_pointer = 1;
1985 : 168 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1986 : : /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1987 : : has the wrong type if component references are done. */
1988 : 168 : lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1989 : 168 : tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1990 : 168 : gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1991 : : gfc_get_dtype_rank_type (
1992 : 168 : gfc_has_vector_subscript (lhs_expr)
1993 : 0 : ? gfc_find_array_ref (lhs_expr)->dimen
1994 : : : lhs_expr->rank,
1995 : : lhs_type));
1996 : : }
1997 : : else
1998 : : {
1999 : 143 : bool has_vector = gfc_has_vector_subscript (lhs_expr);
2000 : :
2001 : 143 : if (gfc_is_coindexed (lhs_expr) || !has_vector)
2002 : : {
2003 : : /* If has_vector, pass descriptor for whole array and the
2004 : : vector bounds separately. */
2005 : 139 : gfc_array_ref *ar, ar2;
2006 : 139 : bool has_tmp_lhs_array = false;
2007 : 139 : if (has_vector)
2008 : : {
2009 : 0 : has_tmp_lhs_array = true;
2010 : 0 : ar = gfc_find_array_ref (lhs_expr);
2011 : 0 : ar2 = *ar;
2012 : 0 : memset (ar, '\0', sizeof (*ar));
2013 : 0 : ar->as = ar2.as;
2014 : 0 : ar->type = AR_FULL;
2015 : : }
2016 : 139 : lhs_se.want_pointer = 1;
2017 : 139 : gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
2018 : : /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2019 : : that has the wrong type if component references are done. */
2020 : 139 : lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2021 : 139 : tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
2022 : 139 : gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2023 : : gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2024 : : : lhs_expr->rank,
2025 : : lhs_type));
2026 : 139 : if (has_tmp_lhs_array)
2027 : : {
2028 : 0 : vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
2029 : 0 : *ar = ar2;
2030 : : }
2031 : : }
2032 : : else
2033 : : {
2034 : : /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2035 : : indexed array expression. This is rewritten to:
2036 : :
2037 : : tmp_array = arr2[...]
2038 : : arr1 ([...]) = tmp_array
2039 : :
2040 : : because using the standard gfc_conv_expr (lhs_expr) did the
2041 : : assignment with lhs and rhs exchanged. */
2042 : :
2043 : 4 : gfc_ss *lss_for_tmparray, *lss_real;
2044 : 4 : gfc_loopinfo loop;
2045 : 4 : gfc_se se;
2046 : 4 : stmtblock_t body;
2047 : 4 : tree tmparr_desc, src;
2048 : 4 : tree index = gfc_index_zero_node;
2049 : 4 : tree stride = gfc_index_zero_node;
2050 : 4 : int n;
2051 : :
2052 : : /* Walk both sides of the assignment, once to get the shape of the
2053 : : temporary array to create right. */
2054 : 4 : lss_for_tmparray = gfc_walk_expr (lhs_expr);
2055 : : /* And a second time to be able to create an assignment of the
2056 : : temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2057 : : the tree in the descriptor with the one for the temporary
2058 : : array. */
2059 : 4 : lss_real = gfc_walk_expr (lhs_expr);
2060 : 4 : gfc_init_loopinfo (&loop);
2061 : 4 : gfc_add_ss_to_loop (&loop, lss_for_tmparray);
2062 : 4 : gfc_add_ss_to_loop (&loop, lss_real);
2063 : 4 : gfc_conv_ss_startstride (&loop);
2064 : 4 : gfc_conv_loop_setup (&loop, &lhs_expr->where);
2065 : 4 : lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2066 : 4 : gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
2067 : : lss_for_tmparray, lhs_type, NULL_TREE,
2068 : : false, true, false,
2069 : : &lhs_expr->where);
2070 : 4 : tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
2071 : 4 : gfc_start_scalarized_body (&loop, &body);
2072 : 4 : gfc_init_se (&se, NULL);
2073 : 4 : gfc_copy_loopinfo_to_se (&se, &loop);
2074 : 4 : se.ss = lss_real;
2075 : 4 : gfc_conv_expr (&se, lhs_expr);
2076 : 4 : gfc_add_block_to_block (&body, &se.pre);
2077 : :
2078 : : /* Walk over all indexes of the loop. */
2079 : 4 : for (n = loop.dimen - 1; n > 0; --n)
2080 : : {
2081 : 0 : tmp = loop.loopvar[n];
2082 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2083 : : gfc_array_index_type, tmp, loop.from[n]);
2084 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
2085 : : gfc_array_index_type, tmp, index);
2086 : :
2087 : 0 : stride = fold_build2_loc (input_location, MINUS_EXPR,
2088 : : gfc_array_index_type,
2089 : 0 : loop.to[n - 1], loop.from[n - 1]);
2090 : 0 : stride = fold_build2_loc (input_location, PLUS_EXPR,
2091 : : gfc_array_index_type,
2092 : : stride, gfc_index_one_node);
2093 : :
2094 : 0 : index = fold_build2_loc (input_location, MULT_EXPR,
2095 : : gfc_array_index_type, tmp, stride);
2096 : : }
2097 : :
2098 : 4 : index = fold_build2_loc (input_location, MINUS_EXPR,
2099 : : gfc_array_index_type,
2100 : : index, loop.from[0]);
2101 : :
2102 : 4 : index = fold_build2_loc (input_location, PLUS_EXPR,
2103 : : gfc_array_index_type,
2104 : : loop.loopvar[0], index);
2105 : :
2106 : 4 : src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
2107 : 4 : src = gfc_build_array_ref (src, index, NULL);
2108 : : /* Now create the assignment of lhs_expr = tmp_array. */
2109 : 4 : gfc_add_modify (&body, se.expr, src);
2110 : 4 : gfc_add_block_to_block (&body, &se.post);
2111 : 4 : lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
2112 : 4 : gfc_trans_scalarizing_loops (&loop, &body);
2113 : 4 : gfc_add_block_to_block (&loop.pre, &loop.post);
2114 : 4 : gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
2115 : 4 : gfc_free_ss (lss_for_tmparray);
2116 : 4 : gfc_free_ss (lss_real);
2117 : : }
2118 : : }
2119 : :
2120 : 528 : lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
2121 : :
2122 : : /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2123 : : temporary and a loop. */
2124 : 528 : if (!gfc_is_coindexed (lhs_expr)
2125 : 528 : && (!lhs_caf_attr.codimension
2126 : 38 : || !(lhs_expr->rank > 0
2127 : 29 : && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
2128 : : {
2129 : 149 : bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
2130 : 149 : gcc_assert (gfc_is_coindexed (rhs_expr));
2131 : 149 : gfc_init_se (&rhs_se, NULL);
2132 : 149 : if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
2133 : : {
2134 : 0 : gfc_se scal_se;
2135 : 0 : gfc_init_se (&scal_se, NULL);
2136 : 0 : scal_se.want_pointer = 1;
2137 : 0 : gfc_conv_expr (&scal_se, lhs_expr);
2138 : : /* Ensure scalar on lhs is allocated. */
2139 : 0 : gfc_add_block_to_block (&block, &scal_se.pre);
2140 : :
2141 : 0 : gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
2142 : 0 : TYPE_SIZE_UNIT (
2143 : : gfc_typenode_for_spec (&lhs_expr->ts)),
2144 : : NULL_TREE);
2145 : 0 : tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,
2146 : : null_pointer_node);
2147 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2148 : : tmp, gfc_finish_block (&scal_se.pre),
2149 : : build_empty_stmt (input_location));
2150 : 0 : gfc_add_expr_to_block (&block, tmp);
2151 : 0 : }
2152 : : else
2153 : 149 : lhs_may_realloc = lhs_may_realloc
2154 : 149 : && gfc_full_array_ref_p (lhs_expr->ref, NULL);
2155 : 149 : gfc_add_block_to_block (&block, &lhs_se.pre);
2156 : 149 : gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
2157 : : may_require_tmp, lhs_may_realloc,
2158 : : &rhs_caf_attr);
2159 : 149 : gfc_add_block_to_block (&block, &rhs_se.pre);
2160 : 149 : gfc_add_block_to_block (&block, &rhs_se.post);
2161 : 149 : gfc_add_block_to_block (&block, &lhs_se.post);
2162 : 149 : return gfc_finish_block (&block);
2163 : : }
2164 : :
2165 : 379 : gfc_add_block_to_block (&block, &lhs_se.pre);
2166 : :
2167 : : /* Obtain token, offset and image index for the LHS. */
2168 : 379 : caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
2169 : 379 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2170 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2171 : 379 : image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
2172 : 379 : tmp = lhs_se.expr;
2173 : 379 : if (lhs_caf_attr.alloc_comp)
2174 : 192 : gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
2175 : : NULL);
2176 : : else
2177 : 187 : gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
2178 : : lhs_expr);
2179 : 379 : lhs_se.expr = tmp;
2180 : :
2181 : : /* RHS. */
2182 : 379 : gfc_init_se (&rhs_se, NULL);
2183 : 379 : if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
2184 : 0 : && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
2185 : 0 : rhs_expr = rhs_expr->value.function.actual->expr;
2186 : 379 : if (rhs_expr->rank == 0)
2187 : : {
2188 : 215 : symbol_attribute attr;
2189 : 215 : gfc_clear_attr (&attr);
2190 : 215 : gfc_conv_expr (&rhs_se, rhs_expr);
2191 : 215 : rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
2192 : 215 : rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
2193 : : }
2194 : 164 : else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2195 : 24 : && rhs_caf_attr.codimension)
2196 : : {
2197 : 24 : tree tmp2;
2198 : 24 : rhs_se.want_pointer = 1;
2199 : 24 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2200 : : /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2201 : : has the wrong type if component references are done. */
2202 : 24 : tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2203 : 24 : tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2204 : 24 : gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2205 : : gfc_get_dtype_rank_type (
2206 : 24 : gfc_has_vector_subscript (rhs_expr)
2207 : 0 : ? gfc_find_array_ref (rhs_expr)->dimen
2208 : : : rhs_expr->rank,
2209 : : tmp2));
2210 : 24 : }
2211 : : else
2212 : : {
2213 : : /* If has_vector, pass descriptor for whole array and the
2214 : : vector bounds separately. */
2215 : 140 : gfc_array_ref *ar, ar2;
2216 : 140 : bool has_vector = false;
2217 : 140 : tree tmp2;
2218 : :
2219 : 140 : if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
2220 : : {
2221 : 0 : has_vector = true;
2222 : 0 : ar = gfc_find_array_ref (rhs_expr);
2223 : 0 : ar2 = *ar;
2224 : 0 : memset (ar, '\0', sizeof (*ar));
2225 : 0 : ar->as = ar2.as;
2226 : 0 : ar->type = AR_FULL;
2227 : : }
2228 : 140 : rhs_se.want_pointer = 1;
2229 : 140 : gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2230 : : /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2231 : : has the wrong type if component references are done. */
2232 : 140 : tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2233 : 140 : tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2234 : 140 : gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2235 : : gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2236 : : : rhs_expr->rank,
2237 : : tmp2));
2238 : 140 : if (has_vector)
2239 : : {
2240 : 0 : rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
2241 : 0 : *ar = ar2;
2242 : : }
2243 : : }
2244 : :
2245 : 379 : gfc_add_block_to_block (&block, &rhs_se.pre);
2246 : :
2247 : 379 : rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
2248 : :
2249 : 379 : tmp_stat = gfc_find_stat_co (lhs_expr);
2250 : :
2251 : 379 : if (tmp_stat)
2252 : : {
2253 : 0 : gfc_se stat_se;
2254 : 0 : gfc_init_se (&stat_se, NULL);
2255 : 0 : gfc_conv_expr_reference (&stat_se, tmp_stat);
2256 : 0 : dst_stat = stat_se.expr;
2257 : 0 : gfc_add_block_to_block (&block, &stat_se.pre);
2258 : 0 : gfc_add_block_to_block (&block, &stat_se.post);
2259 : : }
2260 : :
2261 : 379 : tmp_team = gfc_find_team_co (lhs_expr);
2262 : :
2263 : 379 : if (tmp_team)
2264 : : {
2265 : 0 : gfc_se team_se;
2266 : 0 : gfc_init_se (&team_se, NULL);
2267 : 0 : gfc_conv_expr_reference (&team_se, tmp_team);
2268 : 0 : dst_team = team_se.expr;
2269 : 0 : gfc_add_block_to_block (&block, &team_se.pre);
2270 : 0 : gfc_add_block_to_block (&block, &team_se.post);
2271 : : }
2272 : :
2273 : 379 : if (!gfc_is_coindexed (rhs_expr))
2274 : : {
2275 : 289 : if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
2276 : : {
2277 : 222 : tree reference, dst_realloc;
2278 : 222 : reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2279 : 222 : dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node
2280 : : : boolean_false_node;
2281 : 222 : tmp = build_call_expr_loc (input_location,
2282 : : gfor_fndecl_caf_send_by_ref,
2283 : : 10, token, image_index, rhs_se.expr,
2284 : : reference, lhs_kind, rhs_kind,
2285 : : may_require_tmp, dst_realloc, src_stat,
2286 : : build_int_cst (integer_type_node,
2287 : 222 : lhs_expr->ts.type));
2288 : : }
2289 : : else
2290 : 67 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
2291 : : token, offset, image_index, lhs_se.expr, vec,
2292 : : rhs_se.expr, lhs_kind, rhs_kind,
2293 : : may_require_tmp, src_stat, dst_team);
2294 : : }
2295 : : else
2296 : : {
2297 : 90 : tree rhs_token, rhs_offset, rhs_image_index;
2298 : :
2299 : : /* It guarantees memory consistency within the same segment. */
2300 : 90 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2301 : 90 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2302 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2303 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2304 : 90 : ASM_VOLATILE_P (tmp) = 1;
2305 : 90 : gfc_add_expr_to_block (&block, tmp);
2306 : :
2307 : 90 : caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
2308 : 90 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2309 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2310 : 90 : rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
2311 : 90 : tmp = rhs_se.expr;
2312 : 90 : if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2313 : : {
2314 : 48 : tmp_stat = gfc_find_stat_co (lhs_expr);
2315 : :
2316 : 48 : if (tmp_stat)
2317 : : {
2318 : 0 : gfc_se stat_se;
2319 : 0 : gfc_init_se (&stat_se, NULL);
2320 : 0 : gfc_conv_expr_reference (&stat_se, tmp_stat);
2321 : 0 : src_stat = stat_se.expr;
2322 : 0 : gfc_add_block_to_block (&block, &stat_se.pre);
2323 : 0 : gfc_add_block_to_block (&block, &stat_se.post);
2324 : : }
2325 : :
2326 : 48 : gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
2327 : : NULL_TREE, NULL);
2328 : 48 : tree lhs_reference, rhs_reference;
2329 : 48 : lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2330 : 48 : rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
2331 : 48 : tmp = build_call_expr_loc (input_location,
2332 : : gfor_fndecl_caf_sendget_by_ref, 13,
2333 : : token, image_index, lhs_reference,
2334 : : rhs_token, rhs_image_index, rhs_reference,
2335 : : lhs_kind, rhs_kind, may_require_tmp,
2336 : : dst_stat, src_stat,
2337 : : build_int_cst (integer_type_node,
2338 : 48 : lhs_expr->ts.type),
2339 : : build_int_cst (integer_type_node,
2340 : 48 : rhs_expr->ts.type));
2341 : : }
2342 : : else
2343 : : {
2344 : 42 : gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
2345 : : tmp, rhs_expr);
2346 : 42 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
2347 : : 14, token, offset, image_index,
2348 : : lhs_se.expr, vec, rhs_token, rhs_offset,
2349 : : rhs_image_index, tmp, rhs_vec, lhs_kind,
2350 : : rhs_kind, may_require_tmp, src_stat);
2351 : : }
2352 : : }
2353 : 379 : gfc_add_expr_to_block (&block, tmp);
2354 : 379 : gfc_add_block_to_block (&block, &lhs_se.post);
2355 : 379 : gfc_add_block_to_block (&block, &rhs_se.post);
2356 : :
2357 : : /* It guarantees memory consistency within the same segment. */
2358 : 379 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2359 : 379 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2360 : : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2361 : : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2362 : 379 : ASM_VOLATILE_P (tmp) = 1;
2363 : 379 : gfc_add_expr_to_block (&block, tmp);
2364 : :
2365 : 379 : return gfc_finish_block (&block);
2366 : : }
2367 : :
2368 : :
2369 : : static void
2370 : 637 : trans_this_image (gfc_se * se, gfc_expr *expr)
2371 : : {
2372 : 637 : stmtblock_t loop;
2373 : 637 : tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
2374 : : lbound, ubound, extent, ml;
2375 : 637 : gfc_se argse;
2376 : 637 : int rank, corank;
2377 : 637 : gfc_expr *distance = expr->value.function.actual->next->next->expr;
2378 : :
2379 : 637 : if (expr->value.function.actual->expr
2380 : 637 : && !gfc_is_coarray (expr->value.function.actual->expr))
2381 : 1 : distance = expr->value.function.actual->expr;
2382 : :
2383 : : /* The case -fcoarray=single is handled elsewhere. */
2384 : 637 : gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
2385 : :
2386 : : /* Argument-free version: THIS_IMAGE(). */
2387 : 637 : if (distance || expr->value.function.actual->expr == NULL)
2388 : : {
2389 : 491 : if (distance)
2390 : : {
2391 : 2 : gfc_init_se (&argse, NULL);
2392 : 2 : gfc_conv_expr_val (&argse, distance);
2393 : 2 : gfc_add_block_to_block (&se->pre, &argse.pre);
2394 : 2 : gfc_add_block_to_block (&se->post, &argse.post);
2395 : 2 : tmp = fold_convert (integer_type_node, argse.expr);
2396 : : }
2397 : : else
2398 : 491 : tmp = integer_zero_node;
2399 : 493 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2400 : : tmp);
2401 : 493 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2402 : : tmp);
2403 : 497 : return;
2404 : : }
2405 : :
2406 : : /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2407 : :
2408 : 144 : type = gfc_get_int_type (gfc_default_integer_kind);
2409 : 144 : corank = gfc_get_corank (expr->value.function.actual->expr);
2410 : 144 : rank = expr->value.function.actual->expr->rank;
2411 : :
2412 : : /* Obtain the descriptor of the COARRAY. */
2413 : 144 : gfc_init_se (&argse, NULL);
2414 : 144 : argse.want_coarray = 1;
2415 : 144 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2416 : 144 : gfc_add_block_to_block (&se->pre, &argse.pre);
2417 : 144 : gfc_add_block_to_block (&se->post, &argse.post);
2418 : 144 : desc = argse.expr;
2419 : :
2420 : 144 : if (se->ss)
2421 : : {
2422 : : /* Create an implicit second parameter from the loop variable. */
2423 : 28 : gcc_assert (!expr->value.function.actual->next->expr);
2424 : 28 : gcc_assert (corank > 0);
2425 : 28 : gcc_assert (se->loop->dimen == 1);
2426 : 28 : gcc_assert (se->ss->info->expr == expr);
2427 : :
2428 : 28 : dim_arg = se->loop->loopvar[0];
2429 : 28 : dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
2430 : : gfc_array_index_type, dim_arg,
2431 : 28 : build_int_cst (TREE_TYPE (dim_arg), 1));
2432 : 28 : gfc_advance_se_ss_chain (se);
2433 : : }
2434 : : else
2435 : : {
2436 : : /* Use the passed DIM= argument. */
2437 : 116 : gcc_assert (expr->value.function.actual->next->expr);
2438 : 116 : gfc_init_se (&argse, NULL);
2439 : 116 : gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
2440 : : gfc_array_index_type);
2441 : 116 : gfc_add_block_to_block (&se->pre, &argse.pre);
2442 : 116 : dim_arg = argse.expr;
2443 : :
2444 : 116 : if (INTEGER_CST_P (dim_arg))
2445 : : {
2446 : 58 : if (wi::ltu_p (wi::to_wide (dim_arg), 1)
2447 : 116 : || wi::gtu_p (wi::to_wide (dim_arg),
2448 : 58 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2449 : 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2450 : 0 : "dimension index", expr->value.function.isym->name,
2451 : : &expr->where);
2452 : : }
2453 : 58 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2454 : : {
2455 : 0 : dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
2456 : 0 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2457 : : dim_arg,
2458 : 0 : build_int_cst (TREE_TYPE (dim_arg), 1));
2459 : 0 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2460 : 0 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2461 : : dim_arg, tmp);
2462 : 0 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2463 : : logical_type_node, cond, tmp);
2464 : 0 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2465 : : gfc_msg_fault);
2466 : : }
2467 : : }
2468 : :
2469 : : /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2470 : : one always has a dim_arg argument.
2471 : :
2472 : : m = this_image() - 1
2473 : : if (corank == 1)
2474 : : {
2475 : : sub(1) = m + lcobound(corank)
2476 : : return;
2477 : : }
2478 : : i = rank
2479 : : min_var = min (rank + corank - 2, rank + dim_arg - 1)
2480 : : for (;;)
2481 : : {
2482 : : extent = gfc_extent(i)
2483 : : ml = m
2484 : : m = m/extent
2485 : : if (i >= min_var)
2486 : : goto exit_label
2487 : : i++
2488 : : }
2489 : : exit_label:
2490 : : sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2491 : : : m + lcobound(corank)
2492 : : */
2493 : :
2494 : : /* this_image () - 1. */
2495 : 144 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2496 : : integer_zero_node);
2497 : 144 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
2498 : 144 : fold_convert (type, tmp), build_int_cst (type, 1));
2499 : 144 : if (corank == 1)
2500 : : {
2501 : : /* sub(1) = m + lcobound(corank). */
2502 : 4 : lbound = gfc_conv_descriptor_lbound_get (desc,
2503 : 4 : build_int_cst (TREE_TYPE (gfc_array_index_type),
2504 : 4 : corank+rank-1));
2505 : 4 : lbound = fold_convert (type, lbound);
2506 : 4 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2507 : :
2508 : 4 : se->expr = tmp;
2509 : 4 : return;
2510 : : }
2511 : :
2512 : 140 : m = gfc_create_var (type, NULL);
2513 : 140 : ml = gfc_create_var (type, NULL);
2514 : 140 : loop_var = gfc_create_var (integer_type_node, NULL);
2515 : 140 : min_var = gfc_create_var (integer_type_node, NULL);
2516 : :
2517 : : /* m = this_image () - 1. */
2518 : 140 : gfc_add_modify (&se->pre, m, tmp);
2519 : :
2520 : : /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2521 : 140 : tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2522 : : fold_convert (integer_type_node, dim_arg),
2523 : 140 : build_int_cst (integer_type_node, rank - 1));
2524 : 140 : tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
2525 : 140 : build_int_cst (integer_type_node, rank + corank - 2),
2526 : : tmp);
2527 : 140 : gfc_add_modify (&se->pre, min_var, tmp);
2528 : :
2529 : : /* i = rank. */
2530 : 140 : tmp = build_int_cst (integer_type_node, rank);
2531 : 140 : gfc_add_modify (&se->pre, loop_var, tmp);
2532 : :
2533 : 140 : exit_label = gfc_build_label_decl (NULL_TREE);
2534 : 140 : TREE_USED (exit_label) = 1;
2535 : :
2536 : : /* Loop body. */
2537 : 140 : gfc_init_block (&loop);
2538 : :
2539 : : /* ml = m. */
2540 : 140 : gfc_add_modify (&loop, ml, m);
2541 : :
2542 : : /* extent = ... */
2543 : 140 : lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
2544 : 140 : ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
2545 : 140 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2546 : 140 : extent = fold_convert (type, extent);
2547 : :
2548 : : /* m = m/extent. */
2549 : 140 : gfc_add_modify (&loop, m,
2550 : : fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2551 : : m, extent));
2552 : :
2553 : : /* Exit condition: if (i >= min_var) goto exit_label. */
2554 : 140 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2555 : : min_var);
2556 : 140 : tmp = build1_v (GOTO_EXPR, exit_label);
2557 : 140 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2558 : : build_empty_stmt (input_location));
2559 : 140 : gfc_add_expr_to_block (&loop, tmp);
2560 : :
2561 : : /* Increment loop variable: i++. */
2562 : 140 : gfc_add_modify (&loop, loop_var,
2563 : : fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2564 : : loop_var,
2565 : : integer_one_node));
2566 : :
2567 : : /* Making the loop... actually loop! */
2568 : 140 : tmp = gfc_finish_block (&loop);
2569 : 140 : tmp = build1_v (LOOP_EXPR, tmp);
2570 : 140 : gfc_add_expr_to_block (&se->pre, tmp);
2571 : :
2572 : : /* The exit label. */
2573 : 140 : tmp = build1_v (LABEL_EXPR, exit_label);
2574 : 140 : gfc_add_expr_to_block (&se->pre, tmp);
2575 : :
2576 : : /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2577 : : : m + lcobound(corank) */
2578 : :
2579 : 140 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2580 : 140 : build_int_cst (TREE_TYPE (dim_arg), corank));
2581 : :
2582 : 140 : lbound = gfc_conv_descriptor_lbound_get (desc,
2583 : : fold_build2_loc (input_location, PLUS_EXPR,
2584 : : gfc_array_index_type, dim_arg,
2585 : 140 : build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2586 : 140 : lbound = fold_convert (type, lbound);
2587 : :
2588 : 140 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2589 : : fold_build2_loc (input_location, MULT_EXPR, type,
2590 : : m, extent));
2591 : 140 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2592 : :
2593 : 140 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2594 : : fold_build2_loc (input_location, PLUS_EXPR, type,
2595 : : m, lbound));
2596 : : }
2597 : :
2598 : :
2599 : : /* Convert a call to image_status. */
2600 : :
2601 : : static void
2602 : 16 : conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2603 : : {
2604 : 16 : unsigned int num_args;
2605 : 16 : tree *args, tmp;
2606 : :
2607 : 16 : num_args = gfc_intrinsic_argument_list_length (expr);
2608 : 16 : args = XALLOCAVEC (tree, num_args);
2609 : 16 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2610 : : /* In args[0] the number of the image the status is desired for has to be
2611 : : given. */
2612 : :
2613 : 16 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2614 : : {
2615 : 0 : tree arg;
2616 : 0 : arg = gfc_evaluate_now (args[0], &se->pre);
2617 : 0 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2618 : : fold_convert (integer_type_node, arg),
2619 : : integer_one_node);
2620 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2621 : : tmp, integer_zero_node,
2622 : : build_int_cst (integer_type_node,
2623 : 0 : GFC_STAT_STOPPED_IMAGE));
2624 : : }
2625 : 16 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2626 : 16 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2627 : 16 : args[0], build_int_cst (integer_type_node, -1));
2628 : : else
2629 : 0 : gcc_unreachable ();
2630 : :
2631 : 16 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2632 : 16 : }
2633 : :
2634 : : static void
2635 : 31 : conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2636 : : {
2637 : 31 : unsigned int num_args;
2638 : :
2639 : 31 : tree *args, tmp;
2640 : :
2641 : 31 : num_args = gfc_intrinsic_argument_list_length (expr);
2642 : 31 : args = XALLOCAVEC (tree, num_args);
2643 : 31 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2644 : :
2645 : 31 : if (flag_coarray ==
2646 : 30 : GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2647 : : {
2648 : 0 : tree arg;
2649 : :
2650 : 0 : arg = gfc_evaluate_now (args[0], &se->pre);
2651 : 0 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2652 : : fold_convert (integer_type_node, arg),
2653 : : integer_one_node);
2654 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2655 : : tmp, integer_zero_node,
2656 : : build_int_cst (integer_type_node,
2657 : 0 : GFC_STAT_STOPPED_IMAGE));
2658 : 0 : }
2659 : 31 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2660 : : {
2661 : : // the value -1 represents that no team has been created yet
2662 : 30 : tmp = build_int_cst (integer_type_node, -1);
2663 : : }
2664 : 1 : else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2665 : 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2666 : 0 : args[0], build_int_cst (integer_type_node, -1));
2667 : 1 : else if (flag_coarray == GFC_FCOARRAY_LIB)
2668 : 1 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2669 : 1 : integer_zero_node, build_int_cst (integer_type_node, -1));
2670 : : else
2671 : 0 : gcc_unreachable ();
2672 : :
2673 : 31 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2674 : 31 : }
2675 : :
2676 : :
2677 : : static void
2678 : 152 : trans_image_index (gfc_se * se, gfc_expr *expr)
2679 : : {
2680 : 152 : tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
2681 : : tmp, invalid_bound;
2682 : 152 : gfc_se argse, subse;
2683 : 152 : int rank, corank, codim;
2684 : :
2685 : 152 : type = gfc_get_int_type (gfc_default_integer_kind);
2686 : 152 : corank = gfc_get_corank (expr->value.function.actual->expr);
2687 : 152 : rank = expr->value.function.actual->expr->rank;
2688 : :
2689 : : /* Obtain the descriptor of the COARRAY. */
2690 : 152 : gfc_init_se (&argse, NULL);
2691 : 152 : argse.want_coarray = 1;
2692 : 152 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2693 : 152 : gfc_add_block_to_block (&se->pre, &argse.pre);
2694 : 152 : gfc_add_block_to_block (&se->post, &argse.post);
2695 : 152 : desc = argse.expr;
2696 : :
2697 : : /* Obtain a handle to the SUB argument. */
2698 : 152 : gfc_init_se (&subse, NULL);
2699 : 152 : gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2700 : 152 : gfc_add_block_to_block (&se->pre, &subse.pre);
2701 : 152 : gfc_add_block_to_block (&se->post, &subse.post);
2702 : 152 : subdesc = build_fold_indirect_ref_loc (input_location,
2703 : : gfc_conv_descriptor_data_get (subse.expr));
2704 : :
2705 : : /* Fortran 2008 does not require that the values remain in the cobounds,
2706 : : thus we need explicitly check this - and return 0 if they are exceeded. */
2707 : :
2708 : 152 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2709 : 152 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2710 : 152 : invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2711 : : fold_convert (gfc_array_index_type, tmp),
2712 : : lbound);
2713 : :
2714 : 352 : for (codim = corank + rank - 2; codim >= rank; codim--)
2715 : : {
2716 : 200 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2717 : 200 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2718 : 200 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2719 : 200 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2720 : : fold_convert (gfc_array_index_type, tmp),
2721 : : lbound);
2722 : 200 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2723 : : logical_type_node, invalid_bound, cond);
2724 : 200 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2725 : : fold_convert (gfc_array_index_type, tmp),
2726 : : ubound);
2727 : 200 : invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2728 : : logical_type_node, invalid_bound, cond);
2729 : : }
2730 : :
2731 : 152 : invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2732 : :
2733 : : /* See Fortran 2008, C.10 for the following algorithm. */
2734 : :
2735 : : /* coindex = sub(corank) - lcobound(n). */
2736 : 152 : coindex = fold_convert (gfc_array_index_type,
2737 : : gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2738 : : NULL));
2739 : 152 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2740 : 152 : coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2741 : : fold_convert (gfc_array_index_type, coindex),
2742 : : lbound);
2743 : :
2744 : 352 : for (codim = corank + rank - 2; codim >= rank; codim--)
2745 : : {
2746 : 200 : tree extent, ubound;
2747 : :
2748 : : /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2749 : 200 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2750 : 200 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2751 : 200 : extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2752 : :
2753 : : /* coindex *= extent. */
2754 : 200 : coindex = fold_build2_loc (input_location, MULT_EXPR,
2755 : : gfc_array_index_type, coindex, extent);
2756 : :
2757 : : /* coindex += sub(codim). */
2758 : 200 : tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2759 : 200 : coindex = fold_build2_loc (input_location, PLUS_EXPR,
2760 : : gfc_array_index_type, coindex,
2761 : : fold_convert (gfc_array_index_type, tmp));
2762 : :
2763 : : /* coindex -= lbound(codim). */
2764 : 200 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2765 : 200 : coindex = fold_build2_loc (input_location, MINUS_EXPR,
2766 : : gfc_array_index_type, coindex, lbound);
2767 : : }
2768 : :
2769 : 152 : coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2770 : : fold_convert(type, coindex),
2771 : 152 : build_int_cst (type, 1));
2772 : :
2773 : : /* Return 0 if "coindex" exceeds num_images(). */
2774 : :
2775 : 152 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
2776 : 108 : num_images = build_int_cst (type, 1);
2777 : : else
2778 : : {
2779 : 44 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2780 : : integer_zero_node,
2781 : 44 : build_int_cst (integer_type_node, -1));
2782 : 44 : num_images = fold_convert (type, tmp);
2783 : : }
2784 : :
2785 : 152 : tmp = gfc_create_var (type, NULL);
2786 : 152 : gfc_add_modify (&se->pre, tmp, coindex);
2787 : :
2788 : 152 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2789 : : num_images);
2790 : 152 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2791 : : cond,
2792 : : fold_convert (logical_type_node, invalid_bound));
2793 : 152 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2794 : 152 : build_int_cst (type, 0), tmp);
2795 : 152 : }
2796 : :
2797 : : static void
2798 : 395 : trans_num_images (gfc_se * se, gfc_expr *expr)
2799 : : {
2800 : 395 : tree tmp, distance, failed;
2801 : 395 : gfc_se argse;
2802 : :
2803 : 395 : if (expr->value.function.actual->expr)
2804 : : {
2805 : 3 : gfc_init_se (&argse, NULL);
2806 : 3 : gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2807 : 3 : gfc_add_block_to_block (&se->pre, &argse.pre);
2808 : 3 : gfc_add_block_to_block (&se->post, &argse.post);
2809 : 3 : distance = fold_convert (integer_type_node, argse.expr);
2810 : : }
2811 : : else
2812 : 392 : distance = integer_zero_node;
2813 : :
2814 : 395 : if (expr->value.function.actual->next->expr)
2815 : : {
2816 : 2 : gfc_init_se (&argse, NULL);
2817 : 2 : gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
2818 : 2 : gfc_add_block_to_block (&se->pre, &argse.pre);
2819 : 2 : gfc_add_block_to_block (&se->post, &argse.post);
2820 : 2 : failed = fold_convert (integer_type_node, argse.expr);
2821 : : }
2822 : : else
2823 : 393 : failed = build_int_cst (integer_type_node, -1);
2824 : 395 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2825 : : distance, failed);
2826 : 395 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2827 : 395 : }
2828 : :
2829 : :
2830 : : static void
2831 : 9726 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2832 : : {
2833 : 9726 : gfc_se argse;
2834 : :
2835 : 9726 : gfc_init_se (&argse, NULL);
2836 : 9726 : argse.data_not_needed = 1;
2837 : 9726 : argse.descriptor_only = 1;
2838 : :
2839 : 9726 : gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2840 : 9726 : gfc_add_block_to_block (&se->pre, &argse.pre);
2841 : 9726 : gfc_add_block_to_block (&se->post, &argse.post);
2842 : :
2843 : 9726 : se->expr = gfc_conv_descriptor_rank (argse.expr);
2844 : 9726 : se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2845 : : se->expr);
2846 : 9726 : }
2847 : :
2848 : :
2849 : : static void
2850 : 621 : gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2851 : : {
2852 : 621 : gfc_expr *arg;
2853 : 621 : arg = expr->value.function.actual->expr;
2854 : 621 : gfc_conv_is_contiguous_expr (se, arg);
2855 : 621 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2856 : 621 : }
2857 : :
2858 : : /* This function does the work for gfc_conv_intrinsic_is_contiguous,
2859 : : plus it can be called directly. */
2860 : :
2861 : : void
2862 : 1938 : gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
2863 : : {
2864 : 1938 : gfc_ss *ss;
2865 : 1938 : gfc_se argse;
2866 : 1938 : tree desc, tmp, stride, extent, cond;
2867 : 1938 : int i;
2868 : 1938 : tree fncall0;
2869 : 1938 : gfc_array_spec *as;
2870 : :
2871 : 1938 : if (arg->ts.type == BT_CLASS)
2872 : 36 : gfc_add_class_array_ref (arg);
2873 : :
2874 : 1938 : ss = gfc_walk_expr (arg);
2875 : 1938 : gcc_assert (ss != gfc_ss_terminator);
2876 : 1938 : gfc_init_se (&argse, NULL);
2877 : 1938 : argse.data_not_needed = 1;
2878 : 1938 : gfc_conv_expr_descriptor (&argse, arg);
2879 : :
2880 : 1938 : as = gfc_get_full_arrayspec_from_expr (arg);
2881 : :
2882 : : /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2883 : : Note in addition that zero-sized arrays don't count as contiguous. */
2884 : :
2885 : 1938 : if (as && as->type == AS_ASSUMED_RANK)
2886 : : {
2887 : : /* Build the call to is_contiguous0. */
2888 : 243 : argse.want_pointer = 1;
2889 : 243 : gfc_conv_expr_descriptor (&argse, arg);
2890 : 243 : gfc_add_block_to_block (&se->pre, &argse.pre);
2891 : 243 : gfc_add_block_to_block (&se->post, &argse.post);
2892 : 243 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2893 : 243 : fncall0 = build_call_expr_loc (input_location,
2894 : : gfor_fndecl_is_contiguous0, 1, desc);
2895 : 243 : se->expr = fncall0;
2896 : 243 : se->expr = convert (logical_type_node, se->expr);
2897 : : }
2898 : : else
2899 : : {
2900 : 1695 : gfc_add_block_to_block (&se->pre, &argse.pre);
2901 : 1695 : gfc_add_block_to_block (&se->post, &argse.post);
2902 : 1695 : desc = gfc_evaluate_now (argse.expr, &se->pre);
2903 : :
2904 : 1695 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2905 : 1695 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2906 : 1695 : stride, build_int_cst (TREE_TYPE (stride), 1));
2907 : :
2908 : 2017 : for (i = 0; i < arg->rank - 1; i++)
2909 : : {
2910 : 322 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2911 : 322 : extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2912 : 322 : extent = fold_build2_loc (input_location, MINUS_EXPR,
2913 : : gfc_array_index_type, extent, tmp);
2914 : 322 : extent = fold_build2_loc (input_location, PLUS_EXPR,
2915 : : gfc_array_index_type, extent,
2916 : : gfc_index_one_node);
2917 : 322 : tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2918 : 322 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2919 : : tmp, extent);
2920 : 322 : stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2921 : 322 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2922 : : stride, tmp);
2923 : 322 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2924 : : boolean_type_node, cond, tmp);
2925 : : }
2926 : 1695 : se->expr = cond;
2927 : : }
2928 : 1938 : }
2929 : :
2930 : :
2931 : : /* Evaluate a single upper or lower bound. */
2932 : : /* TODO: bound intrinsic generates way too much unnecessary code. */
2933 : :
2934 : : static void
2935 : 12976 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
2936 : : {
2937 : 12976 : gfc_actual_arglist *arg;
2938 : 12976 : gfc_actual_arglist *arg2;
2939 : 12976 : tree desc;
2940 : 12976 : tree type;
2941 : 12976 : tree bound;
2942 : 12976 : tree tmp;
2943 : 12976 : tree cond, cond1;
2944 : 12976 : tree ubound;
2945 : 12976 : tree lbound;
2946 : 12976 : tree size;
2947 : 12976 : gfc_se argse;
2948 : 12976 : gfc_array_spec * as;
2949 : 12976 : bool assumed_rank_lb_one;
2950 : :
2951 : 12976 : arg = expr->value.function.actual;
2952 : 12976 : arg2 = arg->next;
2953 : :
2954 : 12976 : if (se->ss)
2955 : : {
2956 : : /* Create an implicit second parameter from the loop variable. */
2957 : 4763 : gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
2958 : 4763 : gcc_assert (se->loop->dimen == 1);
2959 : 4763 : gcc_assert (se->ss->info->expr == expr);
2960 : 4763 : gfc_advance_se_ss_chain (se);
2961 : 4763 : bound = se->loop->loopvar[0];
2962 : 4763 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2963 : : gfc_array_index_type, bound,
2964 : : se->loop->from[0]);
2965 : : }
2966 : : else
2967 : : {
2968 : : /* use the passed argument. */
2969 : 8213 : gcc_assert (arg2->expr);
2970 : 8213 : gfc_init_se (&argse, NULL);
2971 : 8213 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2972 : 8213 : gfc_add_block_to_block (&se->pre, &argse.pre);
2973 : 8213 : bound = argse.expr;
2974 : : /* Convert from one based to zero based. */
2975 : 8213 : bound = fold_build2_loc (input_location, MINUS_EXPR,
2976 : : gfc_array_index_type, bound,
2977 : : gfc_index_one_node);
2978 : : }
2979 : :
2980 : : /* TODO: don't re-evaluate the descriptor on each iteration. */
2981 : : /* Get a descriptor for the first parameter. */
2982 : 12976 : gfc_init_se (&argse, NULL);
2983 : 12976 : gfc_conv_expr_descriptor (&argse, arg->expr);
2984 : 12976 : gfc_add_block_to_block (&se->pre, &argse.pre);
2985 : 12976 : gfc_add_block_to_block (&se->post, &argse.post);
2986 : :
2987 : 12976 : desc = argse.expr;
2988 : :
2989 : 12976 : as = gfc_get_full_arrayspec_from_expr (arg->expr);
2990 : :
2991 : 12976 : if (INTEGER_CST_P (bound))
2992 : : {
2993 : 8093 : gcc_assert (op != GFC_ISYM_SHAPE);
2994 : 7856 : if (((!as || as->type != AS_ASSUMED_RANK)
2995 : 7233 : && wi::geu_p (wi::to_wide (bound),
2996 : 7233 : GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2997 : 16186 : || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2998 : 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2999 : : "dimension index",
3000 : : (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
3001 : : &expr->where);
3002 : : }
3003 : :
3004 : 12976 : if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
3005 : : {
3006 : 5743 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3007 : : {
3008 : 639 : bound = gfc_evaluate_now (bound, &se->pre);
3009 : 639 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3010 : 639 : bound, build_int_cst (TREE_TYPE (bound), 0));
3011 : 639 : if (as && as->type == AS_ASSUMED_RANK)
3012 : 546 : tmp = gfc_conv_descriptor_rank (desc);
3013 : : else
3014 : 93 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
3015 : 639 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3016 : 639 : bound, fold_convert(TREE_TYPE (bound), tmp));
3017 : 639 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3018 : : logical_type_node, cond, tmp);
3019 : 639 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3020 : : gfc_msg_fault);
3021 : : }
3022 : : }
3023 : :
3024 : : /* Take care of the lbound shift for assumed-rank arrays that are
3025 : : nonallocatable and nonpointers. Those have a lbound of 1. */
3026 : 12500 : assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
3027 : 7820 : && ((arg->expr->ts.type != BT_CLASS
3028 : 1909 : && !arg->expr->symtree->n.sym->attr.allocatable
3029 : 1909 : && !arg->expr->symtree->n.sym->attr.pointer)
3030 : 890 : || (arg->expr->ts.type == BT_CLASS
3031 : 168 : && !CLASS_DATA (arg->expr)->attr.allocatable
3032 : 168 : && !CLASS_DATA (arg->expr)->attr.class_pointer));
3033 : :
3034 : 12976 : ubound = gfc_conv_descriptor_ubound_get (desc, bound);
3035 : 12976 : lbound = gfc_conv_descriptor_lbound_get (desc, bound);
3036 : 12976 : size = fold_build2_loc (input_location, MINUS_EXPR,
3037 : : gfc_array_index_type, ubound, lbound);
3038 : 12976 : size = fold_build2_loc (input_location, PLUS_EXPR,
3039 : : gfc_array_index_type, size, gfc_index_one_node);
3040 : :
3041 : : /* 13.14.53: Result value for LBOUND
3042 : :
3043 : : Case (i): For an array section or for an array expression other than a
3044 : : whole array or array structure component, LBOUND(ARRAY, DIM)
3045 : : has the value 1. For a whole array or array structure
3046 : : component, LBOUND(ARRAY, DIM) has the value:
3047 : : (a) equal to the lower bound for subscript DIM of ARRAY if
3048 : : dimension DIM of ARRAY does not have extent zero
3049 : : or if ARRAY is an assumed-size array of rank DIM,
3050 : : or (b) 1 otherwise.
3051 : :
3052 : : 13.14.113: Result value for UBOUND
3053 : :
3054 : : Case (i): For an array section or for an array expression other than a
3055 : : whole array or array structure component, UBOUND(ARRAY, DIM)
3056 : : has the value equal to the number of elements in the given
3057 : : dimension; otherwise, it has a value equal to the upper bound
3058 : : for subscript DIM of ARRAY if dimension DIM of ARRAY does
3059 : : not have size zero and has value zero if dimension DIM has
3060 : : size zero. */
3061 : :
3062 : 12976 : if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
3063 : 520 : se->expr = gfc_index_one_node;
3064 : 12456 : else if (as)
3065 : : {
3066 : 11980 : if (op == GFC_ISYM_UBOUND)
3067 : : {
3068 : 5159 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3069 : : size, gfc_index_zero_node);
3070 : 9726 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3071 : : gfc_array_index_type, cond,
3072 : : (assumed_rank_lb_one ? size : ubound),
3073 : : gfc_index_zero_node);
3074 : : }
3075 : 6821 : else if (op == GFC_ISYM_LBOUND)
3076 : : {
3077 : 4865 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3078 : : size, gfc_index_zero_node);
3079 : 4865 : if (as->type == AS_ASSUMED_SIZE)
3080 : : {
3081 : 98 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
3082 : : logical_type_node, bound,
3083 : 98 : build_int_cst (TREE_TYPE (bound),
3084 : 98 : arg->expr->rank - 1));
3085 : 98 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3086 : : logical_type_node, cond, cond1);
3087 : : }
3088 : 4865 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3089 : : gfc_array_index_type, cond,
3090 : : lbound, gfc_index_one_node);
3091 : : }
3092 : 1956 : else if (op == GFC_ISYM_SHAPE)
3093 : 1956 : se->expr = size;
3094 : : else
3095 : 0 : gcc_unreachable ();
3096 : :
3097 : : /* According to F2018 16.9.172, para 5, an assumed rank object,
3098 : : argument associated with and assumed size array, has the ubound
3099 : : of the final dimension set to -1 and UBOUND must return this.
3100 : : Similarly for the SHAPE intrinsic. */
3101 : 11980 : if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
3102 : : {
3103 : 763 : tree minus_one = build_int_cst (gfc_array_index_type, -1);
3104 : 763 : tree rank = fold_convert (gfc_array_index_type,
3105 : : gfc_conv_descriptor_rank (desc));
3106 : 763 : rank = fold_build2_loc (input_location, PLUS_EXPR,
3107 : : gfc_array_index_type, rank, minus_one);
3108 : :
3109 : : /* Fix the expression to stop it from becoming even more
3110 : : complicated. */
3111 : 763 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
3112 : :
3113 : : /* Descriptors for assumed-size arrays have ubound = -1
3114 : : in the last dimension. */
3115 : 763 : cond1 = fold_build2_loc (input_location, EQ_EXPR,
3116 : : logical_type_node, ubound, minus_one);
3117 : 763 : cond = fold_build2_loc (input_location, EQ_EXPR,
3118 : : logical_type_node, bound, rank);
3119 : 763 : cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3120 : : logical_type_node, cond, cond1);
3121 : 763 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3122 : : gfc_array_index_type, cond,
3123 : : minus_one, se->expr);
3124 : : }
3125 : : }
3126 : : else /* as is null; this is an old-fashioned 1-based array. */
3127 : : {
3128 : 476 : if (op != GFC_ISYM_LBOUND)
3129 : : {
3130 : 374 : se->expr = fold_build2_loc (input_location, MAX_EXPR,
3131 : : gfc_array_index_type, size,
3132 : : gfc_index_zero_node);
3133 : : }
3134 : : else
3135 : 102 : se->expr = gfc_index_one_node;
3136 : : }
3137 : :
3138 : :
3139 : 12976 : type = gfc_typenode_for_spec (&expr->ts);
3140 : 12976 : se->expr = convert (type, se->expr);
3141 : 12976 : }
3142 : :
3143 : :
3144 : : static void
3145 : 569 : conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
3146 : : {
3147 : 569 : gfc_actual_arglist *arg;
3148 : 569 : gfc_actual_arglist *arg2;
3149 : 569 : gfc_se argse;
3150 : 569 : tree bound, resbound, resbound2, desc, cond, tmp;
3151 : 569 : tree type;
3152 : 569 : int corank;
3153 : :
3154 : 569 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
3155 : : || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
3156 : : || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
3157 : :
3158 : 569 : arg = expr->value.function.actual;
3159 : 569 : arg2 = arg->next;
3160 : :
3161 : 569 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
3162 : 569 : corank = gfc_get_corank (arg->expr);
3163 : :
3164 : 569 : gfc_init_se (&argse, NULL);
3165 : 569 : argse.want_coarray = 1;
3166 : :
3167 : 569 : gfc_conv_expr_descriptor (&argse, arg->expr);
3168 : 569 : gfc_add_block_to_block (&se->pre, &argse.pre);
3169 : 569 : gfc_add_block_to_block (&se->post, &argse.post);
3170 : 569 : desc = argse.expr;
3171 : :
3172 : 569 : if (se->ss)
3173 : : {
3174 : : /* Create an implicit second parameter from the loop variable. */
3175 : 179 : gcc_assert (!arg2->expr);
3176 : 179 : gcc_assert (corank > 0);
3177 : 179 : gcc_assert (se->loop->dimen == 1);
3178 : 179 : gcc_assert (se->ss->info->expr == expr);
3179 : :
3180 : 179 : bound = se->loop->loopvar[0];
3181 : 358 : bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3182 : 179 : bound, gfc_rank_cst[arg->expr->rank]);
3183 : 179 : gfc_advance_se_ss_chain (se);
3184 : : }
3185 : : else
3186 : : {
3187 : : /* use the passed argument. */
3188 : 390 : gcc_assert (arg2->expr);
3189 : 390 : gfc_init_se (&argse, NULL);
3190 : 390 : gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
3191 : 390 : gfc_add_block_to_block (&se->pre, &argse.pre);
3192 : 390 : bound = argse.expr;
3193 : :
3194 : 390 : if (INTEGER_CST_P (bound))
3195 : : {
3196 : 296 : if (wi::ltu_p (wi::to_wide (bound), 1)
3197 : 592 : || wi::gtu_p (wi::to_wide (bound),
3198 : 296 : GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
3199 : 0 : gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3200 : 0 : "dimension index", expr->value.function.isym->name,
3201 : : &expr->where);
3202 : : }
3203 : 94 : else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3204 : : {
3205 : 36 : bound = gfc_evaluate_now (bound, &se->pre);
3206 : 36 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3207 : 36 : bound, build_int_cst (TREE_TYPE (bound), 1));
3208 : 36 : tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
3209 : 36 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3210 : : bound, tmp);
3211 : 36 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3212 : : logical_type_node, cond, tmp);
3213 : 36 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3214 : : gfc_msg_fault);
3215 : : }
3216 : :
3217 : :
3218 : : /* Subtract 1 to get to zero based and add dimensions. */
3219 : 390 : switch (arg->expr->rank)
3220 : : {
3221 : 49 : case 0:
3222 : 49 : bound = fold_build2_loc (input_location, MINUS_EXPR,
3223 : : gfc_array_index_type, bound,
3224 : : gfc_index_one_node);
3225 : : case 1:
3226 : : break;
3227 : 36 : default:
3228 : 36 : bound = fold_build2_loc (input_location, PLUS_EXPR,
3229 : : gfc_array_index_type, bound,
3230 : 36 : gfc_rank_cst[arg->expr->rank - 1]);
3231 : : }
3232 : : }
3233 : :
3234 : 569 : resbound = gfc_conv_descriptor_lbound_get (desc, bound);
3235 : :
3236 : : /* Handle UCOBOUND with special handling of the last codimension. */
3237 : 569 : if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
3238 : : {
3239 : : /* Last codimension: For -fcoarray=single just return
3240 : : the lcobound - otherwise add
3241 : : ceiling (real (num_images ()) / real (size)) - 1
3242 : : = (num_images () + size - 1) / size - 1
3243 : : = (num_images - 1) / size(),
3244 : : where size is the product of the extent of all but the last
3245 : : codimension. */
3246 : :
3247 : 185 : if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
3248 : : {
3249 : 26 : tree cosize;
3250 : :
3251 : 26 : cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
3252 : 26 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3253 : : 2, integer_zero_node,
3254 : 26 : build_int_cst (integer_type_node, -1));
3255 : 26 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3256 : : gfc_array_index_type,
3257 : : fold_convert (gfc_array_index_type, tmp),
3258 : 26 : build_int_cst (gfc_array_index_type, 1));
3259 : 26 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
3260 : : gfc_array_index_type, tmp,
3261 : : fold_convert (gfc_array_index_type, cosize));
3262 : 26 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
3263 : : gfc_array_index_type, resbound, tmp);
3264 : 26 : }
3265 : 159 : else if (flag_coarray != GFC_FCOARRAY_SINGLE)
3266 : : {
3267 : : /* ubound = lbound + num_images() - 1. */
3268 : 21 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3269 : : 2, integer_zero_node,
3270 : 21 : build_int_cst (integer_type_node, -1));
3271 : 21 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3272 : : gfc_array_index_type,
3273 : : fold_convert (gfc_array_index_type, tmp),
3274 : 21 : build_int_cst (gfc_array_index_type, 1));
3275 : 21 : resbound = fold_build2_loc (input_location, PLUS_EXPR,
3276 : : gfc_array_index_type, resbound, tmp);
3277 : : }
3278 : :
3279 : 185 : if (corank > 1)
3280 : : {
3281 : 131 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3282 : : bound,
3283 : 131 : build_int_cst (TREE_TYPE (bound),
3284 : 131 : arg->expr->rank + corank - 1));
3285 : :
3286 : 131 : resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
3287 : 131 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3288 : : gfc_array_index_type, cond,
3289 : : resbound, resbound2);
3290 : : }
3291 : : else
3292 : 54 : se->expr = resbound;
3293 : : }
3294 : : else
3295 : 384 : se->expr = resbound;
3296 : :
3297 : 569 : type = gfc_typenode_for_spec (&expr->ts);
3298 : 569 : se->expr = convert (type, se->expr);
3299 : 569 : }
3300 : :
3301 : :
3302 : : static void
3303 : 1733 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
3304 : : {
3305 : 1733 : gfc_actual_arglist *array_arg;
3306 : 1733 : gfc_actual_arglist *dim_arg;
3307 : 1733 : gfc_se argse;
3308 : 1733 : tree desc, tmp;
3309 : :
3310 : 1733 : array_arg = expr->value.function.actual;
3311 : 1733 : dim_arg = array_arg->next;
3312 : :
3313 : 1733 : gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
3314 : :
3315 : 1733 : gfc_init_se (&argse, NULL);
3316 : 1733 : gfc_conv_expr_descriptor (&argse, array_arg->expr);
3317 : 1733 : gfc_add_block_to_block (&se->pre, &argse.pre);
3318 : 1733 : gfc_add_block_to_block (&se->post, &argse.post);
3319 : 1733 : desc = argse.expr;
3320 : :
3321 : 1733 : gcc_assert (dim_arg->expr);
3322 : 1733 : gfc_init_se (&argse, NULL);
3323 : 1733 : gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
3324 : 1733 : gfc_add_block_to_block (&se->pre, &argse.pre);
3325 : 1733 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3326 : : argse.expr, gfc_index_one_node);
3327 : 1733 : se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
3328 : 1733 : }
3329 : :
3330 : : static void
3331 : 7598 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
3332 : : {
3333 : 7598 : tree arg, cabs;
3334 : :
3335 : 7598 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3336 : :
3337 : 7598 : switch (expr->value.function.actual->expr->ts.type)
3338 : : {
3339 : 6635 : case BT_INTEGER:
3340 : 6635 : case BT_REAL:
3341 : 6635 : se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
3342 : : arg);
3343 : 6635 : break;
3344 : :
3345 : 963 : case BT_COMPLEX:
3346 : 963 : cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
3347 : 963 : se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
3348 : 963 : break;
3349 : :
3350 : 0 : default:
3351 : 0 : gcc_unreachable ();
3352 : : }
3353 : 7598 : }
3354 : :
3355 : :
3356 : : /* Create a complex value from one or two real components. */
3357 : :
3358 : : static void
3359 : 415 : gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
3360 : : {
3361 : 415 : tree real;
3362 : 415 : tree imag;
3363 : 415 : tree type;
3364 : 415 : tree *args;
3365 : 415 : unsigned int num_args;
3366 : :
3367 : 415 : num_args = gfc_intrinsic_argument_list_length (expr);
3368 : 415 : args = XALLOCAVEC (tree, num_args);
3369 : :
3370 : 415 : type = gfc_typenode_for_spec (&expr->ts);
3371 : 415 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3372 : 415 : real = convert (TREE_TYPE (type), args[0]);
3373 : 415 : if (both)
3374 : 372 : imag = convert (TREE_TYPE (type), args[1]);
3375 : 43 : else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
3376 : : {
3377 : 30 : imag = fold_build1_loc (input_location, IMAGPART_EXPR,
3378 : 30 : TREE_TYPE (TREE_TYPE (args[0])), args[0]);
3379 : 30 : imag = convert (TREE_TYPE (type), imag);
3380 : : }
3381 : : else
3382 : 13 : imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
3383 : :
3384 : 415 : se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
3385 : 415 : }
3386 : :
3387 : :
3388 : : /* Remainder function MOD(A, P) = A - INT(A / P) * P
3389 : : MODULO(A, P) = A - FLOOR (A / P) * P
3390 : :
3391 : : The obvious algorithms above are numerically instable for large
3392 : : arguments, hence these intrinsics are instead implemented via calls
3393 : : to the fmod family of functions. It is the responsibility of the
3394 : : user to ensure that the second argument is non-zero. */
3395 : :
3396 : : static void
3397 : 2940 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
3398 : : {
3399 : 2940 : tree type;
3400 : 2940 : tree tmp;
3401 : 2940 : tree test;
3402 : 2940 : tree test2;
3403 : 2940 : tree fmod;
3404 : 2940 : tree zero;
3405 : 2940 : tree args[2];
3406 : :
3407 : 2940 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3408 : :
3409 : 2940 : switch (expr->ts.type)
3410 : : {
3411 : 2817 : case BT_INTEGER:
3412 : : /* Integer case is easy, we've got a builtin op. */
3413 : 2817 : type = TREE_TYPE (args[0]);
3414 : :
3415 : 2817 : if (modulo)
3416 : 428 : se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
3417 : : args[0], args[1]);
3418 : : else
3419 : 2389 : se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
3420 : : args[0], args[1]);
3421 : 2817 : break;
3422 : :
3423 : 123 : case BT_REAL:
3424 : 123 : fmod = NULL_TREE;
3425 : : /* Check if we have a builtin fmod. */
3426 : 123 : fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
3427 : :
3428 : : /* The builtin should always be available. */
3429 : 123 : gcc_assert (fmod != NULL_TREE);
3430 : :
3431 : 123 : tmp = build_addr (fmod);
3432 : 123 : se->expr = build_call_array_loc (input_location,
3433 : 123 : TREE_TYPE (TREE_TYPE (fmod)),
3434 : : tmp, 2, args);
3435 : 123 : if (modulo == 0)
3436 : 123 : return;
3437 : :
3438 : 25 : type = TREE_TYPE (args[0]);
3439 : :
3440 : 25 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3441 : 25 : args[1] = gfc_evaluate_now (args[1], &se->pre);
3442 : :
3443 : : /* Definition:
3444 : : modulo = arg - floor (arg/arg2) * arg2
3445 : :
3446 : : In order to calculate the result accurately, we use the fmod
3447 : : function as follows.
3448 : :
3449 : : res = fmod (arg, arg2);
3450 : : if (res)
3451 : : {
3452 : : if ((arg < 0) xor (arg2 < 0))
3453 : : res += arg2;
3454 : : }
3455 : : else
3456 : : res = copysign (0., arg2);
3457 : :
3458 : : => As two nested ternary exprs:
3459 : :
3460 : : res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3461 : : : copysign (0., arg2);
3462 : :
3463 : : */
3464 : :
3465 : 25 : zero = gfc_build_const (type, integer_zero_node);
3466 : 25 : tmp = gfc_evaluate_now (se->expr, &se->pre);
3467 : 25 : if (!flag_signed_zeros)
3468 : : {
3469 : 1 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3470 : : args[0], zero);
3471 : 1 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3472 : : args[1], zero);
3473 : 1 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3474 : : logical_type_node, test, test2);
3475 : 1 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3476 : : tmp, zero);
3477 : 1 : test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3478 : : logical_type_node, test, test2);
3479 : 1 : test = gfc_evaluate_now (test, &se->pre);
3480 : 1 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3481 : : fold_build2_loc (input_location,
3482 : : PLUS_EXPR,
3483 : : type, tmp, args[1]),
3484 : : tmp);
3485 : : }
3486 : : else
3487 : : {
3488 : 24 : tree expr1, copysign, cscall;
3489 : 24 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3490 : : expr->ts.kind);
3491 : 24 : test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3492 : : args[0], zero);
3493 : 24 : test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3494 : : args[1], zero);
3495 : 24 : test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3496 : : logical_type_node, test, test2);
3497 : 24 : expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3498 : : fold_build2_loc (input_location,
3499 : : PLUS_EXPR,
3500 : : type, tmp, args[1]),
3501 : : tmp);
3502 : 24 : test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3503 : : tmp, zero);
3504 : 24 : cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3505 : : args[1]);
3506 : 24 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3507 : : expr1, cscall);
3508 : : }
3509 : : return;
3510 : :
3511 : 0 : default:
3512 : 0 : gcc_unreachable ();
3513 : : }
3514 : : }
3515 : :
3516 : : /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3517 : : DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3518 : : where the right shifts are logical (i.e. 0's are shifted in).
3519 : : Because SHIFT_EXPR's want shifts strictly smaller than the integral
3520 : : type width, we have to special-case both S == 0 and S == BITSIZE(J):
3521 : : DSHIFTL(I,J,0) = I
3522 : : DSHIFTL(I,J,BITSIZE) = J
3523 : : DSHIFTR(I,J,0) = J
3524 : : DSHIFTR(I,J,BITSIZE) = I. */
3525 : :
3526 : : static void
3527 : 60 : gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3528 : : {
3529 : 60 : tree type, utype, stype, arg1, arg2, shift, res, left, right;
3530 : 60 : tree args[3], cond, tmp;
3531 : 60 : int bitsize;
3532 : :
3533 : 60 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
3534 : :
3535 : 60 : gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3536 : 60 : type = TREE_TYPE (args[0]);
3537 : 60 : bitsize = TYPE_PRECISION (type);
3538 : 60 : utype = unsigned_type_for (type);
3539 : 60 : stype = TREE_TYPE (args[2]);
3540 : :
3541 : 60 : arg1 = gfc_evaluate_now (args[0], &se->pre);
3542 : 60 : arg2 = gfc_evaluate_now (args[1], &se->pre);
3543 : 60 : shift = gfc_evaluate_now (args[2], &se->pre);
3544 : :
3545 : : /* The generic case. */
3546 : 60 : tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3547 : : build_int_cst (stype, bitsize), shift);
3548 : 90 : left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3549 : : arg1, dshiftl ? shift : tmp);
3550 : :
3551 : 90 : right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3552 : : fold_convert (utype, arg2), dshiftl ? tmp : shift);
3553 : 60 : right = fold_convert (type, right);
3554 : :
3555 : 60 : res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3556 : :
3557 : : /* Special cases. */
3558 : 60 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3559 : 60 : build_int_cst (stype, 0));
3560 : 90 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3561 : : dshiftl ? arg1 : arg2, res);
3562 : :
3563 : 60 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3564 : : build_int_cst (stype, bitsize));
3565 : 90 : res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3566 : : dshiftl ? arg2 : arg1, res);
3567 : :
3568 : 60 : se->expr = res;
3569 : 60 : }
3570 : :
3571 : :
3572 : : /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3573 : :
3574 : : static void
3575 : 96 : gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3576 : : {
3577 : 96 : tree val;
3578 : 96 : tree tmp;
3579 : 96 : tree type;
3580 : 96 : tree zero;
3581 : 96 : tree args[2];
3582 : :
3583 : 96 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3584 : 96 : type = TREE_TYPE (args[0]);
3585 : :
3586 : 96 : val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3587 : 96 : val = gfc_evaluate_now (val, &se->pre);
3588 : :
3589 : 96 : zero = gfc_build_const (type, integer_zero_node);
3590 : 96 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3591 : 96 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3592 : 96 : }
3593 : :
3594 : :
3595 : : /* SIGN(A, B) is absolute value of A times sign of B.
3596 : : The real value versions use library functions to ensure the correct
3597 : : handling of negative zero. Integer case implemented as:
3598 : : SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3599 : : */
3600 : :
3601 : : static void
3602 : 424 : gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3603 : : {
3604 : 424 : tree tmp;
3605 : 424 : tree type;
3606 : 424 : tree args[2];
3607 : :
3608 : 424 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3609 : 424 : if (expr->ts.type == BT_REAL)
3610 : : {
3611 : 162 : tree abs;
3612 : :
3613 : 162 : tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3614 : 162 : abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3615 : :
3616 : : /* We explicitly have to ignore the minus sign. We do so by using
3617 : : result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3618 : 162 : if (!flag_sign_zero
3619 : 198 : && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3620 : : {
3621 : 12 : tree cond, zero;
3622 : 12 : zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3623 : 12 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3624 : : args[1], zero);
3625 : 24 : se->expr = fold_build3_loc (input_location, COND_EXPR,
3626 : 12 : TREE_TYPE (args[0]), cond,
3627 : : build_call_expr_loc (input_location, abs, 1,
3628 : : args[0]),
3629 : : build_call_expr_loc (input_location, tmp, 2,
3630 : : args[0], args[1]));
3631 : : }
3632 : : else
3633 : 150 : se->expr = build_call_expr_loc (input_location, tmp, 2,
3634 : : args[0], args[1]);
3635 : 162 : return;
3636 : : }
3637 : :
3638 : : /* Having excluded floating point types, we know we are now dealing
3639 : : with signed integer types. */
3640 : 262 : type = TREE_TYPE (args[0]);
3641 : :
3642 : : /* Args[0] is used multiple times below. */
3643 : 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
3644 : :
3645 : : /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3646 : : the signs of A and B are the same, and of all ones if they differ. */
3647 : 262 : tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3648 : 262 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3649 : 262 : build_int_cst (type, TYPE_PRECISION (type) - 1));
3650 : 262 : tmp = gfc_evaluate_now (tmp, &se->pre);
3651 : :
3652 : : /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3653 : : is all ones (i.e. -1). */
3654 : 262 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3655 : : fold_build2_loc (input_location, PLUS_EXPR,
3656 : : type, args[0], tmp), tmp);
3657 : : }
3658 : :
3659 : :
3660 : : /* Test for the presence of an optional argument. */
3661 : :
3662 : : static void
3663 : 4729 : gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3664 : : {
3665 : 4729 : gfc_expr *arg;
3666 : :
3667 : 4729 : arg = expr->value.function.actual->expr;
3668 : 4729 : gcc_assert (arg->expr_type == EXPR_VARIABLE);
3669 : 4729 : se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3670 : 4729 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3671 : 4729 : }
3672 : :
3673 : :
3674 : : /* Calculate the double precision product of two single precision values. */
3675 : :
3676 : : static void
3677 : 13 : gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3678 : : {
3679 : 13 : tree type;
3680 : 13 : tree args[2];
3681 : :
3682 : 13 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
3683 : :
3684 : : /* Convert the args to double precision before multiplying. */
3685 : 13 : type = gfc_typenode_for_spec (&expr->ts);
3686 : 13 : args[0] = convert (type, args[0]);
3687 : 13 : args[1] = convert (type, args[1]);
3688 : 13 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3689 : : args[1]);
3690 : 13 : }
3691 : :
3692 : :
3693 : : /* Return a length one character string containing an ascii character. */
3694 : :
3695 : : static void
3696 : 2019 : gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3697 : : {
3698 : 2019 : tree arg[2];
3699 : 2019 : tree var;
3700 : 2019 : tree type;
3701 : 2019 : unsigned int num_args;
3702 : :
3703 : 2019 : num_args = gfc_intrinsic_argument_list_length (expr);
3704 : 2019 : gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3705 : :
3706 : 2019 : type = gfc_get_char_type (expr->ts.kind);
3707 : 2019 : var = gfc_create_var (type, "char");
3708 : :
3709 : 2019 : arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3710 : 2019 : gfc_add_modify (&se->pre, var, arg[0]);
3711 : 2019 : se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3712 : 2019 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3713 : 2019 : }
3714 : :
3715 : :
3716 : : static void
3717 : 0 : gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3718 : : {
3719 : 0 : tree var;
3720 : 0 : tree len;
3721 : 0 : tree tmp;
3722 : 0 : tree cond;
3723 : 0 : tree fndecl;
3724 : 0 : tree *args;
3725 : 0 : unsigned int num_args;
3726 : :
3727 : 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3728 : 0 : args = XALLOCAVEC (tree, num_args);
3729 : :
3730 : 0 : var = gfc_create_var (pchar_type_node, "pstr");
3731 : 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3732 : :
3733 : 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3734 : 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3735 : 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3736 : :
3737 : 0 : fndecl = build_addr (gfor_fndecl_ctime);
3738 : 0 : tmp = build_call_array_loc (input_location,
3739 : 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3740 : : fndecl, num_args, args);
3741 : 0 : gfc_add_expr_to_block (&se->pre, tmp);
3742 : :
3743 : : /* Free the temporary afterwards, if necessary. */
3744 : 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3745 : 0 : len, build_int_cst (TREE_TYPE (len), 0));
3746 : 0 : tmp = gfc_call_free (var);
3747 : 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3748 : 0 : gfc_add_expr_to_block (&se->post, tmp);
3749 : :
3750 : 0 : se->expr = var;
3751 : 0 : se->string_length = len;
3752 : 0 : }
3753 : :
3754 : :
3755 : : static void
3756 : 0 : gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3757 : : {
3758 : 0 : tree var;
3759 : 0 : tree len;
3760 : 0 : tree tmp;
3761 : 0 : tree cond;
3762 : 0 : tree fndecl;
3763 : 0 : tree *args;
3764 : 0 : unsigned int num_args;
3765 : :
3766 : 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3767 : 0 : args = XALLOCAVEC (tree, num_args);
3768 : :
3769 : 0 : var = gfc_create_var (pchar_type_node, "pstr");
3770 : 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
3771 : :
3772 : 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3773 : 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
3774 : 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
3775 : :
3776 : 0 : fndecl = build_addr (gfor_fndecl_fdate);
3777 : 0 : tmp = build_call_array_loc (input_location,
3778 : 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3779 : : fndecl, num_args, args);
3780 : 0 : gfc_add_expr_to_block (&se->pre, tmp);
3781 : :
3782 : : /* Free the temporary afterwards, if necessary. */
3783 : 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3784 : 0 : len, build_int_cst (TREE_TYPE (len), 0));
3785 : 0 : tmp = gfc_call_free (var);
3786 : 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3787 : 0 : gfc_add_expr_to_block (&se->post, tmp);
3788 : :
3789 : 0 : se->expr = var;
3790 : 0 : se->string_length = len;
3791 : 0 : }
3792 : :
3793 : :
3794 : : /* Generate a direct call to free() for the FREE subroutine. */
3795 : :
3796 : : static tree
3797 : 10 : conv_intrinsic_free (gfc_code *code)
3798 : : {
3799 : 10 : stmtblock_t block;
3800 : 10 : gfc_se argse;
3801 : 10 : tree arg, call;
3802 : :
3803 : 10 : gfc_init_se (&argse, NULL);
3804 : 10 : gfc_conv_expr (&argse, code->ext.actual->expr);
3805 : 10 : arg = fold_convert (ptr_type_node, argse.expr);
3806 : :
3807 : 10 : gfc_init_block (&block);
3808 : 10 : call = build_call_expr_loc (input_location,
3809 : : builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3810 : 10 : gfc_add_expr_to_block (&block, call);
3811 : 10 : return gfc_finish_block (&block);
3812 : : }
3813 : :
3814 : :
3815 : : /* Call the RANDOM_INIT library subroutine with a hidden argument for
3816 : : handling seeding on coarray images. */
3817 : :
3818 : : static tree
3819 : 90 : conv_intrinsic_random_init (gfc_code *code)
3820 : : {
3821 : 90 : stmtblock_t block;
3822 : 90 : gfc_se se;
3823 : 90 : tree arg1, arg2, tmp;
3824 : : /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */
3825 : 90 : tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
3826 : 90 : ? logical_type_node
3827 : 90 : : gfc_get_logical_type (4);
3828 : :
3829 : : /* Make the function call. */
3830 : 90 : gfc_init_block (&block);
3831 : 90 : gfc_init_se (&se, NULL);
3832 : :
3833 : : /* Convert REPEATABLE to the desired LOGICAL entity. */
3834 : 90 : gfc_conv_expr (&se, code->ext.actual->expr);
3835 : 90 : gfc_add_block_to_block (&block, &se.pre);
3836 : 90 : arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3837 : 90 : gfc_add_block_to_block (&block, &se.post);
3838 : :
3839 : : /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */
3840 : 90 : gfc_conv_expr (&se, code->ext.actual->next->expr);
3841 : 90 : gfc_add_block_to_block (&block, &se.pre);
3842 : 90 : arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
3843 : 90 : gfc_add_block_to_block (&block, &se.post);
3844 : :
3845 : 90 : if (flag_coarray == GFC_FCOARRAY_LIB)
3846 : : {
3847 : 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
3848 : : 2, arg1, arg2);
3849 : : }
3850 : : else
3851 : : {
3852 : : /* The ABI for libgfortran needs to be maintained, so a hidden
3853 : : argument must be include if code is compiled with -fcoarray=single
3854 : : or without the option. Set to 0. */
3855 : 90 : tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
3856 : 90 : tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
3857 : : 3, arg1, arg2, arg3);
3858 : : }
3859 : :
3860 : 90 : gfc_add_expr_to_block (&block, tmp);
3861 : :
3862 : 90 : return gfc_finish_block (&block);
3863 : : }
3864 : :
3865 : :
3866 : : /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3867 : : conversions. */
3868 : :
3869 : : static tree
3870 : 194 : conv_intrinsic_system_clock (gfc_code *code)
3871 : : {
3872 : 194 : stmtblock_t block;
3873 : 194 : gfc_se count_se, count_rate_se, count_max_se;
3874 : 194 : tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3875 : 194 : tree tmp;
3876 : 194 : int least;
3877 : :
3878 : 194 : gfc_expr *count = code->ext.actual->expr;
3879 : 194 : gfc_expr *count_rate = code->ext.actual->next->expr;
3880 : 194 : gfc_expr *count_max = code->ext.actual->next->next->expr;
3881 : :
3882 : : /* Evaluate our arguments. */
3883 : 194 : if (count)
3884 : : {
3885 : 194 : gfc_init_se (&count_se, NULL);
3886 : 194 : gfc_conv_expr (&count_se, count);
3887 : : }
3888 : :
3889 : 194 : if (count_rate)
3890 : : {
3891 : 181 : gfc_init_se (&count_rate_se, NULL);
3892 : 181 : gfc_conv_expr (&count_rate_se, count_rate);
3893 : : }
3894 : :
3895 : 194 : if (count_max)
3896 : : {
3897 : 180 : gfc_init_se (&count_max_se, NULL);
3898 : 180 : gfc_conv_expr (&count_max_se, count_max);
3899 : : }
3900 : :
3901 : : /* Find the smallest kind found of the arguments. */
3902 : 194 : least = 16;
3903 : 194 : least = (count && count->ts.kind < least) ? count->ts.kind : least;
3904 : 194 : least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3905 : : : least;
3906 : 194 : least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3907 : : : least;
3908 : :
3909 : : /* Prepare temporary variables. */
3910 : :
3911 : 194 : if (count)
3912 : : {
3913 : 194 : if (least >= 8)
3914 : 18 : arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3915 : 176 : else if (least == 4)
3916 : 152 : arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3917 : 24 : else if (count->ts.kind == 1)
3918 : 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3919 : : count->ts.kind);
3920 : : else
3921 : 12 : arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3922 : : count->ts.kind);
3923 : : }
3924 : :
3925 : 194 : if (count_rate)
3926 : : {
3927 : 181 : if (least >= 8)
3928 : 18 : arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3929 : 163 : else if (least == 4)
3930 : 139 : arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3931 : : else
3932 : 24 : arg2 = integer_zero_node;
3933 : : }
3934 : :
3935 : 194 : if (count_max)
3936 : : {
3937 : 180 : if (least >= 8)
3938 : 18 : arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3939 : 162 : else if (least == 4)
3940 : 138 : arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3941 : : else
3942 : 24 : arg3 = integer_zero_node;
3943 : : }
3944 : :
3945 : : /* Make the function call. */
3946 : 194 : gfc_init_block (&block);
3947 : :
3948 : 194 : if (least <= 2)
3949 : : {
3950 : 24 : if (least == 1)
3951 : : {
3952 : 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3953 : : : null_pointer_node;
3954 : 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3955 : : : null_pointer_node;
3956 : 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3957 : : : null_pointer_node;
3958 : : }
3959 : :
3960 : 24 : if (least == 2)
3961 : : {
3962 : 12 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3963 : : : null_pointer_node;
3964 : 12 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3965 : : : null_pointer_node;
3966 : 12 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3967 : : : null_pointer_node;
3968 : : }
3969 : : }
3970 : : else
3971 : : {
3972 : 170 : if (least == 4)
3973 : : {
3974 : 581 : tmp = build_call_expr_loc (input_location,
3975 : : gfor_fndecl_system_clock4, 3,
3976 : 152 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3977 : : : null_pointer_node,
3978 : 139 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3979 : : : null_pointer_node,
3980 : 138 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3981 : : : null_pointer_node);
3982 : 152 : gfc_add_expr_to_block (&block, tmp);
3983 : : }
3984 : : /* Handle kind>=8, 10, or 16 arguments */
3985 : 170 : if (least >= 8)
3986 : : {
3987 : 72 : tmp = build_call_expr_loc (input_location,
3988 : : gfor_fndecl_system_clock8, 3,
3989 : 18 : arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3990 : : : null_pointer_node,
3991 : 18 : arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3992 : : : null_pointer_node,
3993 : 18 : arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3994 : : : null_pointer_node);
3995 : 18 : gfc_add_expr_to_block (&block, tmp);
3996 : : }
3997 : : }
3998 : :
3999 : : /* And store values back if needed. */
4000 : 194 : if (arg1 && arg1 != count_se.expr)
4001 : 194 : gfc_add_modify (&block, count_se.expr,
4002 : 194 : fold_convert (TREE_TYPE (count_se.expr), arg1));
4003 : 194 : if (arg2 && arg2 != count_rate_se.expr)
4004 : 181 : gfc_add_modify (&block, count_rate_se.expr,
4005 : 181 : fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
4006 : 194 : if (arg3 && arg3 != count_max_se.expr)
4007 : 180 : gfc_add_modify (&block, count_max_se.expr,
4008 : 180 : fold_convert (TREE_TYPE (count_max_se.expr), arg3));
4009 : :
4010 : 194 : return gfc_finish_block (&block);
4011 : : }
4012 : :
4013 : :
4014 : : /* Return a character string containing the tty name. */
4015 : :
4016 : : static void
4017 : 0 : gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
4018 : : {
4019 : 0 : tree var;
4020 : 0 : tree len;
4021 : 0 : tree tmp;
4022 : 0 : tree cond;
4023 : 0 : tree fndecl;
4024 : 0 : tree *args;
4025 : 0 : unsigned int num_args;
4026 : :
4027 : 0 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4028 : 0 : args = XALLOCAVEC (tree, num_args);
4029 : :
4030 : 0 : var = gfc_create_var (pchar_type_node, "pstr");
4031 : 0 : len = gfc_create_var (gfc_charlen_type_node, "len");
4032 : :
4033 : 0 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4034 : 0 : args[0] = gfc_build_addr_expr (NULL_TREE, var);
4035 : 0 : args[1] = gfc_build_addr_expr (NULL_TREE, len);
4036 : :
4037 : 0 : fndecl = build_addr (gfor_fndecl_ttynam);
4038 : 0 : tmp = build_call_array_loc (input_location,
4039 : 0 : TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
4040 : : fndecl, num_args, args);
4041 : 0 : gfc_add_expr_to_block (&se->pre, tmp);
4042 : :
4043 : : /* Free the temporary afterwards, if necessary. */
4044 : 0 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4045 : 0 : len, build_int_cst (TREE_TYPE (len), 0));
4046 : 0 : tmp = gfc_call_free (var);
4047 : 0 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4048 : 0 : gfc_add_expr_to_block (&se->post, tmp);
4049 : :
4050 : 0 : se->expr = var;
4051 : 0 : se->string_length = len;
4052 : 0 : }
4053 : :
4054 : :
4055 : : /* Get the minimum/maximum value of all the parameters.
4056 : : minmax (a1, a2, a3, ...)
4057 : : {
4058 : : mvar = a1;
4059 : : mvar = COMP (mvar, a2)
4060 : : mvar = COMP (mvar, a3)
4061 : : ...
4062 : : return mvar;
4063 : : }
4064 : : Where COMP is MIN/MAX_EXPR for integral types or when we don't
4065 : : care about NaNs, or IFN_FMIN/MAX when the target has support for
4066 : : fast NaN-honouring min/max. When neither holds expand a sequence
4067 : : of explicit comparisons. */
4068 : :
4069 : : /* TODO: Mismatching types can occur when specific names are used.
4070 : : These should be handled during resolution. */
4071 : : static void
4072 : 1257 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
4073 : : {
4074 : 1257 : tree tmp;
4075 : 1257 : tree mvar;
4076 : 1257 : tree val;
4077 : 1257 : tree *args;
4078 : 1257 : tree type;
4079 : 1257 : tree argtype;
4080 : 1257 : gfc_actual_arglist *argexpr;
4081 : 1257 : unsigned int i, nargs;
4082 : :
4083 : 1257 : nargs = gfc_intrinsic_argument_list_length (expr);
4084 : 1257 : args = XALLOCAVEC (tree, nargs);
4085 : :
4086 : 1257 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
4087 : 1257 : type = gfc_typenode_for_spec (&expr->ts);
4088 : :
4089 : : /* Only evaluate the argument once. */
4090 : 1257 : if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
4091 : 295 : args[0] = gfc_evaluate_now (args[0], &se->pre);
4092 : :
4093 : : /* Determine suitable type of temporary, as a GNU extension allows
4094 : : different argument kinds. */
4095 : 1257 : argtype = TREE_TYPE (args[0]);
4096 : 1257 : argexpr = expr->value.function.actual;
4097 : 2738 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
4098 : : {
4099 : 1481 : tree tmptype = TREE_TYPE (args[i]);
4100 : 1481 : if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
4101 : 6 : argtype = tmptype;
4102 : : }
4103 : 1257 : mvar = gfc_create_var (argtype, "M");
4104 : 1257 : gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
4105 : :
4106 : 1257 : argexpr = expr->value.function.actual;
4107 : 2738 : for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
4108 : : {
4109 : 1481 : tree cond = NULL_TREE;
4110 : 1481 : val = args[i];
4111 : :
4112 : : /* Handle absent optional arguments by ignoring the comparison. */
4113 : 1481 : if (argexpr->expr->expr_type == EXPR_VARIABLE
4114 : 855 : && argexpr->expr->symtree->n.sym->attr.optional
4115 : 39 : && INDIRECT_REF_P (val))
4116 : : {
4117 : 72 : cond = fold_build2_loc (input_location,
4118 : : NE_EXPR, logical_type_node,
4119 : 36 : TREE_OPERAND (val, 0),
4120 : 36 : build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
4121 : : }
4122 : 1445 : else if (!VAR_P (val) && !TREE_CONSTANT (val))
4123 : : /* Only evaluate the argument once. */
4124 : 571 : val = gfc_evaluate_now (val, &se->pre);
4125 : :
4126 : 1481 : tree calc;
4127 : : /* For floating point types, the question is what MAX(a, NaN) or
4128 : : MIN(a, NaN) should return (where "a" is a normal number).
4129 : : There are valid use case for returning either one, but the
4130 : : Fortran standard doesn't specify which one should be chosen.
4131 : : Also, there is no consensus among other tested compilers. In
4132 : : short, it's a mess. So lets just do whatever is fastest. */
4133 : 1481 : tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
4134 : 1481 : calc = fold_build2_loc (input_location, code, argtype,
4135 : : convert (argtype, val), mvar);
4136 : 1481 : tmp = build2_v (MODIFY_EXPR, mvar, calc);
4137 : :
4138 : 1481 : if (cond != NULL_TREE)
4139 : 36 : tmp = build3_v (COND_EXPR, cond, tmp,
4140 : : build_empty_stmt (input_location));
4141 : 1481 : gfc_add_expr_to_block (&se->pre, tmp);
4142 : : }
4143 : 1257 : se->expr = convert (type, mvar);
4144 : 1257 : }
4145 : :
4146 : :
4147 : : /* Generate library calls for MIN and MAX intrinsics for character
4148 : : variables. */
4149 : : static void
4150 : 282 : gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
4151 : : {
4152 : 282 : tree *args;
4153 : 282 : tree var, len, fndecl, tmp, cond, function;
4154 : 282 : unsigned int nargs;
4155 : :
4156 : 282 : nargs = gfc_intrinsic_argument_list_length (expr);
4157 : 282 : args = XALLOCAVEC (tree, nargs + 4);
4158 : 282 : gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
4159 : :
4160 : : /* Create the result variables. */
4161 : 282 : len = gfc_create_var (gfc_charlen_type_node, "len");
4162 : 282 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
4163 : 282 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4164 : 282 : args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
4165 : 282 : args[2] = build_int_cst (integer_type_node, op);
4166 : 282 : args[3] = build_int_cst (integer_type_node, nargs / 2);
4167 : :
4168 : 282 : if (expr->ts.kind == 1)
4169 : 210 : function = gfor_fndecl_string_minmax;
4170 : 72 : else if (expr->ts.kind == 4)
4171 : 72 : function = gfor_fndecl_string_minmax_char4;
4172 : : else
4173 : 0 : gcc_unreachable ();
4174 : :
4175 : : /* Make the function call. */
4176 : 282 : fndecl = build_addr (function);
4177 : 282 : tmp = build_call_array_loc (input_location,
4178 : 282 : TREE_TYPE (TREE_TYPE (function)), fndecl,
4179 : : nargs + 4, args);
4180 : 282 : gfc_add_expr_to_block (&se->pre, tmp);
4181 : :
4182 : : /* Free the temporary afterwards, if necessary. */
4183 : 282 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4184 : 282 : len, build_int_cst (TREE_TYPE (len), 0));
4185 : 282 : tmp = gfc_call_free (var);
4186 : 282 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4187 : 282 : gfc_add_expr_to_block (&se->post, tmp);
4188 : :
4189 : 282 : se->expr = var;
4190 : 282 : se->string_length = len;
4191 : 282 : }
4192 : :
4193 : :
4194 : : /* Create a symbol node for this intrinsic. The symbol from the frontend
4195 : : has the generic name. */
4196 : :
4197 : : static gfc_symbol *
4198 : 9035 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
4199 : : {
4200 : 9035 : gfc_symbol *sym;
4201 : :
4202 : : /* TODO: Add symbols for intrinsic function to the global namespace. */
4203 : 9035 : gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
4204 : 9035 : sym = gfc_new_symbol (expr->value.function.name, NULL);
4205 : :
4206 : 9035 : sym->ts = expr->ts;
4207 : 9035 : sym->attr.external = 1;
4208 : 9035 : sym->attr.function = 1;
4209 : 9035 : sym->attr.always_explicit = 1;
4210 : 9035 : sym->attr.proc = PROC_INTRINSIC;
4211 : 9035 : sym->attr.flavor = FL_PROCEDURE;
4212 : 9035 : sym->result = sym;
4213 : 9035 : if (expr->rank > 0)
4214 : : {
4215 : 7823 : sym->attr.dimension = 1;
4216 : 7823 : sym->as = gfc_get_array_spec ();
4217 : 7823 : sym->as->type = AS_ASSUMED_SHAPE;
4218 : 7823 : sym->as->rank = expr->rank;
4219 : : }
4220 : :
4221 : 9035 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
4222 : : ignore_optional ? expr->value.function.actual
4223 : : : NULL);
4224 : :
4225 : 9035 : return sym;
4226 : : }
4227 : :
4228 : : /* Remove empty actual arguments. */
4229 : :
4230 : : static void
4231 : 7355 : remove_empty_actual_arguments (gfc_actual_arglist **ap)
4232 : : {
4233 : 38960 : while (*ap)
4234 : : {
4235 : 31605 : if ((*ap)->expr == NULL)
4236 : : {
4237 : 9216 : gfc_actual_arglist *r = *ap;
4238 : 9216 : *ap = r->next;
4239 : 9216 : r->next = NULL;
4240 : 9216 : gfc_free_actual_arglist (r);
4241 : : }
4242 : : else
4243 : 22389 : ap = &((*ap)->next);
4244 : : }
4245 : 7355 : }
4246 : :
4247 : : #define MAX_SPEC_ARG 12
4248 : :
4249 : : /* Make up an fn spec that's right for intrinsic functions that we
4250 : : want to call. */
4251 : :
4252 : : static char *
4253 : 1608 : intrinsic_fnspec (gfc_expr *expr)
4254 : : {
4255 : 1608 : static char fnspec_buf[MAX_SPEC_ARG*2+1];
4256 : 1608 : char *fp;
4257 : 1608 : int i;
4258 : 1608 : int num_char_args;
4259 : :
4260 : : #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
4261 : :
4262 : : /* Set the fndecl. */
4263 : 1608 : fp = fnspec_buf;
4264 : : /* Function return value. FIXME: Check if the second letter could
4265 : : be something other than a space, for further optimization. */
4266 : 1608 : ADD_CHAR ('.');
4267 : 1608 : if (expr->rank == 0)
4268 : : {
4269 : 166 : if (expr->ts.type == BT_CHARACTER)
4270 : : {
4271 : 84 : ADD_CHAR ('w'); /* Address of character. */
4272 : 84 : ADD_CHAR ('.'); /* Length of character. */
4273 : : }
4274 : : }
4275 : : else
4276 : 1442 : ADD_CHAR ('w'); /* Return value is a descriptor. */
4277 : :
4278 : 1608 : num_char_args = 0;
4279 : 8228 : for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
4280 : : {
4281 : 6620 : if (a->expr == NULL)
4282 : 2016 : continue;
4283 : :
4284 : 4604 : if (a->name && strcmp (a->name,"%VAL") == 0)
4285 : 976 : ADD_CHAR ('.');
4286 : : else
4287 : : {
4288 : 3628 : if (a->expr->rank > 0)
4289 : 2167 : ADD_CHAR ('r');
4290 : : else
4291 : 1461 : ADD_CHAR ('R');
4292 : : }
4293 : 4604 : num_char_args += a->expr->ts.type == BT_CHARACTER;
4294 : 4604 : gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
4295 : : }
4296 : :
4297 : 2232 : for (i = 0; i < num_char_args; i++)
4298 : 624 : ADD_CHAR ('.');
4299 : :
4300 : 1608 : *fp = '\0';
4301 : 1608 : return fnspec_buf;
4302 : : }
4303 : :
4304 : : #undef MAX_SPEC_ARG
4305 : : #undef ADD_CHAR
4306 : :
4307 : : /* Generate the right symbol for the specific intrinsic function and
4308 : : modify the expr accordingly. This assumes that absent optional
4309 : : arguments should be removed. */
4310 : :
4311 : : gfc_symbol *
4312 : 7355 : specific_intrinsic_symbol (gfc_expr *expr)
4313 : : {
4314 : 7355 : gfc_symbol *sym;
4315 : :
4316 : 7355 : sym = gfc_find_intrinsic_symbol (expr);
4317 : 7355 : if (sym == NULL)
4318 : : {
4319 : 1608 : sym = gfc_get_intrinsic_function_symbol (expr);
4320 : 1608 : sym->ts = expr->ts;
4321 : 1608 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
4322 : 240 : sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
4323 : :
4324 : 1608 : gfc_copy_formal_args_intr (sym, expr->value.function.isym,
4325 : : expr->value.function.actual, true);
4326 : 1608 : sym->backend_decl
4327 : 1608 : = gfc_get_extern_function_decl (sym, expr->value.function.actual,
4328 : 1608 : intrinsic_fnspec (expr));
4329 : : }
4330 : :
4331 : 7355 : remove_empty_actual_arguments (&(expr->value.function.actual));
4332 : :
4333 : 7355 : return sym;
4334 : : }
4335 : :
4336 : : /* Generate a call to an external intrinsic function. FIXME: So far,
4337 : : this only works for functions which are called with well-defined
4338 : : types; CSHIFT and friends will come later. */
4339 : :
4340 : : static void
4341 : 12400 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
4342 : : {
4343 : 12400 : gfc_symbol *sym;
4344 : 12400 : vec<tree, va_gc> *append_args;
4345 : 12400 : bool specific_symbol;
4346 : :
4347 : 12400 : gcc_assert (!se->ss || se->ss->info->expr == expr);
4348 : :
4349 : 12400 : if (se->ss)
4350 : 10878 : gcc_assert (expr->rank > 0);
4351 : : else
4352 : 1522 : gcc_assert (expr->rank == 0);
4353 : :
4354 : 12400 : switch (expr->value.function.isym->id)
4355 : : {
4356 : : case GFC_ISYM_ANY:
4357 : : case GFC_ISYM_ALL:
4358 : : case GFC_ISYM_FINDLOC:
4359 : : case GFC_ISYM_MAXLOC:
4360 : : case GFC_ISYM_MINLOC:
4361 : : case GFC_ISYM_MAXVAL:
4362 : : case GFC_ISYM_MINVAL:
4363 : : case GFC_ISYM_NORM2:
4364 : : case GFC_ISYM_PRODUCT:
4365 : : case GFC_ISYM_SUM:
4366 : : specific_symbol = true;
4367 : : break;
4368 : 5045 : default:
4369 : 5045 : specific_symbol = false;
4370 : : }
4371 : :
4372 : 12400 : if (specific_symbol)
4373 : : {
4374 : : /* Need to copy here because specific_intrinsic_symbol modifies
4375 : : expr to omit the absent optional arguments. */
4376 : 7355 : expr = gfc_copy_expr (expr);
4377 : 7355 : sym = specific_intrinsic_symbol (expr);
4378 : : }
4379 : : else
4380 : 5045 : sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
4381 : :
4382 : : /* Calls to libgfortran_matmul need to be appended special arguments,
4383 : : to be able to call the BLAS ?gemm functions if required and possible. */
4384 : 12400 : append_args = NULL;
4385 : 12400 : if (expr->value.function.isym->id == GFC_ISYM_MATMUL
4386 : 908 : && !expr->external_blas
4387 : 871 : && sym->ts.type != BT_LOGICAL)
4388 : : {
4389 : 855 : tree cint = gfc_get_int_type (gfc_c_int_kind);
4390 : :
4391 : 855 : if (flag_external_blas
4392 : 0 : && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
4393 : 0 : && (sym->ts.kind == 4 || sym->ts.kind == 8))
4394 : : {
4395 : 0 : tree gemm_fndecl;
4396 : :
4397 : 0 : if (sym->ts.type == BT_REAL)
4398 : : {
4399 : 0 : if (sym->ts.kind == 4)
4400 : 0 : gemm_fndecl = gfor_fndecl_sgemm;
4401 : : else
4402 : 0 : gemm_fndecl = gfor_fndecl_dgemm;
4403 : : }
4404 : : else
4405 : : {
4406 : 0 : if (sym->ts.kind == 4)
4407 : 0 : gemm_fndecl = gfor_fndecl_cgemm;
4408 : : else
4409 : 0 : gemm_fndecl = gfor_fndecl_zgemm;
4410 : : }
4411 : :
4412 : 0 : vec_alloc (append_args, 3);
4413 : 0 : append_args->quick_push (build_int_cst (cint, 1));
4414 : 0 : append_args->quick_push (build_int_cst (cint,
4415 : : flag_blas_matmul_limit));
4416 : 0 : append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
4417 : : gemm_fndecl));
4418 : 0 : }
4419 : : else
4420 : : {
4421 : 855 : vec_alloc (append_args, 3);
4422 : 855 : append_args->quick_push (build_int_cst (cint, 0));
4423 : 855 : append_args->quick_push (build_int_cst (cint, 0));
4424 : 855 : append_args->quick_push (null_pointer_node);
4425 : : }
4426 : : }
4427 : :
4428 : 12400 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4429 : : append_args);
4430 : :
4431 : 12400 : if (specific_symbol)
4432 : 7355 : gfc_free_expr (expr);
4433 : : else
4434 : 5045 : gfc_free_symbol (sym);
4435 : 12400 : }
4436 : :
4437 : : /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4438 : : Implemented as
4439 : : any(a)
4440 : : {
4441 : : forall (i=...)
4442 : : if (a[i] != 0)
4443 : : return 1
4444 : : end forall
4445 : : return 0
4446 : : }
4447 : : all(a)
4448 : : {
4449 : : forall (i=...)
4450 : : if (a[i] == 0)
4451 : : return 0
4452 : : end forall
4453 : : return 1
4454 : : }
4455 : : */
4456 : : static void
4457 : 29420 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4458 : : {
4459 : 29420 : tree resvar;
4460 : 29420 : stmtblock_t block;
4461 : 29420 : stmtblock_t body;
4462 : 29420 : tree type;
4463 : 29420 : tree tmp;
4464 : 29420 : tree found;
4465 : 29420 : gfc_loopinfo loop;
4466 : 29420 : gfc_actual_arglist *actual;
4467 : 29420 : gfc_ss *arrayss;
4468 : 29420 : gfc_se arrayse;
4469 : 29420 : tree exit_label;
4470 : :
4471 : 29420 : if (se->ss)
4472 : : {
4473 : 0 : gfc_conv_intrinsic_funcall (se, expr);
4474 : 0 : return;
4475 : : }
4476 : :
4477 : 29420 : actual = expr->value.function.actual;
4478 : 29420 : type = gfc_typenode_for_spec (&expr->ts);
4479 : : /* Initialize the result. */
4480 : 29420 : resvar = gfc_create_var (type, "test");
4481 : 29420 : if (op == EQ_EXPR)
4482 : 441 : tmp = convert (type, boolean_true_node);
4483 : : else
4484 : 28979 : tmp = convert (type, boolean_false_node);
4485 : 29420 : gfc_add_modify (&se->pre, resvar, tmp);
4486 : :
4487 : : /* Walk the arguments. */
4488 : 29420 : arrayss = gfc_walk_expr (actual->expr);
4489 : 29420 : gcc_assert (arrayss != gfc_ss_terminator);
4490 : :
4491 : : /* Initialize the scalarizer. */
4492 : 29420 : gfc_init_loopinfo (&loop);
4493 : 29420 : exit_label = gfc_build_label_decl (NULL_TREE);
4494 : 29420 : TREE_USED (exit_label) = 1;
4495 : 29420 : gfc_add_ss_to_loop (&loop, arrayss);
4496 : :
4497 : : /* Initialize the loop. */
4498 : 29420 : gfc_conv_ss_startstride (&loop);
4499 : 29420 : gfc_conv_loop_setup (&loop, &expr->where);
4500 : :
4501 : 29420 : gfc_mark_ss_chain_used (arrayss, 1);
4502 : : /* Generate the loop body. */
4503 : 29420 : gfc_start_scalarized_body (&loop, &body);
4504 : :
4505 : : /* If the condition matches then set the return value. */
4506 : 29420 : gfc_start_block (&block);
4507 : 29420 : if (op == EQ_EXPR)
4508 : 441 : tmp = convert (type, boolean_false_node);
4509 : : else
4510 : 28979 : tmp = convert (type, boolean_true_node);
4511 : 29420 : gfc_add_modify (&block, resvar, tmp);
4512 : :
4513 : : /* And break out of the loop. */
4514 : 29420 : tmp = build1_v (GOTO_EXPR, exit_label);
4515 : 29420 : gfc_add_expr_to_block (&block, tmp);
4516 : :
4517 : 29420 : found = gfc_finish_block (&block);
4518 : :
4519 : : /* Check this element. */
4520 : 29420 : gfc_init_se (&arrayse, NULL);
4521 : 29420 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4522 : 29420 : arrayse.ss = arrayss;
4523 : 29420 : gfc_conv_expr_val (&arrayse, actual->expr);
4524 : :
4525 : 29420 : gfc_add_block_to_block (&body, &arrayse.pre);
4526 : 29420 : tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4527 : 29420 : build_int_cst (TREE_TYPE (arrayse.expr), 0));
4528 : 29420 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4529 : 29420 : gfc_add_expr_to_block (&body, tmp);
4530 : 29420 : gfc_add_block_to_block (&body, &arrayse.post);
4531 : :
4532 : 29420 : gfc_trans_scalarizing_loops (&loop, &body);
4533 : :
4534 : : /* Add the exit label. */
4535 : 29420 : tmp = build1_v (LABEL_EXPR, exit_label);
4536 : 29420 : gfc_add_expr_to_block (&loop.pre, tmp);
4537 : :
4538 : 29420 : gfc_add_block_to_block (&se->pre, &loop.pre);
4539 : 29420 : gfc_add_block_to_block (&se->pre, &loop.post);
4540 : 29420 : gfc_cleanup_loop (&loop);
4541 : :
4542 : 29420 : se->expr = resvar;
4543 : : }
4544 : :
4545 : :
4546 : : /* Generate the constant 180 / pi, which is used in the conversion
4547 : : of acosd(), asind(), atand(), atan2d(). */
4548 : :
4549 : : static tree
4550 : 288 : rad2deg (int kind)
4551 : : {
4552 : 288 : tree retval;
4553 : 288 : mpfr_t pi, t0;
4554 : :
4555 : 288 : gfc_set_model_kind (kind);
4556 : 288 : mpfr_init (pi);
4557 : 288 : mpfr_init (t0);
4558 : 288 : mpfr_set_si (t0, 180, GFC_RND_MODE);
4559 : 288 : mpfr_const_pi (pi, GFC_RND_MODE);
4560 : 288 : mpfr_div (t0, t0, pi, GFC_RND_MODE);
4561 : 288 : retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
4562 : 288 : mpfr_clear (t0);
4563 : 288 : mpfr_clear (pi);
4564 : 288 : return retval;
4565 : : }
4566 : :
4567 : :
4568 : : static gfc_intrinsic_map_t *
4569 : 498 : gfc_lookup_intrinsic (gfc_isym_id id)
4570 : : {
4571 : 498 : gfc_intrinsic_map_t *m = gfc_intrinsic_map;
4572 : 8400 : for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
4573 : 8400 : if (id == m->id)
4574 : : break;
4575 : 498 : gcc_assert (id == m->id);
4576 : 498 : return m;
4577 : : }
4578 : :
4579 : :
4580 : : /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
4581 : : ASIND(x) is translated into ASIN(x) * 180 / pi.
4582 : : ATAND(x) is translated into ATAN(x) * 180 / pi. */
4583 : :
4584 : : static void
4585 : 216 : gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
4586 : : {
4587 : 216 : tree arg;
4588 : 216 : tree atrigd;
4589 : 216 : tree type;
4590 : 216 : gfc_intrinsic_map_t *m;
4591 : :
4592 : 216 : type = gfc_typenode_for_spec (&expr->ts);
4593 : :
4594 : 216 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4595 : :
4596 : 216 : switch (id)
4597 : : {
4598 : 72 : case GFC_ISYM_ACOSD:
4599 : 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
4600 : 72 : break;
4601 : 72 : case GFC_ISYM_ASIND:
4602 : 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
4603 : 72 : break;
4604 : 72 : case GFC_ISYM_ATAND:
4605 : 72 : m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
4606 : 72 : break;
4607 : 0 : default:
4608 : 0 : gcc_unreachable ();
4609 : : }
4610 : 216 : atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
4611 : 216 : atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
4612 : :
4613 : 216 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
4614 : : fold_convert (type, rad2deg (expr->ts.kind)));
4615 : 216 : }
4616 : :
4617 : :
4618 : : /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
4619 : : COS(X) / SIN(X) for COMPLEX argument. */
4620 : :
4621 : : static void
4622 : 102 : gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
4623 : : {
4624 : 102 : gfc_intrinsic_map_t *m;
4625 : 102 : tree arg;
4626 : 102 : tree type;
4627 : :
4628 : 102 : type = gfc_typenode_for_spec (&expr->ts);
4629 : 102 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4630 : :
4631 : 102 : if (expr->ts.type == BT_REAL)
4632 : : {
4633 : 102 : tree tan;
4634 : 102 : tree tmp;
4635 : 102 : mpfr_t pio2;
4636 : :
4637 : : /* Create pi/2. */
4638 : 102 : gfc_set_model_kind (expr->ts.kind);
4639 : 102 : mpfr_init (pio2);
4640 : 102 : mpfr_const_pi (pio2, GFC_RND_MODE);
4641 : 102 : mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
4642 : 102 : tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
4643 : 102 : mpfr_clear (pio2);
4644 : :
4645 : : /* Find tan builtin function. */
4646 : 102 : m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
4647 : 102 : tan = gfc_get_intrinsic_lib_fndecl (m, expr);
4648 : 102 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
4649 : 102 : tan = build_call_expr_loc (input_location, tan, 1, tmp);
4650 : 102 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
4651 : : }
4652 : : else
4653 : : {
4654 : 0 : tree sin;
4655 : 0 : tree cos;
4656 : :
4657 : : /* Find cos builtin function. */
4658 : 0 : m = gfc_lookup_intrinsic (GFC_ISYM_COS);
4659 : 0 : cos = gfc_get_intrinsic_lib_fndecl (m, expr);
4660 : 0 : cos = build_call_expr_loc (input_location, cos, 1, arg);
4661 : :
4662 : : /* Find sin builtin function. */
4663 : 0 : m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
4664 : 0 : sin = gfc_get_intrinsic_lib_fndecl (m, expr);
4665 : 0 : sin = build_call_expr_loc (input_location, sin, 1, arg);
4666 : :
4667 : : /* Divide cos by sin. */
4668 : 0 : se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
4669 : : }
4670 : 102 : }
4671 : :
4672 : :
4673 : : /* COTAND(X) is translated into -TAND(X+90) for REAL argument. */
4674 : :
4675 : : static void
4676 : 108 : gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
4677 : : {
4678 : 108 : tree arg;
4679 : 108 : tree type;
4680 : 108 : tree ninety_tree;
4681 : 108 : mpfr_t ninety;
4682 : :
4683 : 108 : type = gfc_typenode_for_spec (&expr->ts);
4684 : 108 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4685 : :
4686 : 108 : gfc_set_model_kind (expr->ts.kind);
4687 : :
4688 : : /* Build the tree for x + 90. */
4689 : 108 : mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
4690 : 108 : ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
4691 : 108 : arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
4692 : 108 : mpfr_clear (ninety);
4693 : :
4694 : : /* Find tand. */
4695 : 108 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
4696 : 108 : tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
4697 : 108 : tand = build_call_expr_loc (input_location, tand, 1, arg);
4698 : :
4699 : 108 : se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
4700 : 108 : }
4701 : :
4702 : :
4703 : : /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
4704 : :
4705 : : static void
4706 : 72 : gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
4707 : : {
4708 : 72 : tree args[2];
4709 : 72 : tree atan2d;
4710 : 72 : tree type;
4711 : :
4712 : 72 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
4713 : 72 : type = TREE_TYPE (args[0]);
4714 : :
4715 : 72 : gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
4716 : 72 : atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
4717 : 72 : atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
4718 : :
4719 : 72 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
4720 : : rad2deg (expr->ts.kind));
4721 : 72 : }
4722 : :
4723 : :
4724 : : /* COUNT(A) = Number of true elements in A. */
4725 : : static void
4726 : 142 : gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4727 : : {
4728 : 142 : tree resvar;
4729 : 142 : tree type;
4730 : 142 : stmtblock_t body;
4731 : 142 : tree tmp;
4732 : 142 : gfc_loopinfo loop;
4733 : 142 : gfc_actual_arglist *actual;
4734 : 142 : gfc_ss *arrayss;
4735 : 142 : gfc_se arrayse;
4736 : :
4737 : 142 : if (se->ss)
4738 : : {
4739 : 0 : gfc_conv_intrinsic_funcall (se, expr);
4740 : 0 : return;
4741 : : }
4742 : :
4743 : 142 : actual = expr->value.function.actual;
4744 : :
4745 : 142 : type = gfc_typenode_for_spec (&expr->ts);
4746 : : /* Initialize the result. */
4747 : 142 : resvar = gfc_create_var (type, "count");
4748 : 142 : gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4749 : :
4750 : : /* Walk the arguments. */
4751 : 142 : arrayss = gfc_walk_expr (actual->expr);
4752 : 142 : gcc_assert (arrayss != gfc_ss_terminator);
4753 : :
4754 : : /* Initialize the scalarizer. */
4755 : 142 : gfc_init_loopinfo (&loop);
4756 : 142 : gfc_add_ss_to_loop (&loop, arrayss);
4757 : :
4758 : : /* Initialize the loop. */
4759 : 142 : gfc_conv_ss_startstride (&loop);
4760 : 142 : gfc_conv_loop_setup (&loop, &expr->where);
4761 : :
4762 : 142 : gfc_mark_ss_chain_used (arrayss, 1);
4763 : : /* Generate the loop body. */
4764 : 142 : gfc_start_scalarized_body (&loop, &body);
4765 : :
4766 : 142 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4767 : 142 : resvar, build_int_cst (TREE_TYPE (resvar), 1));
4768 : 142 : tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4769 : :
4770 : 142 : gfc_init_se (&arrayse, NULL);
4771 : 142 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
4772 : 142 : arrayse.ss = arrayss;
4773 : 142 : gfc_conv_expr_val (&arrayse, actual->expr);
4774 : 142 : tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4775 : : build_empty_stmt (input_location));
4776 : :
4777 : 142 : gfc_add_block_to_block (&body, &arrayse.pre);
4778 : 142 : gfc_add_expr_to_block (&body, tmp);
4779 : 142 : gfc_add_block_to_block (&body, &arrayse.post);
4780 : :
4781 : 142 : gfc_trans_scalarizing_loops (&loop, &body);
4782 : :
4783 : 142 : gfc_add_block_to_block (&se->pre, &loop.pre);
4784 : 142 : gfc_add_block_to_block (&se->pre, &loop.post);
4785 : 142 : gfc_cleanup_loop (&loop);
4786 : :
4787 : 142 : se->expr = resvar;
4788 : : }
4789 : :
4790 : :
4791 : : /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4792 : : struct and return the corresponding loopinfo. */
4793 : :
4794 : : static gfc_loopinfo *
4795 : 563 : enter_nested_loop (gfc_se *se)
4796 : : {
4797 : 563 : se->ss = se->ss->nested_ss;
4798 : 563 : gcc_assert (se->ss == se->ss->loop->ss);
4799 : :
4800 : 563 : return se->ss->loop;
4801 : : }
4802 : :
4803 : : /* Build the condition for a mask, which may be optional. */
4804 : :
4805 : : static tree
4806 : 7187 : conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4807 : : bool optional_mask)
4808 : : {
4809 : 7187 : tree present;
4810 : 7187 : tree type;
4811 : :
4812 : 7187 : if (optional_mask)
4813 : : {
4814 : 62 : type = TREE_TYPE (maskse->expr);
4815 : 62 : present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4816 : 62 : present = convert (type, present);
4817 : 62 : present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4818 : : present);
4819 : 62 : return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4820 : 62 : type, present, maskse->expr);
4821 : : }
4822 : : else
4823 : 7125 : return maskse->expr;
4824 : : }
4825 : :
4826 : : /* Inline implementation of the sum and product intrinsics. */
4827 : : static void
4828 : 2310 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4829 : : bool norm2)
4830 : : {
4831 : 2310 : tree resvar;
4832 : 2310 : tree scale = NULL_TREE;
4833 : 2310 : tree type;
4834 : 2310 : stmtblock_t body;
4835 : 2310 : stmtblock_t block;
4836 : 2310 : tree tmp;
4837 : 2310 : gfc_loopinfo loop, *ploop;
4838 : 2310 : gfc_actual_arglist *arg_array, *arg_mask;
4839 : 2310 : gfc_ss *arrayss = NULL;
4840 : 2310 : gfc_ss *maskss = NULL;
4841 : 2310 : gfc_se arrayse;
4842 : 2310 : gfc_se maskse;
4843 : 2310 : gfc_se *parent_se;
4844 : 2310 : gfc_expr *arrayexpr;
4845 : 2310 : gfc_expr *maskexpr;
4846 : 2310 : bool optional_mask;
4847 : :
4848 : 2310 : if (expr->rank > 0)
4849 : : {
4850 : 563 : gcc_assert (gfc_inline_intrinsic_function_p (expr));
4851 : : parent_se = se;
4852 : : }
4853 : : else
4854 : : parent_se = NULL;
4855 : :
4856 : 2310 : type = gfc_typenode_for_spec (&expr->ts);
4857 : : /* Initialize the result. */
4858 : 2310 : resvar = gfc_create_var (type, "val");
4859 : 2310 : if (norm2)
4860 : : {
4861 : : /* result = 0.0;
4862 : : scale = 1.0. */
4863 : 68 : scale = gfc_create_var (type, "scale");
4864 : 68 : gfc_add_modify (&se->pre, scale,
4865 : : gfc_build_const (type, integer_one_node));
4866 : 68 : tmp = gfc_build_const (type, integer_zero_node);
4867 : : }
4868 : 2242 : else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4869 : 1850 : tmp = gfc_build_const (type, integer_zero_node);
4870 : 392 : else if (op == NE_EXPR)
4871 : : /* PARITY. */
4872 : 36 : tmp = convert (type, boolean_false_node);
4873 : 356 : else if (op == BIT_AND_EXPR)
4874 : 18 : tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4875 : : type, integer_one_node));
4876 : : else
4877 : 338 : tmp = gfc_build_const (type, integer_one_node);
4878 : :
4879 : 2310 : gfc_add_modify (&se->pre, resvar, tmp);
4880 : :
4881 : 2310 : arg_array = expr->value.function.actual;
4882 : :
4883 : 2310 : arrayexpr = arg_array->expr;
4884 : :
4885 : 2310 : if (op == NE_EXPR || norm2)
4886 : : {
4887 : : /* PARITY and NORM2. */
4888 : : maskexpr = NULL;
4889 : : optional_mask = false;
4890 : : }
4891 : : else
4892 : : {
4893 : 2206 : arg_mask = arg_array->next->next;
4894 : 2206 : gcc_assert (arg_mask != NULL);
4895 : 2206 : maskexpr = arg_mask->expr;
4896 : 371 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4897 : 266 : && maskexpr->symtree->n.sym->attr.dummy
4898 : 2472 : && maskexpr->symtree->n.sym->attr.optional;
4899 : : }
4900 : :
4901 : 2310 : if (expr->rank == 0)
4902 : : {
4903 : : /* Walk the arguments. */
4904 : 1747 : arrayss = gfc_walk_expr (arrayexpr);
4905 : 1747 : gcc_assert (arrayss != gfc_ss_terminator);
4906 : :
4907 : 1747 : if (maskexpr && maskexpr->rank > 0)
4908 : : {
4909 : 223 : maskss = gfc_walk_expr (maskexpr);
4910 : 223 : gcc_assert (maskss != gfc_ss_terminator);
4911 : : }
4912 : : else
4913 : : maskss = NULL;
4914 : :
4915 : : /* Initialize the scalarizer. */
4916 : 1747 : gfc_init_loopinfo (&loop);
4917 : :
4918 : : /* We add the mask first because the number of iterations is
4919 : : taken from the last ss, and this breaks if an absent
4920 : : optional argument is used for mask. */
4921 : :
4922 : 1747 : if (maskexpr && maskexpr->rank > 0)
4923 : 223 : gfc_add_ss_to_loop (&loop, maskss);
4924 : 1747 : gfc_add_ss_to_loop (&loop, arrayss);
4925 : :
4926 : : /* Initialize the loop. */
4927 : 1747 : gfc_conv_ss_startstride (&loop);
4928 : 1747 : gfc_conv_loop_setup (&loop, &expr->where);
4929 : :
4930 : 1747 : if (maskexpr && maskexpr->rank > 0)
4931 : 223 : gfc_mark_ss_chain_used (maskss, 1);
4932 : 1747 : gfc_mark_ss_chain_used (arrayss, 1);
4933 : :
4934 : 1747 : ploop = &loop;
4935 : : }
4936 : : else
4937 : : /* All the work has been done in the parent loops. */
4938 : 563 : ploop = enter_nested_loop (se);
4939 : :
4940 : 2310 : gcc_assert (ploop);
4941 : :
4942 : : /* Generate the loop body. */
4943 : 2310 : gfc_start_scalarized_body (ploop, &body);
4944 : :
4945 : : /* If we have a mask, only add this element if the mask is set. */
4946 : 2310 : if (maskexpr && maskexpr->rank > 0)
4947 : : {
4948 : 307 : gfc_init_se (&maskse, parent_se);
4949 : 307 : gfc_copy_loopinfo_to_se (&maskse, ploop);
4950 : 307 : if (expr->rank == 0)
4951 : 223 : maskse.ss = maskss;
4952 : 307 : gfc_conv_expr_val (&maskse, maskexpr);
4953 : 307 : gfc_add_block_to_block (&body, &maskse.pre);
4954 : :
4955 : 307 : gfc_start_block (&block);
4956 : : }
4957 : : else
4958 : 2003 : gfc_init_block (&block);
4959 : :
4960 : : /* Do the actual summation/product. */
4961 : 2310 : gfc_init_se (&arrayse, parent_se);
4962 : 2310 : gfc_copy_loopinfo_to_se (&arrayse, ploop);
4963 : 2310 : if (expr->rank == 0)
4964 : 1747 : arrayse.ss = arrayss;
4965 : 2310 : gfc_conv_expr_val (&arrayse, arrayexpr);
4966 : 2310 : gfc_add_block_to_block (&block, &arrayse.pre);
4967 : :
4968 : 2310 : if (norm2)
4969 : : {
4970 : : /* if (x (i) != 0.0)
4971 : : {
4972 : : absX = abs(x(i))
4973 : : if (absX > scale)
4974 : : {
4975 : : val = scale/absX;
4976 : : result = 1.0 + result * val * val;
4977 : : scale = absX;
4978 : : }
4979 : : else
4980 : : {
4981 : : val = absX/scale;
4982 : : result += val * val;
4983 : : }
4984 : : } */
4985 : 68 : tree res1, res2, cond, absX, val;
4986 : 68 : stmtblock_t ifblock1, ifblock2, ifblock3;
4987 : :
4988 : 68 : gfc_init_block (&ifblock1);
4989 : :
4990 : 68 : absX = gfc_create_var (type, "absX");
4991 : 68 : gfc_add_modify (&ifblock1, absX,
4992 : : fold_build1_loc (input_location, ABS_EXPR, type,
4993 : : arrayse.expr));
4994 : 68 : val = gfc_create_var (type, "val");
4995 : 68 : gfc_add_expr_to_block (&ifblock1, val);
4996 : :
4997 : 68 : gfc_init_block (&ifblock2);
4998 : 68 : gfc_add_modify (&ifblock2, val,
4999 : : fold_build2_loc (input_location, RDIV_EXPR, type, scale,
5000 : : absX));
5001 : 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
5002 : 68 : res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
5003 : 68 : res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
5004 : : gfc_build_const (type, integer_one_node));
5005 : 68 : gfc_add_modify (&ifblock2, resvar, res1);
5006 : 68 : gfc_add_modify (&ifblock2, scale, absX);
5007 : 68 : res1 = gfc_finish_block (&ifblock2);
5008 : :
5009 : 68 : gfc_init_block (&ifblock3);
5010 : 68 : gfc_add_modify (&ifblock3, val,
5011 : : fold_build2_loc (input_location, RDIV_EXPR, type, absX,
5012 : : scale));
5013 : 68 : res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
5014 : 68 : res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
5015 : 68 : gfc_add_modify (&ifblock3, resvar, res2);
5016 : 68 : res2 = gfc_finish_block (&ifblock3);
5017 : :
5018 : 68 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
5019 : : absX, scale);
5020 : 68 : tmp = build3_v (COND_EXPR, cond, res1, res2);
5021 : 68 : gfc_add_expr_to_block (&ifblock1, tmp);
5022 : 68 : tmp = gfc_finish_block (&ifblock1);
5023 : :
5024 : 68 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
5025 : : arrayse.expr,
5026 : : gfc_build_const (type, integer_zero_node));
5027 : :
5028 : 68 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
5029 : 68 : gfc_add_expr_to_block (&block, tmp);
5030 : : }
5031 : : else
5032 : : {
5033 : 2242 : tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
5034 : 2242 : gfc_add_modify (&block, resvar, tmp);
5035 : : }
5036 : :
5037 : 2310 : gfc_add_block_to_block (&block, &arrayse.post);
5038 : :
5039 : 2310 : if (maskexpr && maskexpr->rank > 0)
5040 : : {
5041 : : /* We enclose the above in if (mask) {...} . If the mask is an
5042 : : optional argument, generate
5043 : : IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
5044 : 307 : tree ifmask;
5045 : 307 : tmp = gfc_finish_block (&block);
5046 : 307 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5047 : 307 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5048 : : build_empty_stmt (input_location));
5049 : 307 : }
5050 : : else
5051 : 2003 : tmp = gfc_finish_block (&block);
5052 : 2310 : gfc_add_expr_to_block (&body, tmp);
5053 : :
5054 : 2310 : gfc_trans_scalarizing_loops (ploop, &body);
5055 : :
5056 : : /* For a scalar mask, enclose the loop in an if statement. */
5057 : 2310 : if (maskexpr && maskexpr->rank == 0)
5058 : : {
5059 : 64 : gfc_init_block (&block);
5060 : 64 : gfc_add_block_to_block (&block, &ploop->pre);
5061 : 64 : gfc_add_block_to_block (&block, &ploop->post);
5062 : 64 : tmp = gfc_finish_block (&block);
5063 : :
5064 : 64 : if (expr->rank > 0)
5065 : : {
5066 : 34 : tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
5067 : : build_empty_stmt (input_location));
5068 : 34 : gfc_advance_se_ss_chain (se);
5069 : : }
5070 : : else
5071 : : {
5072 : 30 : tree ifmask;
5073 : :
5074 : 30 : gcc_assert (expr->rank == 0);
5075 : 30 : gfc_init_se (&maskse, NULL);
5076 : 30 : gfc_conv_expr_val (&maskse, maskexpr);
5077 : 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5078 : 30 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5079 : : build_empty_stmt (input_location));
5080 : : }
5081 : :
5082 : 64 : gfc_add_expr_to_block (&block, tmp);
5083 : 64 : gfc_add_block_to_block (&se->pre, &block);
5084 : 64 : gcc_assert (se->post.head == NULL);
5085 : : }
5086 : : else
5087 : : {
5088 : 2246 : gfc_add_block_to_block (&se->pre, &ploop->pre);
5089 : 2246 : gfc_add_block_to_block (&se->pre, &ploop->post);
5090 : : }
5091 : :
5092 : 2310 : if (expr->rank == 0)
5093 : 1747 : gfc_cleanup_loop (ploop);
5094 : :
5095 : 2310 : if (norm2)
5096 : : {
5097 : : /* result = scale * sqrt(result). */
5098 : 68 : tree sqrt;
5099 : 68 : sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
5100 : 68 : resvar = build_call_expr_loc (input_location,
5101 : : sqrt, 1, resvar);
5102 : 68 : resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
5103 : : }
5104 : :
5105 : 2310 : se->expr = resvar;
5106 : 2310 : }
5107 : :
5108 : :
5109 : : /* Inline implementation of the dot_product intrinsic. This function
5110 : : is based on gfc_conv_intrinsic_arith (the previous function). */
5111 : : static void
5112 : 111 : gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
5113 : : {
5114 : 111 : tree resvar;
5115 : 111 : tree type;
5116 : 111 : stmtblock_t body;
5117 : 111 : stmtblock_t block;
5118 : 111 : tree tmp;
5119 : 111 : gfc_loopinfo loop;
5120 : 111 : gfc_actual_arglist *actual;
5121 : 111 : gfc_ss *arrayss1, *arrayss2;
5122 : 111 : gfc_se arrayse1, arrayse2;
5123 : 111 : gfc_expr *arrayexpr1, *arrayexpr2;
5124 : :
5125 : 111 : type = gfc_typenode_for_spec (&expr->ts);
5126 : :
5127 : : /* Initialize the result. */
5128 : 111 : resvar = gfc_create_var (type, "val");
5129 : 111 : if (expr->ts.type == BT_LOGICAL)
5130 : 30 : tmp = build_int_cst (type, 0);
5131 : : else
5132 : 81 : tmp = gfc_build_const (type, integer_zero_node);
5133 : :
5134 : 111 : gfc_add_modify (&se->pre, resvar, tmp);
5135 : :
5136 : : /* Walk argument #1. */
5137 : 111 : actual = expr->value.function.actual;
5138 : 111 : arrayexpr1 = actual->expr;
5139 : 111 : arrayss1 = gfc_walk_expr (arrayexpr1);
5140 : 111 : gcc_assert (arrayss1 != gfc_ss_terminator);
5141 : :
5142 : : /* Walk argument #2. */
5143 : 111 : actual = actual->next;
5144 : 111 : arrayexpr2 = actual->expr;
5145 : 111 : arrayss2 = gfc_walk_expr (arrayexpr2);
5146 : 111 : gcc_assert (arrayss2 != gfc_ss_terminator);
5147 : :
5148 : : /* Initialize the scalarizer. */
5149 : 111 : gfc_init_loopinfo (&loop);
5150 : 111 : gfc_add_ss_to_loop (&loop, arrayss1);
5151 : 111 : gfc_add_ss_to_loop (&loop, arrayss2);
5152 : :
5153 : : /* Initialize the loop. */
5154 : 111 : gfc_conv_ss_startstride (&loop);
5155 : 111 : gfc_conv_loop_setup (&loop, &expr->where);
5156 : :
5157 : 111 : gfc_mark_ss_chain_used (arrayss1, 1);
5158 : 111 : gfc_mark_ss_chain_used (arrayss2, 1);
5159 : :
5160 : : /* Generate the loop body. */
5161 : 111 : gfc_start_scalarized_body (&loop, &body);
5162 : 111 : gfc_init_block (&block);
5163 : :
5164 : : /* Make the tree expression for [conjg(]array1[)]. */
5165 : 111 : gfc_init_se (&arrayse1, NULL);
5166 : 111 : gfc_copy_loopinfo_to_se (&arrayse1, &loop);
5167 : 111 : arrayse1.ss = arrayss1;
5168 : 111 : gfc_conv_expr_val (&arrayse1, arrayexpr1);
5169 : 111 : if (expr->ts.type == BT_COMPLEX)
5170 : 9 : arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
5171 : : arrayse1.expr);
5172 : 111 : gfc_add_block_to_block (&block, &arrayse1.pre);
5173 : :
5174 : : /* Make the tree expression for array2. */
5175 : 111 : gfc_init_se (&arrayse2, NULL);
5176 : 111 : gfc_copy_loopinfo_to_se (&arrayse2, &loop);
5177 : 111 : arrayse2.ss = arrayss2;
5178 : 111 : gfc_conv_expr_val (&arrayse2, arrayexpr2);
5179 : 111 : gfc_add_block_to_block (&block, &arrayse2.pre);
5180 : :
5181 : : /* Do the actual product and sum. */
5182 : 111 : if (expr->ts.type == BT_LOGICAL)
5183 : : {
5184 : 30 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
5185 : : arrayse1.expr, arrayse2.expr);
5186 : 30 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
5187 : : }
5188 : : else
5189 : : {
5190 : 81 : tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
5191 : : arrayse2.expr);
5192 : 81 : tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
5193 : : }
5194 : 111 : gfc_add_modify (&block, resvar, tmp);
5195 : :
5196 : : /* Finish up the loop block and the loop. */
5197 : 111 : tmp = gfc_finish_block (&block);
5198 : 111 : gfc_add_expr_to_block (&body, tmp);
5199 : :
5200 : 111 : gfc_trans_scalarizing_loops (&loop, &body);
5201 : 111 : gfc_add_block_to_block (&se->pre, &loop.pre);
5202 : 111 : gfc_add_block_to_block (&se->pre, &loop.post);
5203 : 111 : gfc_cleanup_loop (&loop);
5204 : :
5205 : 111 : se->expr = resvar;
5206 : 111 : }
5207 : :
5208 : :
5209 : : /* Remove unneeded kind= argument from actual argument list when the
5210 : : result conversion is dealt with in a different place. */
5211 : :
5212 : : static void
5213 : 76 : strip_kind_from_actual (gfc_actual_arglist * actual)
5214 : : {
5215 : 456 : for (gfc_actual_arglist *a = actual; a; a = a->next)
5216 : : {
5217 : 380 : if (a && a->name && strcmp (a->name, "kind") == 0)
5218 : : {
5219 : 12 : gfc_free_expr (a->expr);
5220 : 12 : a->expr = NULL;
5221 : : }
5222 : : }
5223 : 76 : }
5224 : :
5225 : : /* Emit code for minloc or maxloc intrinsic. There are many different cases
5226 : : we need to handle. For performance reasons we sometimes create two
5227 : : loops instead of one, where the second one is much simpler.
5228 : : Examples for minloc intrinsic:
5229 : : 1) Result is an array, a call is generated
5230 : : 2) Array mask is used and NaNs need to be supported:
5231 : : limit = Infinity;
5232 : : pos = 0;
5233 : : S = from;
5234 : : while (S <= to) {
5235 : : if (mask[S]) {
5236 : : if (pos == 0) pos = S + (1 - from);
5237 : : if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5238 : : }
5239 : : S++;
5240 : : }
5241 : : goto lab2;
5242 : : lab1:;
5243 : : while (S <= to) {
5244 : : if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5245 : : S++;
5246 : : }
5247 : : lab2:;
5248 : : 3) NaNs need to be supported, but it is known at compile time or cheaply
5249 : : at runtime whether array is nonempty or not:
5250 : : limit = Infinity;
5251 : : pos = 0;
5252 : : S = from;
5253 : : while (S <= to) {
5254 : : if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5255 : : S++;
5256 : : }
5257 : : if (from <= to) pos = 1;
5258 : : goto lab2;
5259 : : lab1:;
5260 : : while (S <= to) {
5261 : : if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5262 : : S++;
5263 : : }
5264 : : lab2:;
5265 : : 4) NaNs aren't supported, array mask is used:
5266 : : limit = infinities_supported ? Infinity : huge (limit);
5267 : : pos = 0;
5268 : : S = from;
5269 : : while (S <= to) {
5270 : : if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
5271 : : S++;
5272 : : }
5273 : : goto lab2;
5274 : : lab1:;
5275 : : while (S <= to) {
5276 : : if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5277 : : S++;
5278 : : }
5279 : : lab2:;
5280 : : 5) Same without array mask:
5281 : : limit = infinities_supported ? Infinity : huge (limit);
5282 : : pos = (from <= to) ? 1 : 0;
5283 : : S = from;
5284 : : while (S <= to) {
5285 : : if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
5286 : : S++;
5287 : : }
5288 : : For 3) and 5), if mask is scalar, this all goes into a conditional,
5289 : : setting pos = 0; in the else branch.
5290 : :
5291 : : Since we now also support the BACK argument, instead of using
5292 : : if (a[S] < limit), we now use
5293 : :
5294 : : if (back)
5295 : : cond = a[S] <= limit;
5296 : : else
5297 : : cond = a[S] < limit;
5298 : : if (cond) {
5299 : : ....
5300 : :
5301 : : The optimizer is smart enough to move the condition out of the loop.
5302 : : The are now marked as unlikely to for further speedup. */
5303 : :
5304 : : static void
5305 : 7428 : gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
5306 : : {
5307 : 7428 : stmtblock_t body;
5308 : 7428 : stmtblock_t block;
5309 : 7428 : stmtblock_t ifblock;
5310 : 7428 : stmtblock_t elseblock;
5311 : 7428 : tree limit;
5312 : 7428 : tree type;
5313 : 7428 : tree tmp;
5314 : 7428 : tree cond;
5315 : 7428 : tree elsetmp;
5316 : 7428 : tree ifbody;
5317 : 7428 : tree offset;
5318 : 7428 : tree nonempty;
5319 : 7428 : tree lab1, lab2;
5320 : 7428 : tree b_if, b_else;
5321 : 7428 : gfc_loopinfo loop;
5322 : 7428 : gfc_actual_arglist *actual;
5323 : 7428 : gfc_ss *arrayss;
5324 : 7428 : gfc_ss *maskss;
5325 : 7428 : gfc_se arrayse;
5326 : 7428 : gfc_se maskse;
5327 : 7428 : gfc_expr *arrayexpr;
5328 : 7428 : gfc_expr *maskexpr;
5329 : 7428 : gfc_expr *backexpr;
5330 : 7428 : gfc_se backse;
5331 : 7428 : tree pos;
5332 : 7428 : int n;
5333 : 7428 : bool optional_mask;
5334 : :
5335 : 7428 : actual = expr->value.function.actual;
5336 : :
5337 : : /* The last argument, BACK, is passed by value. Ensure that
5338 : : by setting its name to %VAL. */
5339 : 44568 : for (gfc_actual_arglist *a = actual; a; a = a->next)
5340 : : {
5341 : 37140 : if (a->next == NULL)
5342 : 7428 : a->name = "%VAL";
5343 : : }
5344 : :
5345 : 7428 : if (se->ss)
5346 : : {
5347 : 3218 : gfc_conv_intrinsic_funcall (se, expr);
5348 : 6512 : return;
5349 : : }
5350 : :
5351 : 4210 : arrayexpr = actual->expr;
5352 : :
5353 : : /* Special case for character maxloc. Remove unneeded actual
5354 : : arguments, then call a library function. */
5355 : :
5356 : 4210 : if (arrayexpr->ts.type == BT_CHARACTER)
5357 : : {
5358 : 76 : gfc_actual_arglist *a;
5359 : 76 : a = actual;
5360 : 76 : strip_kind_from_actual (a);
5361 : 532 : while (a)
5362 : : {
5363 : 380 : if (a->name && strcmp (a->name, "dim") == 0)
5364 : : {
5365 : 76 : gfc_free_expr (a->expr);
5366 : 76 : a->expr = NULL;
5367 : : }
5368 : 380 : a = a->next;
5369 : : }
5370 : 76 : gfc_conv_intrinsic_funcall (se, expr);
5371 : 76 : return;
5372 : : }
5373 : :
5374 : : /* Initialize the result. */
5375 : 4134 : pos = gfc_create_var (gfc_array_index_type, "pos");
5376 : 4134 : offset = gfc_create_var (gfc_array_index_type, "offset");
5377 : 4134 : type = gfc_typenode_for_spec (&expr->ts);
5378 : :
5379 : : /* Walk the arguments. */
5380 : 4134 : arrayss = gfc_walk_expr (arrayexpr);
5381 : 4134 : gcc_assert (arrayss != gfc_ss_terminator);
5382 : :
5383 : 4134 : actual = actual->next->next;
5384 : 4134 : gcc_assert (actual);
5385 : 4134 : maskexpr = actual->expr;
5386 : 3098 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5387 : 2523 : && maskexpr->symtree->n.sym->attr.dummy
5388 : 6657 : && maskexpr->symtree->n.sym->attr.optional;
5389 : 4134 : backexpr = actual->next->next->expr;
5390 : 4134 : nonempty = NULL;
5391 : 4134 : if (maskexpr && maskexpr->rank != 0)
5392 : : {
5393 : 1766 : maskss = gfc_walk_expr (maskexpr);
5394 : 1766 : gcc_assert (maskss != gfc_ss_terminator);
5395 : : }
5396 : : else
5397 : : {
5398 : 2368 : mpz_t asize;
5399 : 2368 : if (gfc_array_size (arrayexpr, &asize))
5400 : : {
5401 : 1619 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5402 : 1619 : mpz_clear (asize);
5403 : 1619 : nonempty = fold_build2_loc (input_location, GT_EXPR,
5404 : : logical_type_node, nonempty,
5405 : : gfc_index_zero_node);
5406 : : }
5407 : 2368 : maskss = NULL;
5408 : : }
5409 : :
5410 : 4134 : limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5411 : 4134 : switch (arrayexpr->ts.type)
5412 : : {
5413 : 1531 : case BT_REAL:
5414 : 1531 : tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5415 : 1531 : break;
5416 : :
5417 : 2603 : case BT_INTEGER:
5418 : 2603 : n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5419 : 2603 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5420 : : arrayexpr->ts.kind);
5421 : 2603 : break;
5422 : :
5423 : 0 : default:
5424 : 0 : gcc_unreachable ();
5425 : : }
5426 : :
5427 : : /* We start with the most negative possible value for MAXLOC, and the most
5428 : : positive possible value for MINLOC. The most negative possible value is
5429 : : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5430 : : possible value is HUGE in both cases. */
5431 : 4134 : if (op == GT_EXPR)
5432 : 1866 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5433 : 1866 : if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5434 : 1206 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5435 : 1206 : build_int_cst (TREE_TYPE (tmp), 1));
5436 : :
5437 : 4134 : gfc_add_modify (&se->pre, limit, tmp);
5438 : :
5439 : : /* Initialize the scalarizer. */
5440 : 4134 : gfc_init_loopinfo (&loop);
5441 : :
5442 : : /* We add the mask first because the number of iterations is taken
5443 : : from the last ss, and this breaks if an absent optional argument
5444 : : is used for mask. */
5445 : :
5446 : 4134 : if (maskss)
5447 : 1766 : gfc_add_ss_to_loop (&loop, maskss);
5448 : :
5449 : 4134 : gfc_add_ss_to_loop (&loop, arrayss);
5450 : :
5451 : : /* Initialize the loop. */
5452 : 4134 : gfc_conv_ss_startstride (&loop);
5453 : :
5454 : : /* The code generated can have more than one loop in sequence (see the
5455 : : comment at the function header). This doesn't work well with the
5456 : : scalarizer, which changes arrays' offset when the scalarization loops
5457 : : are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5458 : : are currently inlined in the scalar case only (for which loop is of rank
5459 : : one). As there is no dependency to care about in that case, there is no
5460 : : temporary, so that we can use the scalarizer temporary code to handle
5461 : : multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5462 : : with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5463 : : to restore offset.
5464 : : TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5465 : : should eventually go away. We could either create two loops properly,
5466 : : or find another way to save/restore the array offsets between the two
5467 : : loops (without conflicting with temporary management), or use a single
5468 : : loop minmaxloc implementation. See PR 31067. */
5469 : 4134 : loop.temp_dim = loop.dimen;
5470 : 4134 : gfc_conv_loop_setup (&loop, &expr->where);
5471 : :
5472 : 4134 : gcc_assert (loop.dimen == 1);
5473 : 4134 : if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
5474 : 749 : nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5475 : : loop.from[0], loop.to[0]);
5476 : :
5477 : 4134 : lab1 = NULL;
5478 : 4134 : lab2 = NULL;
5479 : : /* Initialize the position to zero, following Fortran 2003. We are free
5480 : : to do this because Fortran 95 allows the result of an entirely false
5481 : : mask to be processor dependent. If we know at compile time the array
5482 : : is non-empty and no MASK is used, we can initialize to 1 to simplify
5483 : : the inner loop. */
5484 : 4134 : if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5485 : 1491 : gfc_add_modify (&loop.pre, pos,
5486 : : fold_build3_loc (input_location, COND_EXPR,
5487 : : gfc_array_index_type,
5488 : : nonempty, gfc_index_one_node,
5489 : : gfc_index_zero_node));
5490 : : else
5491 : : {
5492 : 2643 : gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
5493 : 2643 : lab1 = gfc_build_label_decl (NULL_TREE);
5494 : 2643 : TREE_USED (lab1) = 1;
5495 : 2643 : lab2 = gfc_build_label_decl (NULL_TREE);
5496 : 2643 : TREE_USED (lab2) = 1;
5497 : : }
5498 : :
5499 : : /* An offset must be added to the loop
5500 : : counter to obtain the required position. */
5501 : 4134 : gcc_assert (loop.from[0]);
5502 : :
5503 : 4134 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5504 : : gfc_index_one_node, loop.from[0]);
5505 : 4134 : gfc_add_modify (&loop.pre, offset, tmp);
5506 : :
5507 : 5625 : gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5508 : 4134 : if (maskss)
5509 : 1766 : gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5510 : : /* Generate the loop body. */
5511 : 4134 : gfc_start_scalarized_body (&loop, &body);
5512 : :
5513 : : /* If we have a mask, only check this element if the mask is set. */
5514 : 4134 : if (maskss)
5515 : : {
5516 : 1766 : gfc_init_se (&maskse, NULL);
5517 : 1766 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5518 : 1766 : maskse.ss = maskss;
5519 : 1766 : gfc_conv_expr_val (&maskse, maskexpr);
5520 : 1766 : gfc_add_block_to_block (&body, &maskse.pre);
5521 : :
5522 : 1766 : gfc_start_block (&block);
5523 : : }
5524 : : else
5525 : 2368 : gfc_init_block (&block);
5526 : :
5527 : : /* Compare with the current limit. */
5528 : 4134 : gfc_init_se (&arrayse, NULL);
5529 : 4134 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5530 : 4134 : arrayse.ss = arrayss;
5531 : 4134 : gfc_conv_expr_val (&arrayse, arrayexpr);
5532 : 4134 : gfc_add_block_to_block (&block, &arrayse.pre);
5533 : :
5534 : 4134 : gfc_init_se (&backse, NULL);
5535 : 4134 : gfc_conv_expr_val (&backse, backexpr);
5536 : 4134 : gfc_add_block_to_block (&block, &backse.pre);
5537 : :
5538 : : /* We do the following if this is a more extreme value. */
5539 : 4134 : gfc_start_block (&ifblock);
5540 : :
5541 : : /* Assign the value to the limit... */
5542 : 4134 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5543 : :
5544 : 4134 : if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5545 : : {
5546 : 654 : stmtblock_t ifblock2;
5547 : 654 : tree ifbody2;
5548 : :
5549 : 654 : gfc_start_block (&ifblock2);
5550 : 654 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5551 : : loop.loopvar[0], offset);
5552 : 654 : gfc_add_modify (&ifblock2, pos, tmp);
5553 : 654 : ifbody2 = gfc_finish_block (&ifblock2);
5554 : 654 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos,
5555 : : gfc_index_zero_node);
5556 : 654 : tmp = build3_v (COND_EXPR, cond, ifbody2,
5557 : : build_empty_stmt (input_location));
5558 : 654 : gfc_add_expr_to_block (&block, tmp);
5559 : : }
5560 : :
5561 : 4134 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5562 : : loop.loopvar[0], offset);
5563 : 4134 : gfc_add_modify (&ifblock, pos, tmp);
5564 : :
5565 : 4134 : if (lab1)
5566 : 2643 : gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5567 : :
5568 : 4134 : ifbody = gfc_finish_block (&ifblock);
5569 : :
5570 : 4134 : if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5571 : : {
5572 : 3022 : if (lab1)
5573 : 2402 : cond = fold_build2_loc (input_location,
5574 : : op == GT_EXPR ? GE_EXPR : LE_EXPR,
5575 : : logical_type_node, arrayse.expr, limit);
5576 : : else
5577 : : {
5578 : 1491 : tree ifbody2, elsebody2;
5579 : :
5580 : : /* We switch to > or >= depending on the value of the BACK argument. */
5581 : 1491 : cond = gfc_create_var (logical_type_node, "cond");
5582 : :
5583 : 1491 : gfc_start_block (&ifblock);
5584 : 2265 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5585 : : logical_type_node, arrayse.expr, limit);
5586 : :
5587 : 1491 : gfc_add_modify (&ifblock, cond, b_if);
5588 : 1491 : ifbody2 = gfc_finish_block (&ifblock);
5589 : :
5590 : 1491 : gfc_start_block (&elseblock);
5591 : 1491 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5592 : : arrayse.expr, limit);
5593 : :
5594 : 1491 : gfc_add_modify (&elseblock, cond, b_else);
5595 : 1491 : elsebody2 = gfc_finish_block (&elseblock);
5596 : :
5597 : 1491 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5598 : : backse.expr, ifbody2, elsebody2);
5599 : :
5600 : 1491 : gfc_add_expr_to_block (&block, tmp);
5601 : : }
5602 : :
5603 : 3022 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5604 : 3022 : ifbody = build3_v (COND_EXPR, cond, ifbody,
5605 : : build_empty_stmt (input_location));
5606 : : }
5607 : 4134 : gfc_add_expr_to_block (&block, ifbody);
5608 : :
5609 : 4134 : if (maskss)
5610 : : {
5611 : : /* We enclose the above in if (mask) {...}. If the mask is an
5612 : : optional argument, generate IF (.NOT. PRESENT(MASK)
5613 : : .OR. MASK(I)). */
5614 : :
5615 : 1766 : tree ifmask;
5616 : 1766 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5617 : 1766 : tmp = gfc_finish_block (&block);
5618 : 1766 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5619 : : build_empty_stmt (input_location));
5620 : : }
5621 : : else
5622 : 2368 : tmp = gfc_finish_block (&block);
5623 : 4134 : gfc_add_expr_to_block (&body, tmp);
5624 : :
5625 : 4134 : if (lab1)
5626 : : {
5627 : 2643 : gfc_trans_scalarized_loop_boundary (&loop, &body);
5628 : :
5629 : 2643 : if (HONOR_NANS (DECL_MODE (limit)))
5630 : : {
5631 : 1531 : if (nonempty != NULL)
5632 : : {
5633 : 877 : ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
5634 : 877 : tmp = build3_v (COND_EXPR, nonempty, ifbody,
5635 : : build_empty_stmt (input_location));
5636 : 877 : gfc_add_expr_to_block (&loop.code[0], tmp);
5637 : : }
5638 : : }
5639 : :
5640 : 2643 : gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
5641 : 2643 : gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
5642 : :
5643 : : /* If we have a mask, only check this element if the mask is set. */
5644 : 2643 : if (maskss)
5645 : : {
5646 : 1766 : gfc_init_se (&maskse, NULL);
5647 : 1766 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5648 : 1766 : maskse.ss = maskss;
5649 : 1766 : gfc_conv_expr_val (&maskse, maskexpr);
5650 : 1766 : gfc_add_block_to_block (&body, &maskse.pre);
5651 : :
5652 : 1766 : gfc_start_block (&block);
5653 : : }
5654 : : else
5655 : 877 : gfc_init_block (&block);
5656 : :
5657 : : /* Compare with the current limit. */
5658 : 2643 : gfc_init_se (&arrayse, NULL);
5659 : 2643 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5660 : 2643 : arrayse.ss = arrayss;
5661 : 2643 : gfc_conv_expr_val (&arrayse, arrayexpr);
5662 : 2643 : gfc_add_block_to_block (&block, &arrayse.pre);
5663 : :
5664 : : /* We do the following if this is a more extreme value. */
5665 : 2643 : gfc_start_block (&ifblock);
5666 : :
5667 : : /* Assign the value to the limit... */
5668 : 2643 : gfc_add_modify (&ifblock, limit, arrayse.expr);
5669 : :
5670 : 2643 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5671 : : loop.loopvar[0], offset);
5672 : 2643 : gfc_add_modify (&ifblock, pos, tmp);
5673 : :
5674 : 2643 : ifbody = gfc_finish_block (&ifblock);
5675 : :
5676 : : /* We switch to > or >= depending on the value of the BACK argument. */
5677 : 2643 : {
5678 : 2643 : tree ifbody2, elsebody2;
5679 : :
5680 : 2643 : cond = gfc_create_var (logical_type_node, "cond");
5681 : :
5682 : 2643 : gfc_start_block (&ifblock);
5683 : 4137 : b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5684 : : logical_type_node, arrayse.expr, limit);
5685 : :
5686 : 2643 : gfc_add_modify (&ifblock, cond, b_if);
5687 : 2643 : ifbody2 = gfc_finish_block (&ifblock);
5688 : :
5689 : 2643 : gfc_start_block (&elseblock);
5690 : 2643 : b_else = fold_build2_loc (input_location, op, logical_type_node,
5691 : : arrayse.expr, limit);
5692 : :
5693 : 2643 : gfc_add_modify (&elseblock, cond, b_else);
5694 : 2643 : elsebody2 = gfc_finish_block (&elseblock);
5695 : :
5696 : 2643 : tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5697 : : backse.expr, ifbody2, elsebody2);
5698 : : }
5699 : :
5700 : 2643 : gfc_add_expr_to_block (&block, tmp);
5701 : 2643 : cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5702 : 2643 : tmp = build3_v (COND_EXPR, cond, ifbody,
5703 : : build_empty_stmt (input_location));
5704 : :
5705 : 2643 : gfc_add_expr_to_block (&block, tmp);
5706 : :
5707 : 2643 : if (maskss)
5708 : : {
5709 : : /* We enclose the above in if (mask) {...}. If the mask is
5710 : : an optional argument, generate IF (.NOT. PRESENT(MASK)
5711 : : .OR. MASK(I)).*/
5712 : :
5713 : 1766 : tree ifmask;
5714 : 1766 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5715 : 1766 : tmp = gfc_finish_block (&block);
5716 : 1766 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5717 : : build_empty_stmt (input_location));
5718 : : }
5719 : : else
5720 : 877 : tmp = gfc_finish_block (&block);
5721 : 2643 : gfc_add_expr_to_block (&body, tmp);
5722 : : /* Avoid initializing loopvar[0] again, it should be left where
5723 : : it finished by the first loop. */
5724 : 2643 : loop.from[0] = loop.loopvar[0];
5725 : : }
5726 : :
5727 : 4134 : gfc_trans_scalarizing_loops (&loop, &body);
5728 : :
5729 : 4134 : if (lab2)
5730 : 2643 : gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
5731 : :
5732 : : /* For a scalar mask, enclose the loop in an if statement. */
5733 : 4134 : if (maskexpr && maskss == NULL)
5734 : : {
5735 : 1332 : tree ifmask;
5736 : :
5737 : 1332 : gfc_init_se (&maskse, NULL);
5738 : 1332 : gfc_conv_expr_val (&maskse, maskexpr);
5739 : 1332 : gfc_init_block (&block);
5740 : 1332 : gfc_add_block_to_block (&block, &loop.pre);
5741 : 1332 : gfc_add_block_to_block (&block, &loop.post);
5742 : 1332 : tmp = gfc_finish_block (&block);
5743 : :
5744 : : /* For the else part of the scalar mask, just initialize
5745 : : the pos variable the same way as above. */
5746 : :
5747 : 1332 : gfc_init_block (&elseblock);
5748 : 1332 : gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
5749 : 1332 : elsetmp = gfc_finish_block (&elseblock);
5750 : 1332 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5751 : 1332 : tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5752 : 1332 : gfc_add_expr_to_block (&block, tmp);
5753 : 1332 : gfc_add_block_to_block (&se->pre, &block);
5754 : : }
5755 : : else
5756 : : {
5757 : 2802 : gfc_add_block_to_block (&se->pre, &loop.pre);
5758 : 2802 : gfc_add_block_to_block (&se->pre, &loop.post);
5759 : : }
5760 : 4134 : gfc_cleanup_loop (&loop);
5761 : :
5762 : 4134 : se->expr = convert (type, pos);
5763 : : }
5764 : :
5765 : : /* Emit code for findloc. */
5766 : :
5767 : : static void
5768 : 1224 : gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5769 : : {
5770 : 1224 : gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5771 : : *kind_arg, *back_arg;
5772 : 1224 : gfc_expr *value_expr;
5773 : 1224 : int ikind;
5774 : 1224 : tree resvar;
5775 : 1224 : stmtblock_t block;
5776 : 1224 : stmtblock_t body;
5777 : 1224 : stmtblock_t loopblock;
5778 : 1224 : tree type;
5779 : 1224 : tree tmp;
5780 : 1224 : tree found;
5781 : 1224 : tree forward_branch = NULL_TREE;
5782 : 1224 : tree back_branch;
5783 : 1224 : gfc_loopinfo loop;
5784 : 1224 : gfc_ss *arrayss;
5785 : 1224 : gfc_ss *maskss;
5786 : 1224 : gfc_se arrayse;
5787 : 1224 : gfc_se valuese;
5788 : 1224 : gfc_se maskse;
5789 : 1224 : gfc_se backse;
5790 : 1224 : tree exit_label;
5791 : 1224 : gfc_expr *maskexpr;
5792 : 1224 : tree offset;
5793 : 1224 : int i;
5794 : 1224 : bool optional_mask;
5795 : :
5796 : 1224 : array_arg = expr->value.function.actual;
5797 : 1224 : value_arg = array_arg->next;
5798 : 1224 : dim_arg = value_arg->next;
5799 : 1224 : mask_arg = dim_arg->next;
5800 : 1224 : kind_arg = mask_arg->next;
5801 : 1224 : back_arg = kind_arg->next;
5802 : :
5803 : : /* Remove kind and set ikind. */
5804 : 1224 : if (kind_arg->expr)
5805 : : {
5806 : 0 : ikind = mpz_get_si (kind_arg->expr->value.integer);
5807 : 0 : gfc_free_expr (kind_arg->expr);
5808 : 0 : kind_arg->expr = NULL;
5809 : : }
5810 : : else
5811 : 1224 : ikind = gfc_default_integer_kind;
5812 : :
5813 : 1224 : value_expr = value_arg->expr;
5814 : :
5815 : : /* Unless it's a string, pass VALUE by value. */
5816 : 1224 : if (value_expr->ts.type != BT_CHARACTER)
5817 : 660 : value_arg->name = "%VAL";
5818 : :
5819 : : /* Pass BACK argument by value. */
5820 : 1224 : back_arg->name = "%VAL";
5821 : :
5822 : : /* Call the library if we have a character function or if
5823 : : rank > 0. */
5824 : 1224 : if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5825 : : {
5826 : 1116 : se->ignore_optional = 1;
5827 : 1116 : if (expr->rank == 0)
5828 : : {
5829 : : /* Remove dim argument. */
5830 : 48 : gfc_free_expr (dim_arg->expr);
5831 : 48 : dim_arg->expr = NULL;
5832 : : }
5833 : 1116 : gfc_conv_intrinsic_funcall (se, expr);
5834 : 1116 : return;
5835 : : }
5836 : :
5837 : 108 : type = gfc_get_int_type (ikind);
5838 : :
5839 : : /* Initialize the result. */
5840 : 108 : resvar = gfc_create_var (gfc_array_index_type, "pos");
5841 : 108 : gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5842 : 108 : offset = gfc_create_var (gfc_array_index_type, "offset");
5843 : :
5844 : 108 : maskexpr = mask_arg->expr;
5845 : 72 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5846 : 60 : && maskexpr->symtree->n.sym->attr.dummy
5847 : 168 : && maskexpr->symtree->n.sym->attr.optional;
5848 : :
5849 : : /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5850 : :
5851 : 324 : for (i = 0 ; i < 2; i++)
5852 : : {
5853 : : /* Walk the arguments. */
5854 : 216 : arrayss = gfc_walk_expr (array_arg->expr);
5855 : 216 : gcc_assert (arrayss != gfc_ss_terminator);
5856 : :
5857 : 216 : if (maskexpr && maskexpr->rank != 0)
5858 : : {
5859 : 84 : maskss = gfc_walk_expr (maskexpr);
5860 : 84 : gcc_assert (maskss != gfc_ss_terminator);
5861 : : }
5862 : : else
5863 : : maskss = NULL;
5864 : :
5865 : : /* Initialize the scalarizer. */
5866 : 216 : gfc_init_loopinfo (&loop);
5867 : 216 : exit_label = gfc_build_label_decl (NULL_TREE);
5868 : 216 : TREE_USED (exit_label) = 1;
5869 : :
5870 : : /* We add the mask first because the number of iterations is
5871 : : taken from the last ss, and this breaks if an absent
5872 : : optional argument is used for mask. */
5873 : :
5874 : 216 : if (maskss)
5875 : 84 : gfc_add_ss_to_loop (&loop, maskss);
5876 : 216 : gfc_add_ss_to_loop (&loop, arrayss);
5877 : :
5878 : : /* Initialize the loop. */
5879 : 216 : gfc_conv_ss_startstride (&loop);
5880 : 216 : gfc_conv_loop_setup (&loop, &expr->where);
5881 : :
5882 : : /* Calculate the offset. */
5883 : 216 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5884 : : gfc_index_one_node, loop.from[0]);
5885 : 216 : gfc_add_modify (&loop.pre, offset, tmp);
5886 : :
5887 : 216 : gfc_mark_ss_chain_used (arrayss, 1);
5888 : 216 : if (maskss)
5889 : 84 : gfc_mark_ss_chain_used (maskss, 1);
5890 : :
5891 : : /* The first loop is for BACK=.true. */
5892 : 216 : if (i == 0)
5893 : 108 : loop.reverse[0] = GFC_REVERSE_SET;
5894 : :
5895 : : /* Generate the loop body. */
5896 : 216 : gfc_start_scalarized_body (&loop, &body);
5897 : :
5898 : : /* If we have an array mask, only add the element if it is
5899 : : set. */
5900 : 216 : if (maskss)
5901 : : {
5902 : 84 : gfc_init_se (&maskse, NULL);
5903 : 84 : gfc_copy_loopinfo_to_se (&maskse, &loop);
5904 : 84 : maskse.ss = maskss;
5905 : 84 : gfc_conv_expr_val (&maskse, maskexpr);
5906 : 84 : gfc_add_block_to_block (&body, &maskse.pre);
5907 : : }
5908 : :
5909 : : /* If the condition matches then set the return value. */
5910 : 216 : gfc_start_block (&block);
5911 : :
5912 : : /* Add the offset. */
5913 : 216 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5914 : 216 : TREE_TYPE (resvar),
5915 : : loop.loopvar[0], offset);
5916 : 216 : gfc_add_modify (&block, resvar, tmp);
5917 : : /* And break out of the loop. */
5918 : 216 : tmp = build1_v (GOTO_EXPR, exit_label);
5919 : 216 : gfc_add_expr_to_block (&block, tmp);
5920 : :
5921 : 216 : found = gfc_finish_block (&block);
5922 : :
5923 : : /* Check this element. */
5924 : 216 : gfc_init_se (&arrayse, NULL);
5925 : 216 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
5926 : 216 : arrayse.ss = arrayss;
5927 : 216 : gfc_conv_expr_val (&arrayse, array_arg->expr);
5928 : 216 : gfc_add_block_to_block (&body, &arrayse.pre);
5929 : :
5930 : 216 : gfc_init_se (&valuese, NULL);
5931 : 216 : gfc_conv_expr_val (&valuese, value_arg->expr);
5932 : 216 : gfc_add_block_to_block (&body, &valuese.pre);
5933 : :
5934 : 216 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5935 : : arrayse.expr, valuese.expr);
5936 : :
5937 : 216 : tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5938 : 216 : if (maskss)
5939 : : {
5940 : : /* We enclose the above in if (mask) {...}. If the mask is
5941 : : an optional argument, generate IF (.NOT. PRESENT(MASK)
5942 : : .OR. MASK(I)). */
5943 : :
5944 : 84 : tree ifmask;
5945 : 84 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5946 : 84 : tmp = build3_v (COND_EXPR, ifmask, tmp,
5947 : : build_empty_stmt (input_location));
5948 : : }
5949 : :
5950 : 216 : gfc_add_expr_to_block (&body, tmp);
5951 : 216 : gfc_add_block_to_block (&body, &arrayse.post);
5952 : :
5953 : 216 : gfc_trans_scalarizing_loops (&loop, &body);
5954 : :
5955 : : /* Add the exit label. */
5956 : 216 : tmp = build1_v (LABEL_EXPR, exit_label);
5957 : 216 : gfc_add_expr_to_block (&loop.pre, tmp);
5958 : 216 : gfc_start_block (&loopblock);
5959 : 216 : gfc_add_block_to_block (&loopblock, &loop.pre);
5960 : 216 : gfc_add_block_to_block (&loopblock, &loop.post);
5961 : 216 : if (i == 0)
5962 : 108 : forward_branch = gfc_finish_block (&loopblock);
5963 : : else
5964 : 108 : back_branch = gfc_finish_block (&loopblock);
5965 : :
5966 : 216 : gfc_cleanup_loop (&loop);
5967 : : }
5968 : :
5969 : : /* Enclose the two loops in an IF statement. */
5970 : :
5971 : 108 : gfc_init_se (&backse, NULL);
5972 : 108 : gfc_conv_expr_val (&backse, back_arg->expr);
5973 : 108 : gfc_add_block_to_block (&se->pre, &backse.pre);
5974 : 108 : tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5975 : :
5976 : : /* For a scalar mask, enclose the loop in an if statement. */
5977 : 108 : if (maskexpr && maskss == NULL)
5978 : : {
5979 : 30 : tree ifmask;
5980 : 30 : tree if_stmt;
5981 : :
5982 : 30 : gfc_init_se (&maskse, NULL);
5983 : 30 : gfc_conv_expr_val (&maskse, maskexpr);
5984 : 30 : gfc_init_block (&block);
5985 : 30 : gfc_add_expr_to_block (&block, maskse.expr);
5986 : 30 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5987 : 30 : if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5988 : : build_empty_stmt (input_location));
5989 : 30 : gfc_add_expr_to_block (&block, if_stmt);
5990 : 30 : tmp = gfc_finish_block (&block);
5991 : : }
5992 : :
5993 : 108 : gfc_add_expr_to_block (&se->pre, tmp);
5994 : 108 : se->expr = convert (type, resvar);
5995 : :
5996 : : }
5997 : :
5998 : : /* Emit code for minval or maxval intrinsic. There are many different cases
5999 : : we need to handle. For performance reasons we sometimes create two
6000 : : loops instead of one, where the second one is much simpler.
6001 : : Examples for minval intrinsic:
6002 : : 1) Result is an array, a call is generated
6003 : : 2) Array mask is used and NaNs need to be supported, rank 1:
6004 : : limit = Infinity;
6005 : : nonempty = false;
6006 : : S = from;
6007 : : while (S <= to) {
6008 : : if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
6009 : : S++;
6010 : : }
6011 : : limit = nonempty ? NaN : huge (limit);
6012 : : lab:
6013 : : while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
6014 : : 3) NaNs need to be supported, but it is known at compile time or cheaply
6015 : : at runtime whether array is nonempty or not, rank 1:
6016 : : limit = Infinity;
6017 : : S = from;
6018 : : while (S <= to) { if (a[S] <= limit) goto lab; S++; }
6019 : : limit = (from <= to) ? NaN : huge (limit);
6020 : : lab:
6021 : : while (S <= to) { limit = min (a[S], limit); S++; }
6022 : : 4) Array mask is used and NaNs need to be supported, rank > 1:
6023 : : limit = Infinity;
6024 : : nonempty = false;
6025 : : fast = false;
6026 : : S1 = from1;
6027 : : while (S1 <= to1) {
6028 : : S2 = from2;
6029 : : while (S2 <= to2) {
6030 : : if (mask[S1][S2]) {
6031 : : if (fast) limit = min (a[S1][S2], limit);
6032 : : else {
6033 : : nonempty = true;
6034 : : if (a[S1][S2] <= limit) {
6035 : : limit = a[S1][S2];
6036 : : fast = true;
6037 : : }
6038 : : }
6039 : : }
6040 : : S2++;
6041 : : }
6042 : : S1++;
6043 : : }
6044 : : if (!fast)
6045 : : limit = nonempty ? NaN : huge (limit);
6046 : : 5) NaNs need to be supported, but it is known at compile time or cheaply
6047 : : at runtime whether array is nonempty or not, rank > 1:
6048 : : limit = Infinity;
6049 : : fast = false;
6050 : : S1 = from1;
6051 : : while (S1 <= to1) {
6052 : : S2 = from2;
6053 : : while (S2 <= to2) {
6054 : : if (fast) limit = min (a[S1][S2], limit);
6055 : : else {
6056 : : if (a[S1][S2] <= limit) {
6057 : : limit = a[S1][S2];
6058 : : fast = true;
6059 : : }
6060 : : }
6061 : : S2++;
6062 : : }
6063 : : S1++;
6064 : : }
6065 : : if (!fast)
6066 : : limit = (nonempty_array) ? NaN : huge (limit);
6067 : : 6) NaNs aren't supported, but infinities are. Array mask is used:
6068 : : limit = Infinity;
6069 : : nonempty = false;
6070 : : S = from;
6071 : : while (S <= to) {
6072 : : if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
6073 : : S++;
6074 : : }
6075 : : limit = nonempty ? limit : huge (limit);
6076 : : 7) Same without array mask:
6077 : : limit = Infinity;
6078 : : S = from;
6079 : : while (S <= to) { limit = min (a[S], limit); S++; }
6080 : : limit = (from <= to) ? limit : huge (limit);
6081 : : 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
6082 : : limit = huge (limit);
6083 : : S = from;
6084 : : while (S <= to) { limit = min (a[S], limit); S++); }
6085 : : (or
6086 : : while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
6087 : : with array mask instead).
6088 : : For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
6089 : : setting limit = huge (limit); in the else branch. */
6090 : :
6091 : : static void
6092 : 2313 : gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
6093 : : {
6094 : 2313 : tree limit;
6095 : 2313 : tree type;
6096 : 2313 : tree tmp;
6097 : 2313 : tree ifbody;
6098 : 2313 : tree nonempty;
6099 : 2313 : tree nonempty_var;
6100 : 2313 : tree lab;
6101 : 2313 : tree fast;
6102 : 2313 : tree huge_cst = NULL, nan_cst = NULL;
6103 : 2313 : stmtblock_t body;
6104 : 2313 : stmtblock_t block, block2;
6105 : 2313 : gfc_loopinfo loop;
6106 : 2313 : gfc_actual_arglist *actual;
6107 : 2313 : gfc_ss *arrayss;
6108 : 2313 : gfc_ss *maskss;
6109 : 2313 : gfc_se arrayse;
6110 : 2313 : gfc_se maskse;
6111 : 2313 : gfc_expr *arrayexpr;
6112 : 2313 : gfc_expr *maskexpr;
6113 : 2313 : int n;
6114 : 2313 : bool optional_mask;
6115 : :
6116 : 2313 : if (se->ss)
6117 : : {
6118 : 0 : gfc_conv_intrinsic_funcall (se, expr);
6119 : 186 : return;
6120 : : }
6121 : :
6122 : 2313 : actual = expr->value.function.actual;
6123 : 2313 : arrayexpr = actual->expr;
6124 : :
6125 : 2313 : if (arrayexpr->ts.type == BT_CHARACTER)
6126 : : {
6127 : 186 : gfc_actual_arglist *dim = actual->next;
6128 : 186 : if (expr->rank == 0 && dim->expr != 0)
6129 : : {
6130 : 6 : gfc_free_expr (dim->expr);
6131 : 6 : dim->expr = NULL;
6132 : : }
6133 : 186 : gfc_conv_intrinsic_funcall (se, expr);
6134 : 186 : return;
6135 : : }
6136 : :
6137 : 2127 : type = gfc_typenode_for_spec (&expr->ts);
6138 : : /* Initialize the result. */
6139 : 2127 : limit = gfc_create_var (type, "limit");
6140 : 2127 : n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
6141 : 2127 : switch (expr->ts.type)
6142 : : {
6143 : 1196 : case BT_REAL:
6144 : 1196 : huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
6145 : : expr->ts.kind, 0);
6146 : 1196 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6147 : : {
6148 : 1192 : REAL_VALUE_TYPE real;
6149 : 1192 : real_inf (&real);
6150 : 1192 : tmp = build_real (type, real);
6151 : : }
6152 : : else
6153 : : tmp = huge_cst;
6154 : 1196 : if (HONOR_NANS (DECL_MODE (limit)))
6155 : 1192 : nan_cst = gfc_build_nan (type, "");
6156 : : break;
6157 : :
6158 : 931 : case BT_INTEGER:
6159 : 931 : tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
6160 : 931 : break;
6161 : :
6162 : 0 : default:
6163 : 0 : gcc_unreachable ();
6164 : : }
6165 : :
6166 : : /* We start with the most negative possible value for MAXVAL, and the most
6167 : : positive possible value for MINVAL. The most negative possible value is
6168 : : -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
6169 : : possible value is HUGE in both cases. */
6170 : 2127 : if (op == GT_EXPR)
6171 : : {
6172 : 913 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
6173 : 913 : if (huge_cst)
6174 : 511 : huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
6175 : 511 : TREE_TYPE (huge_cst), huge_cst);
6176 : : }
6177 : :
6178 : 2127 : if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
6179 : 402 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
6180 : 402 : tmp, build_int_cst (type, 1));
6181 : :
6182 : 2127 : gfc_add_modify (&se->pre, limit, tmp);
6183 : :
6184 : : /* Walk the arguments. */
6185 : 2127 : arrayss = gfc_walk_expr (arrayexpr);
6186 : 2127 : gcc_assert (arrayss != gfc_ss_terminator);
6187 : :
6188 : 2127 : actual = actual->next->next;
6189 : 2127 : gcc_assert (actual);
6190 : 2127 : maskexpr = actual->expr;
6191 : 1536 : optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
6192 : 1524 : && maskexpr->symtree->n.sym->attr.dummy
6193 : 3651 : && maskexpr->symtree->n.sym->attr.optional;
6194 : 1524 : nonempty = NULL;
6195 : 1536 : if (maskexpr && maskexpr->rank != 0)
6196 : : {
6197 : 990 : maskss = gfc_walk_expr (maskexpr);
6198 : 990 : gcc_assert (maskss != gfc_ss_terminator);
6199 : : }
6200 : : else
6201 : : {
6202 : 1137 : mpz_t asize;
6203 : 1137 : if (gfc_array_size (arrayexpr, &asize))
6204 : : {
6205 : 624 : nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
6206 : 624 : mpz_clear (asize);
6207 : 624 : nonempty = fold_build2_loc (input_location, GT_EXPR,
6208 : : logical_type_node, nonempty,
6209 : : gfc_index_zero_node);
6210 : : }
6211 : 1137 : maskss = NULL;
6212 : : }
6213 : :
6214 : : /* Initialize the scalarizer. */
6215 : 2127 : gfc_init_loopinfo (&loop);
6216 : :
6217 : : /* We add the mask first because the number of iterations is taken
6218 : : from the last ss, and this breaks if an absent optional argument
6219 : : is used for mask. */
6220 : :
6221 : 2127 : if (maskss)
6222 : 990 : gfc_add_ss_to_loop (&loop, maskss);
6223 : 2127 : gfc_add_ss_to_loop (&loop, arrayss);
6224 : :
6225 : : /* Initialize the loop. */
6226 : 2127 : gfc_conv_ss_startstride (&loop);
6227 : :
6228 : : /* The code generated can have more than one loop in sequence (see the
6229 : : comment at the function header). This doesn't work well with the
6230 : : scalarizer, which changes arrays' offset when the scalarization loops
6231 : : are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
6232 : : are currently inlined in the scalar case only. As there is no dependency
6233 : : to care about in that case, there is no temporary, so that we can use the
6234 : : scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
6235 : : here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
6236 : : gfc_trans_scalarized_loop_boundary even later to restore offset.
6237 : : TODO: this prevents inlining of rank > 0 minmaxval calls, so this
6238 : : should eventually go away. We could either create two loops properly,
6239 : : or find another way to save/restore the array offsets between the two
6240 : : loops (without conflicting with temporary management), or use a single
6241 : : loop minmaxval implementation. See PR 31067. */
6242 : 2127 : loop.temp_dim = loop.dimen;
6243 : 2127 : gfc_conv_loop_setup (&loop, &expr->where);
6244 : :
6245 : 2127 : if (nonempty == NULL && maskss == NULL
6246 : 513 : && loop.dimen == 1 && loop.from[0] && loop.to[0])
6247 : 477 : nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
6248 : : loop.from[0], loop.to[0]);
6249 : 2127 : nonempty_var = NULL;
6250 : 2127 : if (nonempty == NULL
6251 : 2127 : && (HONOR_INFINITIES (DECL_MODE (limit))
6252 : 468 : || HONOR_NANS (DECL_MODE (limit))))
6253 : : {
6254 : 558 : nonempty_var = gfc_create_var (logical_type_node, "nonempty");
6255 : 558 : gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
6256 : 558 : nonempty = nonempty_var;
6257 : : }
6258 : 2127 : lab = NULL;
6259 : 2127 : fast = NULL;
6260 : 2127 : if (HONOR_NANS (DECL_MODE (limit)))
6261 : : {
6262 : 1192 : if (loop.dimen == 1)
6263 : : {
6264 : 796 : lab = gfc_build_label_decl (NULL_TREE);
6265 : 796 : TREE_USED (lab) = 1;
6266 : : }
6267 : : else
6268 : : {
6269 : 396 : fast = gfc_create_var (logical_type_node, "fast");
6270 : 396 : gfc_add_modify (&se->pre, fast, logical_false_node);
6271 : : }
6272 : : }
6273 : :
6274 : 2127 : gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
6275 : 2127 : if (maskss)
6276 : 1644 : gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
6277 : : /* Generate the loop body. */
6278 : 2127 : gfc_start_scalarized_body (&loop, &body);
6279 : :
6280 : : /* If we have a mask, only add this element if the mask is set. */
6281 : 2127 : if (maskss)
6282 : : {
6283 : 990 : gfc_init_se (&maskse, NULL);
6284 : 990 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6285 : 990 : maskse.ss = maskss;
6286 : 990 : gfc_conv_expr_val (&maskse, maskexpr);
6287 : 990 : gfc_add_block_to_block (&body, &maskse.pre);
6288 : :
6289 : 990 : gfc_start_block (&block);
6290 : : }
6291 : : else
6292 : 1137 : gfc_init_block (&block);
6293 : :
6294 : : /* Compare with the current limit. */
6295 : 2127 : gfc_init_se (&arrayse, NULL);
6296 : 2127 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6297 : 2127 : arrayse.ss = arrayss;
6298 : 2127 : gfc_conv_expr_val (&arrayse, arrayexpr);
6299 : 2127 : gfc_add_block_to_block (&block, &arrayse.pre);
6300 : :
6301 : 2127 : gfc_init_block (&block2);
6302 : :
6303 : 2127 : if (nonempty_var)
6304 : 558 : gfc_add_modify (&block2, nonempty_var, logical_true_node);
6305 : :
6306 : 2127 : if (HONOR_NANS (DECL_MODE (limit)))
6307 : : {
6308 : 1873 : tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
6309 : : logical_type_node, arrayse.expr, limit);
6310 : 1192 : if (lab)
6311 : 796 : ifbody = build1_v (GOTO_EXPR, lab);
6312 : : else
6313 : : {
6314 : 396 : stmtblock_t ifblock;
6315 : :
6316 : 396 : gfc_init_block (&ifblock);
6317 : 396 : gfc_add_modify (&ifblock, limit, arrayse.expr);
6318 : 396 : gfc_add_modify (&ifblock, fast, logical_true_node);
6319 : 396 : ifbody = gfc_finish_block (&ifblock);
6320 : : }
6321 : 1192 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6322 : : build_empty_stmt (input_location));
6323 : 1192 : gfc_add_expr_to_block (&block2, tmp);
6324 : : }
6325 : : else
6326 : : {
6327 : : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6328 : : signed zeros. */
6329 : 1468 : tmp = fold_build2_loc (input_location,
6330 : : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6331 : : type, arrayse.expr, limit);
6332 : 935 : gfc_add_modify (&block2, limit, tmp);
6333 : : }
6334 : :
6335 : 2127 : if (fast)
6336 : : {
6337 : 396 : tree elsebody = gfc_finish_block (&block2);
6338 : :
6339 : : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6340 : : signed zeros. */
6341 : 396 : if (HONOR_NANS (DECL_MODE (limit)))
6342 : : {
6343 : 396 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6344 : : arrayse.expr, limit);
6345 : 396 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6346 : 396 : ifbody = build3_v (COND_EXPR, tmp, ifbody,
6347 : : build_empty_stmt (input_location));
6348 : : }
6349 : : else
6350 : : {
6351 : 0 : tmp = fold_build2_loc (input_location,
6352 : : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6353 : : type, arrayse.expr, limit);
6354 : 0 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6355 : : }
6356 : 396 : tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6357 : 396 : gfc_add_expr_to_block (&block, tmp);
6358 : : }
6359 : : else
6360 : 1731 : gfc_add_block_to_block (&block, &block2);
6361 : :
6362 : 2127 : gfc_add_block_to_block (&block, &arrayse.post);
6363 : :
6364 : 2127 : tmp = gfc_finish_block (&block);
6365 : 2127 : if (maskss)
6366 : : {
6367 : : /* We enclose the above in if (mask) {...}. If the mask is an
6368 : : optional argument, generate IF (.NOT. PRESENT(MASK)
6369 : : .OR. MASK(I)). */
6370 : 990 : tree ifmask;
6371 : 990 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6372 : 990 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6373 : : build_empty_stmt (input_location));
6374 : : }
6375 : 2127 : gfc_add_expr_to_block (&body, tmp);
6376 : :
6377 : 2127 : if (lab)
6378 : : {
6379 : 796 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6380 : :
6381 : 796 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6382 : : nan_cst, huge_cst);
6383 : 796 : gfc_add_modify (&loop.code[0], limit, tmp);
6384 : 796 : gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6385 : :
6386 : : /* If we have a mask, only add this element if the mask is set. */
6387 : 796 : if (maskss)
6388 : : {
6389 : 336 : gfc_init_se (&maskse, NULL);
6390 : 336 : gfc_copy_loopinfo_to_se (&maskse, &loop);
6391 : 336 : maskse.ss = maskss;
6392 : 336 : gfc_conv_expr_val (&maskse, maskexpr);
6393 : 336 : gfc_add_block_to_block (&body, &maskse.pre);
6394 : :
6395 : 336 : gfc_start_block (&block);
6396 : : }
6397 : : else
6398 : 460 : gfc_init_block (&block);
6399 : :
6400 : : /* Compare with the current limit. */
6401 : 796 : gfc_init_se (&arrayse, NULL);
6402 : 796 : gfc_copy_loopinfo_to_se (&arrayse, &loop);
6403 : 796 : arrayse.ss = arrayss;
6404 : 796 : gfc_conv_expr_val (&arrayse, arrayexpr);
6405 : 796 : gfc_add_block_to_block (&block, &arrayse.pre);
6406 : :
6407 : : /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6408 : : signed zeros. */
6409 : 796 : if (HONOR_NANS (DECL_MODE (limit)))
6410 : : {
6411 : 796 : tmp = fold_build2_loc (input_location, op, logical_type_node,
6412 : : arrayse.expr, limit);
6413 : 796 : ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6414 : 796 : tmp = build3_v (COND_EXPR, tmp, ifbody,
6415 : : build_empty_stmt (input_location));
6416 : 796 : gfc_add_expr_to_block (&block, tmp);
6417 : : }
6418 : : else
6419 : : {
6420 : 0 : tmp = fold_build2_loc (input_location,
6421 : : op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6422 : : type, arrayse.expr, limit);
6423 : 0 : gfc_add_modify (&block, limit, tmp);
6424 : : }
6425 : :
6426 : 796 : gfc_add_block_to_block (&block, &arrayse.post);
6427 : :
6428 : 796 : tmp = gfc_finish_block (&block);
6429 : 796 : if (maskss)
6430 : : /* We enclose the above in if (mask) {...}. */
6431 : : {
6432 : 336 : tree ifmask;
6433 : 336 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6434 : 336 : tmp = build3_v (COND_EXPR, ifmask, tmp,
6435 : : build_empty_stmt (input_location));
6436 : : }
6437 : :
6438 : 796 : gfc_add_expr_to_block (&body, tmp);
6439 : : /* Avoid initializing loopvar[0] again, it should be left where
6440 : : it finished by the first loop. */
6441 : 796 : loop.from[0] = loop.loopvar[0];
6442 : : }
6443 : 2127 : gfc_trans_scalarizing_loops (&loop, &body);
6444 : :
6445 : 2127 : if (fast)
6446 : : {
6447 : 396 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6448 : : nan_cst, huge_cst);
6449 : 396 : ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6450 : 396 : tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6451 : : ifbody);
6452 : 396 : gfc_add_expr_to_block (&loop.pre, tmp);
6453 : : }
6454 : 1731 : else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6455 : : {
6456 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6457 : : huge_cst);
6458 : 0 : gfc_add_modify (&loop.pre, limit, tmp);
6459 : : }
6460 : :
6461 : : /* For a scalar mask, enclose the loop in an if statement. */
6462 : 2127 : if (maskexpr && maskss == NULL)
6463 : : {
6464 : 546 : tree else_stmt;
6465 : 546 : tree ifmask;
6466 : :
6467 : 546 : gfc_init_se (&maskse, NULL);
6468 : 546 : gfc_conv_expr_val (&maskse, maskexpr);
6469 : 546 : gfc_init_block (&block);
6470 : 546 : gfc_add_block_to_block (&block, &loop.pre);
6471 : 546 : gfc_add_block_to_block (&block, &loop.post);
6472 : 546 : tmp = gfc_finish_block (&block);
6473 : :
6474 : 546 : if (HONOR_INFINITIES (DECL_MODE (limit)))
6475 : 354 : else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6476 : : else
6477 : 192 : else_stmt = build_empty_stmt (input_location);
6478 : :
6479 : 546 : ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6480 : 546 : tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6481 : 546 : gfc_add_expr_to_block (&block, tmp);
6482 : 546 : gfc_add_block_to_block (&se->pre, &block);
6483 : : }
6484 : : else
6485 : : {
6486 : 1581 : gfc_add_block_to_block (&se->pre, &loop.pre);
6487 : 1581 : gfc_add_block_to_block (&se->pre, &loop.post);
6488 : : }
6489 : :
6490 : 2127 : gfc_cleanup_loop (&loop);
6491 : :
6492 : 2127 : se->expr = limit;
6493 : : }
6494 : :
6495 : : /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6496 : : static void
6497 : 138 : gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6498 : : {
6499 : 138 : tree args[2];
6500 : 138 : tree type;
6501 : 138 : tree tmp;
6502 : :
6503 : 138 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6504 : 138 : type = TREE_TYPE (args[0]);
6505 : :
6506 : : /* Optionally generate code for runtime argument check. */
6507 : 138 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6508 : : {
6509 : 6 : tree below = fold_build2_loc (input_location, LT_EXPR,
6510 : : logical_type_node, args[1],
6511 : 6 : build_int_cst (TREE_TYPE (args[1]), 0));
6512 : 6 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6513 : 6 : tree above = fold_build2_loc (input_location, GE_EXPR,
6514 : : logical_type_node, args[1], nbits);
6515 : 6 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6516 : : logical_type_node, below, above);
6517 : 6 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6518 : : "POS argument (%ld) out of range 0:%ld "
6519 : : "in intrinsic BTEST",
6520 : : fold_convert (long_integer_type_node, args[1]),
6521 : : fold_convert (long_integer_type_node, nbits));
6522 : : }
6523 : :
6524 : 138 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6525 : 138 : build_int_cst (type, 1), args[1]);
6526 : 138 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6527 : 138 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6528 : 138 : build_int_cst (type, 0));
6529 : 138 : type = gfc_typenode_for_spec (&expr->ts);
6530 : 138 : se->expr = convert (type, tmp);
6531 : 138 : }
6532 : :
6533 : :
6534 : : /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6535 : : static void
6536 : 168 : gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6537 : : {
6538 : 168 : tree args[2];
6539 : :
6540 : 168 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6541 : :
6542 : : /* Convert both arguments to the unsigned type of the same size. */
6543 : 168 : args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6544 : 168 : args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6545 : :
6546 : : /* If they have unequal type size, convert to the larger one. */
6547 : 168 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
6548 : 168 : > TYPE_PRECISION (TREE_TYPE (args[1])))
6549 : 0 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6550 : 168 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6551 : 168 : > TYPE_PRECISION (TREE_TYPE (args[0])))
6552 : 0 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6553 : :
6554 : : /* Now, we compare them. */
6555 : 168 : se->expr = fold_build2_loc (input_location, op, logical_type_node,
6556 : : args[0], args[1]);
6557 : 168 : }
6558 : :
6559 : :
6560 : : /* Generate code to perform the specified operation. */
6561 : : static void
6562 : 1849 : gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6563 : : {
6564 : 1849 : tree args[2];
6565 : :
6566 : 1849 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6567 : 1849 : se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6568 : : args[0], args[1]);
6569 : 1849 : }
6570 : :
6571 : : /* Bitwise not. */
6572 : : static void
6573 : 222 : gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6574 : : {
6575 : 222 : tree arg;
6576 : :
6577 : 222 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6578 : 222 : se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6579 : 222 : TREE_TYPE (arg), arg);
6580 : 222 : }
6581 : :
6582 : : /* Set or clear a single bit. */
6583 : : static void
6584 : 282 : gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6585 : : {
6586 : 282 : tree args[2];
6587 : 282 : tree type;
6588 : 282 : tree tmp;
6589 : 282 : enum tree_code op;
6590 : :
6591 : 282 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6592 : 282 : type = TREE_TYPE (args[0]);
6593 : :
6594 : : /* Optionally generate code for runtime argument check. */
6595 : 282 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6596 : : {
6597 : 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6598 : : logical_type_node, args[1],
6599 : 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6600 : 12 : tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6601 : 12 : tree above = fold_build2_loc (input_location, GE_EXPR,
6602 : : logical_type_node, args[1], nbits);
6603 : 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6604 : : logical_type_node, below, above);
6605 : 12 : size_t len_name = strlen (expr->value.function.isym->name);
6606 : 12 : char *name = XALLOCAVEC (char, len_name + 1);
6607 : 72 : for (size_t i = 0; i < len_name; i++)
6608 : 60 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
6609 : 12 : name[len_name] = '\0';
6610 : 12 : tree iname = gfc_build_addr_expr (pchar_type_node,
6611 : : gfc_build_cstring_const (name));
6612 : 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6613 : : "POS argument (%ld) out of range 0:%ld "
6614 : : "in intrinsic %s",
6615 : : fold_convert (long_integer_type_node, args[1]),
6616 : : fold_convert (long_integer_type_node, nbits),
6617 : : iname);
6618 : : }
6619 : :
6620 : 282 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6621 : 282 : build_int_cst (type, 1), args[1]);
6622 : 282 : if (set)
6623 : : op = BIT_IOR_EXPR;
6624 : : else
6625 : : {
6626 : 156 : op = BIT_AND_EXPR;
6627 : 156 : tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6628 : : }
6629 : 282 : se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6630 : 282 : }
6631 : :
6632 : : /* Extract a sequence of bits.
6633 : : IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6634 : : static void
6635 : 27 : gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6636 : : {
6637 : 27 : tree args[3];
6638 : 27 : tree type;
6639 : 27 : tree tmp;
6640 : 27 : tree mask;
6641 : 27 : tree num_bits, cond;
6642 : :
6643 : 27 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
6644 : 27 : type = TREE_TYPE (args[0]);
6645 : :
6646 : : /* Optionally generate code for runtime argument check. */
6647 : 27 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6648 : : {
6649 : 12 : tree tmp1 = fold_convert (long_integer_type_node, args[1]);
6650 : 12 : tree tmp2 = fold_convert (long_integer_type_node, args[2]);
6651 : 36 : tree nbits = build_int_cst (long_integer_type_node,
6652 : 12 : TYPE_PRECISION (type));
6653 : 12 : tree below = fold_build2_loc (input_location, LT_EXPR,
6654 : : logical_type_node, args[1],
6655 : 12 : build_int_cst (TREE_TYPE (args[1]), 0));
6656 : 12 : tree above = fold_build2_loc (input_location, GT_EXPR,
6657 : : logical_type_node, tmp1, nbits);
6658 : 12 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6659 : : logical_type_node, below, above);
6660 : 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6661 : : "POS argument (%ld) out of range 0:%ld "
6662 : : "in intrinsic IBITS", tmp1, nbits);
6663 : 12 : below = fold_build2_loc (input_location, LT_EXPR,
6664 : : logical_type_node, args[2],
6665 : 12 : build_int_cst (TREE_TYPE (args[2]), 0));
6666 : 12 : above = fold_build2_loc (input_location, GT_EXPR,
6667 : : logical_type_node, tmp2, nbits);
6668 : 12 : scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6669 : : logical_type_node, below, above);
6670 : 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6671 : : "LEN argument (%ld) out of range 0:%ld "
6672 : : "in intrinsic IBITS", tmp2, nbits);
6673 : 12 : above = fold_build2_loc (input_location, PLUS_EXPR,
6674 : : long_integer_type_node, tmp1, tmp2);
6675 : 12 : scond = fold_build2_loc (input_location, GT_EXPR,
6676 : : logical_type_node, above, nbits);
6677 : 12 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6678 : : "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
6679 : : "in intrinsic IBITS", tmp1, tmp2, nbits);
6680 : : }
6681 : :
6682 : : /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
6683 : : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6684 : : special case. See also gfc_conv_intrinsic_ishft (). */
6685 : 27 : num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
6686 : :
6687 : 27 : mask = build_int_cst (type, -1);
6688 : 27 : mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6689 : 27 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
6690 : : num_bits);
6691 : 27 : mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
6692 : 27 : build_int_cst (type, 0), mask);
6693 : 27 : mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6694 : :
6695 : 27 : tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6696 : :
6697 : 27 : se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6698 : 27 : }
6699 : :
6700 : : static void
6701 : 351 : gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6702 : : bool arithmetic)
6703 : : {
6704 : 351 : tree args[2], type, num_bits, cond;
6705 : 351 : tree bigshift;
6706 : :
6707 : 351 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6708 : :
6709 : 351 : args[0] = gfc_evaluate_now (args[0], &se->pre);
6710 : 351 : args[1] = gfc_evaluate_now (args[1], &se->pre);
6711 : 351 : type = TREE_TYPE (args[0]);
6712 : :
6713 : 351 : if (!arithmetic)
6714 : 279 : args[0] = fold_convert (unsigned_type_for (type), args[0]);
6715 : : else
6716 : 72 : gcc_assert (right_shift);
6717 : :
6718 : 588 : se->expr = fold_build2_loc (input_location,
6719 : : right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
6720 : 351 : TREE_TYPE (args[0]), args[0], args[1]);
6721 : :
6722 : 351 : if (!arithmetic)
6723 : 279 : se->expr = fold_convert (type, se->expr);
6724 : :
6725 : 351 : if (!arithmetic)
6726 : 279 : bigshift = build_int_cst (type, 0);
6727 : : else
6728 : : {
6729 : 72 : tree nonneg = fold_build2_loc (input_location, GE_EXPR,
6730 : : logical_type_node, args[0],
6731 : 72 : build_int_cst (TREE_TYPE (args[0]), 0));
6732 : 72 : bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
6733 : 72 : build_int_cst (type, 0),
6734 : 72 : build_int_cst (type, -1));
6735 : : }
6736 : :
6737 : : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6738 : : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6739 : : special case. */
6740 : 351 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6741 : :
6742 : : /* Optionally generate code for runtime argument check. */
6743 : 351 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6744 : : {
6745 : 30 : tree below = fold_build2_loc (input_location, LT_EXPR,
6746 : : logical_type_node, args[1],
6747 : 30 : build_int_cst (TREE_TYPE (args[1]), 0));
6748 : 30 : tree above = fold_build2_loc (input_location, GT_EXPR,
6749 : : logical_type_node, args[1], num_bits);
6750 : 30 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6751 : : logical_type_node, below, above);
6752 : 30 : size_t len_name = strlen (expr->value.function.isym->name);
6753 : 30 : char *name = XALLOCAVEC (char, len_name + 1);
6754 : 210 : for (size_t i = 0; i < len_name; i++)
6755 : 180 : name[i] = TOUPPER (expr->value.function.isym->name[i]);
6756 : 30 : name[len_name] = '\0';
6757 : 30 : tree iname = gfc_build_addr_expr (pchar_type_node,
6758 : : gfc_build_cstring_const (name));
6759 : 30 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6760 : : "SHIFT argument (%ld) out of range 0:%ld "
6761 : : "in intrinsic %s",
6762 : : fold_convert (long_integer_type_node, args[1]),
6763 : : fold_convert (long_integer_type_node, num_bits),
6764 : : iname);
6765 : : }
6766 : :
6767 : 351 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6768 : : args[1], num_bits);
6769 : :
6770 : 351 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6771 : : bigshift, se->expr);
6772 : 351 : }
6773 : :
6774 : : /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6775 : : ? 0
6776 : : : ((shift >= 0) ? i << shift : i >> -shift)
6777 : : where all shifts are logical shifts. */
6778 : : static void
6779 : 252 : gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
6780 : : {
6781 : 252 : tree args[2];
6782 : 252 : tree type;
6783 : 252 : tree utype;
6784 : 252 : tree tmp;
6785 : 252 : tree width;
6786 : 252 : tree num_bits;
6787 : 252 : tree cond;
6788 : 252 : tree lshift;
6789 : 252 : tree rshift;
6790 : :
6791 : 252 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
6792 : :
6793 : 252 : args[0] = gfc_evaluate_now (args[0], &se->pre);
6794 : 252 : args[1] = gfc_evaluate_now (args[1], &se->pre);
6795 : :
6796 : 252 : type = TREE_TYPE (args[0]);
6797 : 252 : utype = unsigned_type_for (type);
6798 : :
6799 : 252 : width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
6800 : : args[1]);
6801 : :
6802 : : /* Left shift if positive. */
6803 : 252 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
6804 : :
6805 : : /* Right shift if negative.
6806 : : We convert to an unsigned type because we want a logical shift.
6807 : : The standard doesn't define the case of shifting negative
6808 : : numbers, and we try to be compatible with other compilers, most
6809 : : notably g77, here. */
6810 : 252 : rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
6811 : : utype, convert (utype, args[0]), width));
6812 : :
6813 : 252 : tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
6814 : 252 : build_int_cst (TREE_TYPE (args[1]), 0));
6815 : 252 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
6816 : :
6817 : : /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6818 : : gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6819 : : special case. */
6820 : 252 : num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6821 : :
6822 : : /* Optionally generate code for runtime argument check. */
6823 : 252 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6824 : : {
6825 : 24 : tree outside = fold_build2_loc (input_location, GT_EXPR,
6826 : : logical_type_node, width, num_bits);
6827 : 24 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
6828 : : "SHIFT argument (%ld) out of range -%ld:%ld "
6829 : : "in intrinsic ISHFT",
6830 : : fold_convert (long_integer_type_node, args[1]),
6831 : : fold_convert (long_integer_type_node, num_bits),
6832 : : fold_convert (long_integer_type_node, num_bits));
6833 : : }
6834 : :
6835 : 252 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
6836 : : num_bits);
6837 : 252 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6838 : 252 : build_int_cst (type, 0), tmp);
6839 : 252 : }
6840 : :
6841 : :
6842 : : /* Circular shift. AKA rotate or barrel shift. */
6843 : :
6844 : : static void
6845 : 622 : gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
6846 : : {
6847 : 622 : tree *args;
6848 : 622 : tree type;
6849 : 622 : tree tmp;
6850 : 622 : tree lrot;
6851 : 622 : tree rrot;
6852 : 622 : tree zero;
6853 : 622 : tree nbits;
6854 : 622 : unsigned int num_args;
6855 : :
6856 : 622 : num_args = gfc_intrinsic_argument_list_length (expr);
6857 : 622 : args = XALLOCAVEC (tree, num_args);
6858 : :
6859 : 622 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6860 : :
6861 : 622 : type = TREE_TYPE (args[0]);
6862 : 622 : nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
6863 : :
6864 : 622 : if (num_args == 3)
6865 : : {
6866 : 550 : gfc_expr *size = expr->value.function.actual->next->next->expr;
6867 : :
6868 : : /* Use a library function for the 3 parameter version. */
6869 : 550 : tree int4type = gfc_get_int_type (4);
6870 : :
6871 : : /* Treat optional SIZE argument when it is passed as an optional
6872 : : dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
6873 : 550 : if (size->expr_type == EXPR_VARIABLE
6874 : 438 : && size->symtree->n.sym->attr.dummy
6875 : 438 : && size->symtree->n.sym->attr.optional)
6876 : : {
6877 : 36 : tree type_of_size = TREE_TYPE (args[2]);
6878 : 72 : args[2] = build3_loc (input_location, COND_EXPR, type_of_size,
6879 : 36 : gfc_conv_expr_present (size->symtree->n.sym),
6880 : : args[2], fold_convert (type_of_size, nbits));
6881 : : }
6882 : :
6883 : : /* We convert the first argument to at least 4 bytes, and
6884 : : convert back afterwards. This removes the need for library
6885 : : functions for all argument sizes, and function will be
6886 : : aligned to at least 32 bits, so there's no loss. */
6887 : 550 : if (expr->ts.kind < 4)
6888 : 242 : args[0] = convert (int4type, args[0]);
6889 : :
6890 : : /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6891 : : need loads of library functions. They cannot have values >
6892 : : BIT_SIZE (I) so the conversion is safe. */
6893 : 550 : args[1] = convert (int4type, args[1]);
6894 : 550 : args[2] = convert (int4type, args[2]);
6895 : :
6896 : : /* Optionally generate code for runtime argument check. */
6897 : 550 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6898 : : {
6899 : 18 : tree size = fold_convert (long_integer_type_node, args[2]);
6900 : 18 : tree below = fold_build2_loc (input_location, LE_EXPR,
6901 : : logical_type_node, size,
6902 : 18 : build_int_cst (TREE_TYPE (args[1]), 0));
6903 : 18 : tree above = fold_build2_loc (input_location, GT_EXPR,
6904 : : logical_type_node, size, nbits);
6905 : 18 : tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6906 : : logical_type_node, below, above);
6907 : 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6908 : : "SIZE argument (%ld) out of range 1:%ld "
6909 : : "in intrinsic ISHFTC", size, nbits);
6910 : 18 : tree width = fold_convert (long_integer_type_node, args[1]);
6911 : 18 : width = fold_build1_loc (input_location, ABS_EXPR,
6912 : : long_integer_type_node, width);
6913 : 18 : scond = fold_build2_loc (input_location, GT_EXPR,
6914 : : logical_type_node, width, size);
6915 : 18 : gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
6916 : : "SHIFT argument (%ld) out of range -%ld:%ld "
6917 : : "in intrinsic ISHFTC",
6918 : : fold_convert (long_integer_type_node, args[1]),
6919 : : size, size);
6920 : : }
6921 : :
6922 : 550 : switch (expr->ts.kind)
6923 : : {
6924 : 426 : case 1:
6925 : 426 : case 2:
6926 : 426 : case 4:
6927 : 426 : tmp = gfor_fndecl_math_ishftc4;
6928 : 426 : break;
6929 : 124 : case 8:
6930 : 124 : tmp = gfor_fndecl_math_ishftc8;
6931 : 124 : break;
6932 : 0 : case 16:
6933 : 0 : tmp = gfor_fndecl_math_ishftc16;
6934 : 0 : break;
6935 : 0 : default:
6936 : 0 : gcc_unreachable ();
6937 : : }
6938 : 550 : se->expr = build_call_expr_loc (input_location,
6939 : : tmp, 3, args[0], args[1], args[2]);
6940 : : /* Convert the result back to the original type, if we extended
6941 : : the first argument's width above. */
6942 : 550 : if (expr->ts.kind < 4)
6943 : 242 : se->expr = convert (type, se->expr);
6944 : :
6945 : 550 : return;
6946 : : }
6947 : :
6948 : : /* Evaluate arguments only once. */
6949 : 72 : args[0] = gfc_evaluate_now (args[0], &se->pre);
6950 : 72 : args[1] = gfc_evaluate_now (args[1], &se->pre);
6951 : :
6952 : : /* Optionally generate code for runtime argument check. */
6953 : 72 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
6954 : : {
6955 : 12 : tree width = fold_convert (long_integer_type_node, args[1]);
6956 : 12 : width = fold_build1_loc (input_location, ABS_EXPR,
6957 : : long_integer_type_node, width);
6958 : 12 : tree outside = fold_build2_loc (input_location, GT_EXPR,
6959 : : logical_type_node, width, nbits);
6960 : 12 : gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
6961 : : "SHIFT argument (%ld) out of range -%ld:%ld "
6962 : : "in intrinsic ISHFTC",
6963 : : fold_convert (long_integer_type_node, args[1]),
6964 : : nbits, nbits);
6965 : : }
6966 : :
6967 : : /* Rotate left if positive. */
6968 : 72 : lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
6969 : :
6970 : : /* Rotate right if negative. */
6971 : 72 : tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
6972 : : args[1]);
6973 : 72 : rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
6974 : :
6975 : 72 : zero = build_int_cst (TREE_TYPE (args[1]), 0);
6976 : 72 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
6977 : : zero);
6978 : 72 : rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
6979 : :
6980 : : /* Do nothing if shift == 0. */
6981 : 72 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
6982 : : zero);
6983 : 72 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
6984 : : rrot);
6985 : : }
6986 : :
6987 : :
6988 : : /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
6989 : : : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
6990 : :
6991 : : The conditional expression is necessary because the result of LEADZ(0)
6992 : : is defined, but the result of __builtin_clz(0) is undefined for most
6993 : : targets.
6994 : :
6995 : : For INTEGER kinds smaller than the C 'int' type, we have to subtract the
6996 : : difference in bit size between the argument of LEADZ and the C int. */
6997 : :
6998 : : static void
6999 : 270 : gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
7000 : : {
7001 : 270 : tree arg;
7002 : 270 : tree arg_type;
7003 : 270 : tree cond;
7004 : 270 : tree result_type;
7005 : 270 : tree leadz;
7006 : 270 : tree bit_size;
7007 : 270 : tree tmp;
7008 : 270 : tree func;
7009 : 270 : int s, argsize;
7010 : :
7011 : 270 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7012 : 270 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7013 : :
7014 : : /* Which variant of __builtin_clz* should we call? */
7015 : 270 : if (argsize <= INT_TYPE_SIZE)
7016 : : {
7017 : 183 : arg_type = unsigned_type_node;
7018 : 183 : func = builtin_decl_explicit (BUILT_IN_CLZ);
7019 : : }
7020 : 87 : else if (argsize <= LONG_TYPE_SIZE)
7021 : : {
7022 : 57 : arg_type = long_unsigned_type_node;
7023 : 57 : func = builtin_decl_explicit (BUILT_IN_CLZL);
7024 : : }
7025 : 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7026 : : {
7027 : 0 : arg_type = long_long_unsigned_type_node;
7028 : 0 : func = builtin_decl_explicit (BUILT_IN_CLZLL);
7029 : : }
7030 : : else
7031 : : {
7032 : 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7033 : 30 : arg_type = gfc_build_uint_type (argsize);
7034 : 30 : func = NULL_TREE;
7035 : : }
7036 : :
7037 : : /* Convert the actual argument twice: first, to the unsigned type of the
7038 : : same size; then, to the proper argument type for the built-in
7039 : : function. But the return type is of the default INTEGER kind. */
7040 : 270 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7041 : 270 : arg = fold_convert (arg_type, arg);
7042 : 270 : arg = gfc_evaluate_now (arg, &se->pre);
7043 : 270 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7044 : :
7045 : : /* Compute LEADZ for the case i .ne. 0. */
7046 : 270 : if (func)
7047 : : {
7048 : 240 : s = TYPE_PRECISION (arg_type) - argsize;
7049 : 240 : tmp = fold_convert (result_type,
7050 : : build_call_expr_loc (input_location, func,
7051 : : 1, arg));
7052 : 240 : leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
7053 : : tmp, build_int_cst (result_type, s));
7054 : : }
7055 : : else
7056 : : {
7057 : : /* We end up here if the argument type is larger than 'long long'.
7058 : : We generate this code:
7059 : :
7060 : : if (x & (ULL_MAX << ULL_SIZE) != 0)
7061 : : return clzll ((unsigned long long) (x >> ULLSIZE));
7062 : : else
7063 : : return ULL_SIZE + clzll ((unsigned long long) x);
7064 : : where ULL_MAX is the largest value that a ULL_MAX can hold
7065 : : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7066 : : is the bit-size of the long long type (64 in this example). */
7067 : 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7068 : :
7069 : 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7070 : 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7071 : : long_long_unsigned_type_node,
7072 : : build_int_cst (long_long_unsigned_type_node,
7073 : 30 : 0));
7074 : :
7075 : 30 : cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
7076 : : fold_convert (arg_type, ullmax), ullsize);
7077 : 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
7078 : : arg, cond);
7079 : 30 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7080 : 30 : cond, build_int_cst (arg_type, 0));
7081 : :
7082 : 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7083 : : arg, ullsize);
7084 : 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7085 : 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7086 : 30 : tmp1 = fold_convert (result_type,
7087 : : build_call_expr_loc (input_location, btmp, 1, tmp1));
7088 : :
7089 : 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7090 : 30 : btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
7091 : 30 : tmp2 = fold_convert (result_type,
7092 : : build_call_expr_loc (input_location, btmp, 1, tmp2));
7093 : 30 : tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7094 : : tmp2, ullsize);
7095 : :
7096 : 30 : leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
7097 : : cond, tmp1, tmp2);
7098 : : }
7099 : :
7100 : : /* Build BIT_SIZE. */
7101 : 270 : bit_size = build_int_cst (result_type, argsize);
7102 : :
7103 : 270 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7104 : 270 : arg, build_int_cst (arg_type, 0));
7105 : 270 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7106 : : bit_size, leadz);
7107 : 270 : }
7108 : :
7109 : :
7110 : : /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
7111 : :
7112 : : The conditional expression is necessary because the result of TRAILZ(0)
7113 : : is defined, but the result of __builtin_ctz(0) is undefined for most
7114 : : targets. */
7115 : :
7116 : : static void
7117 : 282 : gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
7118 : : {
7119 : 282 : tree arg;
7120 : 282 : tree arg_type;
7121 : 282 : tree cond;
7122 : 282 : tree result_type;
7123 : 282 : tree trailz;
7124 : 282 : tree bit_size;
7125 : 282 : tree func;
7126 : 282 : int argsize;
7127 : :
7128 : 282 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7129 : 282 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7130 : :
7131 : : /* Which variant of __builtin_ctz* should we call? */
7132 : 282 : if (argsize <= INT_TYPE_SIZE)
7133 : : {
7134 : 195 : arg_type = unsigned_type_node;
7135 : 195 : func = builtin_decl_explicit (BUILT_IN_CTZ);
7136 : : }
7137 : 87 : else if (argsize <= LONG_TYPE_SIZE)
7138 : : {
7139 : 57 : arg_type = long_unsigned_type_node;
7140 : 57 : func = builtin_decl_explicit (BUILT_IN_CTZL);
7141 : : }
7142 : 30 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7143 : : {
7144 : 0 : arg_type = long_long_unsigned_type_node;
7145 : 0 : func = builtin_decl_explicit (BUILT_IN_CTZLL);
7146 : : }
7147 : : else
7148 : : {
7149 : 30 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7150 : 30 : arg_type = gfc_build_uint_type (argsize);
7151 : 30 : func = NULL_TREE;
7152 : : }
7153 : :
7154 : : /* Convert the actual argument twice: first, to the unsigned type of the
7155 : : same size; then, to the proper argument type for the built-in
7156 : : function. But the return type is of the default INTEGER kind. */
7157 : 282 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7158 : 282 : arg = fold_convert (arg_type, arg);
7159 : 282 : arg = gfc_evaluate_now (arg, &se->pre);
7160 : 282 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7161 : :
7162 : : /* Compute TRAILZ for the case i .ne. 0. */
7163 : 282 : if (func)
7164 : 252 : trailz = fold_convert (result_type, build_call_expr_loc (input_location,
7165 : : func, 1, arg));
7166 : : else
7167 : : {
7168 : : /* We end up here if the argument type is larger than 'long long'.
7169 : : We generate this code:
7170 : :
7171 : : if ((x & ULL_MAX) == 0)
7172 : : return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
7173 : : else
7174 : : return ctzll ((unsigned long long) x);
7175 : :
7176 : : where ULL_MAX is the largest value that a ULL_MAX can hold
7177 : : (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
7178 : : is the bit-size of the long long type (64 in this example). */
7179 : 30 : tree ullsize, ullmax, tmp1, tmp2, btmp;
7180 : :
7181 : 30 : ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
7182 : 30 : ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
7183 : : long_long_unsigned_type_node,
7184 : 30 : build_int_cst (long_long_unsigned_type_node, 0));
7185 : :
7186 : 30 : cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
7187 : : fold_convert (arg_type, ullmax));
7188 : 30 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
7189 : 30 : build_int_cst (arg_type, 0));
7190 : :
7191 : 30 : tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
7192 : : arg, ullsize);
7193 : 30 : tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
7194 : 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7195 : 30 : tmp1 = fold_convert (result_type,
7196 : : build_call_expr_loc (input_location, btmp, 1, tmp1));
7197 : 30 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
7198 : : tmp1, ullsize);
7199 : :
7200 : 30 : tmp2 = fold_convert (long_long_unsigned_type_node, arg);
7201 : 30 : btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
7202 : 30 : tmp2 = fold_convert (result_type,
7203 : : build_call_expr_loc (input_location, btmp, 1, tmp2));
7204 : :
7205 : 30 : trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
7206 : : cond, tmp1, tmp2);
7207 : : }
7208 : :
7209 : : /* Build BIT_SIZE. */
7210 : 282 : bit_size = build_int_cst (result_type, argsize);
7211 : :
7212 : 282 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7213 : 282 : arg, build_int_cst (arg_type, 0));
7214 : 282 : se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
7215 : : bit_size, trailz);
7216 : 282 : }
7217 : :
7218 : : /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
7219 : : for types larger than "long long", we call the long long built-in for
7220 : : the lower and higher bits and combine the result. */
7221 : :
7222 : : static void
7223 : 134 : gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
7224 : : {
7225 : 134 : tree arg;
7226 : 134 : tree arg_type;
7227 : 134 : tree result_type;
7228 : 134 : tree func;
7229 : 134 : int argsize;
7230 : :
7231 : 134 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7232 : 134 : argsize = TYPE_PRECISION (TREE_TYPE (arg));
7233 : 134 : result_type = gfc_get_int_type (gfc_default_integer_kind);
7234 : :
7235 : : /* Which variant of the builtin should we call? */
7236 : 134 : if (argsize <= INT_TYPE_SIZE)
7237 : : {
7238 : 108 : arg_type = unsigned_type_node;
7239 : 198 : func = builtin_decl_explicit (parity
7240 : : ? BUILT_IN_PARITY
7241 : : : BUILT_IN_POPCOUNT);
7242 : : }
7243 : 26 : else if (argsize <= LONG_TYPE_SIZE)
7244 : : {
7245 : 12 : arg_type = long_unsigned_type_node;
7246 : 18 : func = builtin_decl_explicit (parity
7247 : : ? BUILT_IN_PARITYL
7248 : : : BUILT_IN_POPCOUNTL);
7249 : : }
7250 : 14 : else if (argsize <= LONG_LONG_TYPE_SIZE)
7251 : : {
7252 : 0 : arg_type = long_long_unsigned_type_node;
7253 : 0 : func = builtin_decl_explicit (parity
7254 : : ? BUILT_IN_PARITYLL
7255 : : : BUILT_IN_POPCOUNTLL);
7256 : : }
7257 : : else
7258 : : {
7259 : : /* Our argument type is larger than 'long long', which mean none
7260 : : of the POPCOUNT builtins covers it. We thus call the 'long long'
7261 : : variant multiple times, and add the results. */
7262 : 14 : tree utype, arg2, call1, call2;
7263 : :
7264 : : /* For now, we only cover the case where argsize is twice as large
7265 : : as 'long long'. */
7266 : 14 : gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
7267 : :
7268 : 21 : func = builtin_decl_explicit (parity
7269 : : ? BUILT_IN_PARITYLL
7270 : : : BUILT_IN_POPCOUNTLL);
7271 : :
7272 : : /* Convert it to an integer, and store into a variable. */
7273 : 14 : utype = gfc_build_uint_type (argsize);
7274 : 14 : arg = fold_convert (utype, arg);
7275 : 14 : arg = gfc_evaluate_now (arg, &se->pre);
7276 : :
7277 : : /* Call the builtin twice. */
7278 : 14 : call1 = build_call_expr_loc (input_location, func, 1,
7279 : : fold_convert (long_long_unsigned_type_node,
7280 : : arg));
7281 : :
7282 : 14 : arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
7283 : 14 : build_int_cst (utype, LONG_LONG_TYPE_SIZE));
7284 : 14 : call2 = build_call_expr_loc (input_location, func, 1,
7285 : : fold_convert (long_long_unsigned_type_node,
7286 : : arg2));
7287 : :
7288 : : /* Combine the results. */
7289 : 14 : if (parity)
7290 : 7 : se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR,
7291 : : integer_type_node, call1, call2);
7292 : : else
7293 : 7 : se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7294 : : integer_type_node, call1, call2);
7295 : :
7296 : 14 : se->expr = convert (result_type, se->expr);
7297 : 14 : return;
7298 : : }
7299 : :
7300 : : /* Convert the actual argument twice: first, to the unsigned type of the
7301 : : same size; then, to the proper argument type for the built-in
7302 : : function. */
7303 : 120 : arg = fold_convert (gfc_build_uint_type (argsize), arg);
7304 : 120 : arg = fold_convert (arg_type, arg);
7305 : :
7306 : 120 : se->expr = fold_convert (result_type,
7307 : : build_call_expr_loc (input_location, func, 1, arg));
7308 : : }
7309 : :
7310 : :
7311 : : /* Process an intrinsic with unspecified argument-types that has an optional
7312 : : argument (which could be of type character), e.g. EOSHIFT. For those, we
7313 : : need to append the string length of the optional argument if it is not
7314 : : present and the type is really character.
7315 : : primary specifies the position (starting at 1) of the non-optional argument
7316 : : specifying the type and optional gives the position of the optional
7317 : : argument in the arglist. */
7318 : :
7319 : : static void
7320 : 3990 : conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
7321 : : unsigned primary, unsigned optional)
7322 : : {
7323 : 3990 : gfc_actual_arglist* prim_arg;
7324 : 3990 : gfc_actual_arglist* opt_arg;
7325 : 3990 : unsigned cur_pos;
7326 : 3990 : gfc_actual_arglist* arg;
7327 : 3990 : gfc_symbol* sym;
7328 : 3990 : vec<tree, va_gc> *append_args;
7329 : :
7330 : : /* Find the two arguments given as position. */
7331 : 3990 : cur_pos = 0;
7332 : 3990 : prim_arg = NULL;
7333 : 3990 : opt_arg = NULL;
7334 : 11970 : for (arg = expr->value.function.actual; arg; arg = arg->next)
7335 : : {
7336 : 11970 : ++cur_pos;
7337 : :
7338 : 11970 : if (cur_pos == primary)
7339 : 3990 : prim_arg = arg;
7340 : 11970 : if (cur_pos == optional)
7341 : 3990 : opt_arg = arg;
7342 : :
7343 : 11970 : if (cur_pos >= primary && cur_pos >= optional)
7344 : : break;
7345 : : }
7346 : 3990 : gcc_assert (prim_arg);
7347 : 3990 : gcc_assert (prim_arg->expr);
7348 : 3990 : gcc_assert (opt_arg);
7349 : :
7350 : : /* If we do have type CHARACTER and the optional argument is really absent,
7351 : : append a dummy 0 as string length. */
7352 : 3990 : append_args = NULL;
7353 : 3990 : if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
7354 : : {
7355 : 564 : tree dummy;
7356 : :
7357 : 564 : dummy = build_int_cst (gfc_charlen_type_node, 0);
7358 : 564 : vec_alloc (append_args, 1);
7359 : 564 : append_args->quick_push (dummy);
7360 : : }
7361 : :
7362 : : /* Build the call itself. */
7363 : 3990 : gcc_assert (!se->ignore_optional);
7364 : 3990 : sym = gfc_get_symbol_for_expr (expr, false);
7365 : 3990 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7366 : : append_args);
7367 : 3990 : gfc_free_symbol (sym);
7368 : 3990 : }
7369 : :
7370 : : /* The length of a character string. */
7371 : : static void
7372 : 5228 : gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
7373 : : {
7374 : 5228 : tree len;
7375 : 5228 : tree type;
7376 : 5228 : tree decl;
7377 : 5228 : gfc_symbol *sym;
7378 : 5228 : gfc_se argse;
7379 : 5228 : gfc_expr *arg;
7380 : :
7381 : 5228 : gcc_assert (!se->ss);
7382 : :
7383 : 5228 : arg = expr->value.function.actual->expr;
7384 : :
7385 : 5228 : type = gfc_typenode_for_spec (&expr->ts);
7386 : 5228 : switch (arg->expr_type)
7387 : : {
7388 : 0 : case EXPR_CONSTANT:
7389 : 0 : len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
7390 : 0 : break;
7391 : :
7392 : 2 : case EXPR_ARRAY:
7393 : : /* Obtain the string length from the function used by
7394 : : trans-array.cc(gfc_trans_array_constructor). */
7395 : 2 : len = NULL_TREE;
7396 : 2 : get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
7397 : 2 : break;
7398 : :
7399 : 4685 : case EXPR_VARIABLE:
7400 : 4685 : if (arg->ref == NULL
7401 : 2059 : || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
7402 : : {
7403 : : /* This doesn't catch all cases.
7404 : : See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
7405 : : and the surrounding thread. */
7406 : 4165 : sym = arg->symtree->n.sym;
7407 : 4165 : decl = gfc_get_symbol_decl (sym);
7408 : 4165 : if (decl == current_function_decl && sym->attr.function
7409 : 29 : && (sym->result == sym))
7410 : 29 : decl = gfc_get_fake_result_decl (sym, 0);
7411 : :
7412 : 4165 : len = sym->ts.u.cl->backend_decl;
7413 : 4165 : gcc_assert (len);
7414 : : break;
7415 : : }
7416 : :
7417 : : /* Fall through. */
7418 : :
7419 : 1061 : default:
7420 : 1061 : gfc_init_se (&argse, se);
7421 : 1061 : if (arg->rank == 0)
7422 : 944 : gfc_conv_expr (&argse, arg);
7423 : : else
7424 : 117 : gfc_conv_expr_descriptor (&argse, arg);
7425 : 1061 : gfc_add_block_to_block (&se->pre, &argse.pre);
7426 : 1061 : gfc_add_block_to_block (&se->post, &argse.post);
7427 : 1061 : len = argse.string_length;
7428 : 1061 : break;
7429 : : }
7430 : 5228 : se->expr = convert (type, len);
7431 : 5228 : }
7432 : :
7433 : : /* The length of a character string not including trailing blanks. */
7434 : : static void
7435 : 2273 : gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
7436 : : {
7437 : 2273 : int kind = expr->value.function.actual->expr->ts.kind;
7438 : 2273 : tree args[2], type, fndecl;
7439 : :
7440 : 2273 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7441 : 2273 : type = gfc_typenode_for_spec (&expr->ts);
7442 : :
7443 : 2273 : if (kind == 1)
7444 : 1896 : fndecl = gfor_fndecl_string_len_trim;
7445 : 377 : else if (kind == 4)
7446 : 377 : fndecl = gfor_fndecl_string_len_trim_char4;
7447 : : else
7448 : 0 : gcc_unreachable ();
7449 : :
7450 : 2273 : se->expr = build_call_expr_loc (input_location,
7451 : : fndecl, 2, args[0], args[1]);
7452 : 2273 : se->expr = convert (type, se->expr);
7453 : 2273 : }
7454 : :
7455 : :
7456 : : /* Returns the starting position of a substring within a string. */
7457 : :
7458 : : static void
7459 : 738 : gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
7460 : : tree function)
7461 : : {
7462 : 738 : tree logical4_type_node = gfc_get_logical_type (4);
7463 : 738 : tree type;
7464 : 738 : tree fndecl;
7465 : 738 : tree *args;
7466 : 738 : unsigned int num_args;
7467 : :
7468 : 738 : args = XALLOCAVEC (tree, 5);
7469 : :
7470 : : /* Get number of arguments; characters count double due to the
7471 : : string length argument. Kind= is not passed to the library
7472 : : and thus ignored. */
7473 : 738 : if (expr->value.function.actual->next->next->expr == NULL)
7474 : : num_args = 4;
7475 : : else
7476 : 304 : num_args = 5;
7477 : :
7478 : 738 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7479 : 738 : type = gfc_typenode_for_spec (&expr->ts);
7480 : :
7481 : 738 : if (num_args == 4)
7482 : 434 : args[4] = build_int_cst (logical4_type_node, 0);
7483 : : else
7484 : 304 : args[4] = convert (logical4_type_node, args[4]);
7485 : :
7486 : 738 : fndecl = build_addr (function);
7487 : 738 : se->expr = build_call_array_loc (input_location,
7488 : 738 : TREE_TYPE (TREE_TYPE (function)), fndecl,
7489 : : 5, args);
7490 : 738 : se->expr = convert (type, se->expr);
7491 : :
7492 : 738 : }
7493 : :
7494 : : /* The ascii value for a single character. */
7495 : : static void
7496 : 1971 : gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7497 : : {
7498 : 1971 : tree args[3], type, pchartype;
7499 : 1971 : int nargs;
7500 : :
7501 : 1971 : nargs = gfc_intrinsic_argument_list_length (expr);
7502 : 1971 : gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7503 : 1971 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7504 : 1971 : pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7505 : 1971 : args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7506 : 1971 : type = gfc_typenode_for_spec (&expr->ts);
7507 : :
7508 : 1971 : se->expr = build_fold_indirect_ref_loc (input_location,
7509 : : args[1]);
7510 : 1971 : se->expr = convert (type, se->expr);
7511 : 1971 : }
7512 : :
7513 : :
7514 : : /* Intrinsic ISNAN calls __builtin_isnan. */
7515 : :
7516 : : static void
7517 : 432 : gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7518 : : {
7519 : 432 : tree arg;
7520 : :
7521 : 432 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7522 : 432 : se->expr = build_call_expr_loc (input_location,
7523 : : builtin_decl_explicit (BUILT_IN_ISNAN),
7524 : : 1, arg);
7525 : 864 : STRIP_TYPE_NOPS (se->expr);
7526 : 432 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7527 : 432 : }
7528 : :
7529 : :
7530 : : /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7531 : : their argument against a constant integer value. */
7532 : :
7533 : : static void
7534 : 24 : gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7535 : : {
7536 : 24 : tree arg;
7537 : :
7538 : 24 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7539 : 24 : se->expr = fold_build2_loc (input_location, EQ_EXPR,
7540 : : gfc_typenode_for_spec (&expr->ts),
7541 : 24 : arg, build_int_cst (TREE_TYPE (arg), value));
7542 : 24 : }
7543 : :
7544 : :
7545 : :
7546 : : /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7547 : :
7548 : : static void
7549 : 917 : gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7550 : : {
7551 : 917 : tree tsource;
7552 : 917 : tree fsource;
7553 : 917 : tree mask;
7554 : 917 : tree type;
7555 : 917 : tree len, len2;
7556 : 917 : tree *args;
7557 : 917 : unsigned int num_args;
7558 : :
7559 : 917 : num_args = gfc_intrinsic_argument_list_length (expr);
7560 : 917 : args = XALLOCAVEC (tree, num_args);
7561 : :
7562 : 917 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7563 : 917 : if (expr->ts.type != BT_CHARACTER)
7564 : : {
7565 : 385 : tsource = args[0];
7566 : 385 : fsource = args[1];
7567 : 385 : mask = args[2];
7568 : : }
7569 : : else
7570 : : {
7571 : : /* We do the same as in the non-character case, but the argument
7572 : : list is different because of the string length arguments. We
7573 : : also have to set the string length for the result. */
7574 : 532 : len = args[0];
7575 : 532 : tsource = args[1];
7576 : 532 : len2 = args[2];
7577 : 532 : fsource = args[3];
7578 : 532 : mask = args[4];
7579 : :
7580 : 532 : gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7581 : : &se->pre);
7582 : 532 : se->string_length = len;
7583 : : }
7584 : 917 : tsource = gfc_evaluate_now (tsource, &se->pre);
7585 : 917 : fsource = gfc_evaluate_now (fsource, &se->pre);
7586 : 917 : mask = gfc_evaluate_now (mask, &se->pre);
7587 : 917 : type = TREE_TYPE (tsource);
7588 : 917 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7589 : : fold_convert (type, fsource));
7590 : 917 : }
7591 : :
7592 : :
7593 : : /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7594 : :
7595 : : static void
7596 : 30 : gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7597 : : {
7598 : 30 : tree args[3], mask, type;
7599 : :
7600 : 30 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
7601 : 30 : mask = gfc_evaluate_now (args[2], &se->pre);
7602 : :
7603 : 30 : type = TREE_TYPE (args[0]);
7604 : 30 : gcc_assert (TREE_TYPE (args[1]) == type);
7605 : 30 : gcc_assert (TREE_TYPE (mask) == type);
7606 : :
7607 : 30 : args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7608 : 30 : args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7609 : : fold_build1_loc (input_location, BIT_NOT_EXPR,
7610 : : type, mask));
7611 : 30 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7612 : : args[0], args[1]);
7613 : 30 : }
7614 : :
7615 : :
7616 : : /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7617 : : MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7618 : :
7619 : : static void
7620 : 64 : gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7621 : : {
7622 : 64 : tree arg, allones, type, utype, res, cond, bitsize;
7623 : 64 : int i;
7624 : :
7625 : 64 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7626 : 64 : arg = gfc_evaluate_now (arg, &se->pre);
7627 : :
7628 : 64 : type = gfc_get_int_type (expr->ts.kind);
7629 : 64 : utype = unsigned_type_for (type);
7630 : :
7631 : 64 : i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7632 : 64 : bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7633 : :
7634 : 64 : allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7635 : 64 : build_int_cst (utype, 0));
7636 : :
7637 : 64 : if (left)
7638 : : {
7639 : : /* Left-justified mask. */
7640 : 32 : res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7641 : : bitsize, arg);
7642 : 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7643 : : fold_convert (utype, res));
7644 : :
7645 : : /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7646 : : smaller than type width. */
7647 : 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7648 : 32 : build_int_cst (TREE_TYPE (arg), 0));
7649 : 32 : res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7650 : 32 : build_int_cst (utype, 0), res);
7651 : : }
7652 : : else
7653 : : {
7654 : : /* Right-justified mask. */
7655 : 32 : res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7656 : : fold_convert (utype, arg));
7657 : 32 : res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7658 : :
7659 : : /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7660 : : strictly smaller than type width. */
7661 : 32 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7662 : : arg, bitsize);
7663 : 32 : res = fold_build3_loc (input_location, COND_EXPR, utype,
7664 : : cond, allones, res);
7665 : : }
7666 : :
7667 : 64 : se->expr = fold_convert (type, res);
7668 : 64 : }
7669 : :
7670 : :
7671 : : /* FRACTION (s) is translated into:
7672 : : isfinite (s) ? frexp (s, &dummy_int) : NaN */
7673 : : static void
7674 : 60 : gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7675 : : {
7676 : 60 : tree arg, type, tmp, res, frexp, cond;
7677 : :
7678 : 60 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7679 : :
7680 : 60 : type = gfc_typenode_for_spec (&expr->ts);
7681 : 60 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7682 : 60 : arg = gfc_evaluate_now (arg, &se->pre);
7683 : :
7684 : 60 : cond = build_call_expr_loc (input_location,
7685 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
7686 : : 1, arg);
7687 : :
7688 : 60 : tmp = gfc_create_var (integer_type_node, NULL);
7689 : 60 : res = build_call_expr_loc (input_location, frexp, 2,
7690 : : fold_convert (type, arg),
7691 : : gfc_build_addr_expr (NULL_TREE, tmp));
7692 : 60 : res = fold_convert (type, res);
7693 : :
7694 : 60 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7695 : : cond, res, gfc_build_nan (type, ""));
7696 : 60 : }
7697 : :
7698 : :
7699 : : /* NEAREST (s, dir) is translated into
7700 : : tmp = copysign (HUGE_VAL, dir);
7701 : : return nextafter (s, tmp);
7702 : : */
7703 : : static void
7704 : 1610 : gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
7705 : : {
7706 : 1610 : tree args[2], type, tmp, nextafter, copysign, huge_val;
7707 : :
7708 : 1610 : nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
7709 : 1610 : copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
7710 : :
7711 : 1610 : type = gfc_typenode_for_spec (&expr->ts);
7712 : 1610 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7713 : :
7714 : 1610 : huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
7715 : 1610 : tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
7716 : : fold_convert (type, args[1]));
7717 : 1610 : se->expr = build_call_expr_loc (input_location, nextafter, 2,
7718 : : fold_convert (type, args[0]), tmp);
7719 : 1610 : se->expr = fold_convert (type, se->expr);
7720 : 1610 : }
7721 : :
7722 : :
7723 : : /* SPACING (s) is translated into
7724 : : int e;
7725 : : if (!isfinite (s))
7726 : : res = NaN;
7727 : : else if (s == 0)
7728 : : res = tiny;
7729 : : else
7730 : : {
7731 : : frexp (s, &e);
7732 : : e = e - prec;
7733 : : e = MAX_EXPR (e, emin);
7734 : : res = scalbn (1., e);
7735 : : }
7736 : : return res;
7737 : :
7738 : : where prec is the precision of s, gfc_real_kinds[k].digits,
7739 : : emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7740 : : and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7741 : :
7742 : : static void
7743 : 70 : gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
7744 : : {
7745 : 70 : tree arg, type, prec, emin, tiny, res, e;
7746 : 70 : tree cond, nan, tmp, frexp, scalbn;
7747 : 70 : int k;
7748 : 70 : stmtblock_t block;
7749 : :
7750 : 70 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
7751 : 70 : prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
7752 : 70 : emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
7753 : 70 : tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
7754 : :
7755 : 70 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7756 : 70 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7757 : :
7758 : 70 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7759 : 70 : arg = gfc_evaluate_now (arg, &se->pre);
7760 : :
7761 : 70 : type = gfc_typenode_for_spec (&expr->ts);
7762 : 70 : e = gfc_create_var (integer_type_node, NULL);
7763 : 70 : res = gfc_create_var (type, NULL);
7764 : :
7765 : :
7766 : : /* Build the block for s /= 0. */
7767 : 70 : gfc_start_block (&block);
7768 : 70 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
7769 : : gfc_build_addr_expr (NULL_TREE, e));
7770 : 70 : gfc_add_expr_to_block (&block, tmp);
7771 : :
7772 : 70 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
7773 : : prec);
7774 : 70 : gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
7775 : : integer_type_node, tmp, emin));
7776 : :
7777 : 70 : tmp = build_call_expr_loc (input_location, scalbn, 2,
7778 : 70 : build_real_from_int_cst (type, integer_one_node), e);
7779 : 70 : gfc_add_modify (&block, res, tmp);
7780 : :
7781 : : /* Finish by building the IF statement for value zero. */
7782 : 70 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7783 : 70 : build_real_from_int_cst (type, integer_zero_node));
7784 : 70 : tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
7785 : : gfc_finish_block (&block));
7786 : :
7787 : : /* And deal with infinities and NaNs. */
7788 : 70 : cond = build_call_expr_loc (input_location,
7789 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
7790 : : 1, arg);
7791 : 70 : nan = gfc_build_nan (type, "");
7792 : 70 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
7793 : :
7794 : 70 : gfc_add_expr_to_block (&se->pre, tmp);
7795 : 70 : se->expr = res;
7796 : 70 : }
7797 : :
7798 : :
7799 : : /* RRSPACING (s) is translated into
7800 : : int e;
7801 : : real x;
7802 : : x = fabs (s);
7803 : : if (isfinite (x))
7804 : : {
7805 : : if (x != 0)
7806 : : {
7807 : : frexp (s, &e);
7808 : : x = scalbn (x, precision - e);
7809 : : }
7810 : : }
7811 : : else
7812 : : x = NaN;
7813 : : return x;
7814 : :
7815 : : where precision is gfc_real_kinds[k].digits. */
7816 : :
7817 : : static void
7818 : 48 : gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
7819 : : {
7820 : 48 : tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
7821 : 48 : int prec, k;
7822 : 48 : stmtblock_t block;
7823 : :
7824 : 48 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
7825 : 48 : prec = gfc_real_kinds[k].digits;
7826 : :
7827 : 48 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7828 : 48 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7829 : 48 : fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
7830 : :
7831 : 48 : type = gfc_typenode_for_spec (&expr->ts);
7832 : 48 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7833 : 48 : arg = gfc_evaluate_now (arg, &se->pre);
7834 : :
7835 : 48 : e = gfc_create_var (integer_type_node, NULL);
7836 : 48 : x = gfc_create_var (type, NULL);
7837 : 48 : gfc_add_modify (&se->pre, x,
7838 : : build_call_expr_loc (input_location, fabs, 1, arg));
7839 : :
7840 : :
7841 : 48 : gfc_start_block (&block);
7842 : 48 : tmp = build_call_expr_loc (input_location, frexp, 2, arg,
7843 : : gfc_build_addr_expr (NULL_TREE, e));
7844 : 48 : gfc_add_expr_to_block (&block, tmp);
7845 : :
7846 : 48 : tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
7847 : : build_int_cst (integer_type_node, prec), e);
7848 : 48 : tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
7849 : 48 : gfc_add_modify (&block, x, tmp);
7850 : 48 : stmt = gfc_finish_block (&block);
7851 : :
7852 : : /* if (x != 0) */
7853 : 48 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
7854 : 48 : build_real_from_int_cst (type, integer_zero_node));
7855 : 48 : tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
7856 : :
7857 : : /* And deal with infinities and NaNs. */
7858 : 48 : cond = build_call_expr_loc (input_location,
7859 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
7860 : : 1, x);
7861 : 48 : nan = gfc_build_nan (type, "");
7862 : 48 : tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
7863 : :
7864 : 48 : gfc_add_expr_to_block (&se->pre, tmp);
7865 : 48 : se->expr = fold_convert (type, x);
7866 : 48 : }
7867 : :
7868 : :
7869 : : /* SCALE (s, i) is translated into scalbn (s, i). */
7870 : : static void
7871 : 72 : gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
7872 : : {
7873 : 72 : tree args[2], type, scalbn;
7874 : :
7875 : 72 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7876 : :
7877 : 72 : type = gfc_typenode_for_spec (&expr->ts);
7878 : 72 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7879 : 72 : se->expr = build_call_expr_loc (input_location, scalbn, 2,
7880 : : fold_convert (type, args[0]),
7881 : : fold_convert (integer_type_node, args[1]));
7882 : 72 : se->expr = fold_convert (type, se->expr);
7883 : 72 : }
7884 : :
7885 : :
7886 : : /* SET_EXPONENT (s, i) is translated into
7887 : : isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7888 : : static void
7889 : 262 : gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
7890 : : {
7891 : 262 : tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
7892 : :
7893 : 262 : frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7894 : 262 : scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7895 : :
7896 : 262 : type = gfc_typenode_for_spec (&expr->ts);
7897 : 262 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
7898 : 262 : args[0] = gfc_evaluate_now (args[0], &se->pre);
7899 : :
7900 : 262 : tmp = gfc_create_var (integer_type_node, NULL);
7901 : 262 : tmp = build_call_expr_loc (input_location, frexp, 2,
7902 : : fold_convert (type, args[0]),
7903 : : gfc_build_addr_expr (NULL_TREE, tmp));
7904 : 262 : res = build_call_expr_loc (input_location, scalbn, 2, tmp,
7905 : : fold_convert (integer_type_node, args[1]));
7906 : 262 : res = fold_convert (type, res);
7907 : :
7908 : : /* Call to isfinite */
7909 : 262 : cond = build_call_expr_loc (input_location,
7910 : : builtin_decl_explicit (BUILT_IN_ISFINITE),
7911 : : 1, args[0]);
7912 : 262 : nan = gfc_build_nan (type, "");
7913 : :
7914 : 262 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7915 : : res, nan);
7916 : 262 : }
7917 : :
7918 : :
7919 : : static void
7920 : 13312 : gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
7921 : : {
7922 : 13312 : gfc_actual_arglist *actual;
7923 : 13312 : tree arg1;
7924 : 13312 : tree type;
7925 : 13312 : tree size;
7926 : 13312 : gfc_se argse;
7927 : 13312 : gfc_expr *e;
7928 : 13312 : gfc_symbol *sym = NULL;
7929 : :
7930 : 13312 : gfc_init_se (&argse, NULL);
7931 : 13312 : actual = expr->value.function.actual;
7932 : :
7933 : 13312 : if (actual->expr->ts.type == BT_CLASS)
7934 : 547 : gfc_add_class_array_ref (actual->expr);
7935 : :
7936 : 13312 : e = actual->expr;
7937 : :
7938 : : /* These are emerging from the interface mapping, when a class valued
7939 : : function appears as the rhs in a realloc on assign statement, where
7940 : : the size of the result is that of one of the actual arguments. */
7941 : 13312 : if (e->expr_type == EXPR_VARIABLE
7942 : 12865 : && e->symtree->n.sym->ns == NULL /* This is distinctive! */
7943 : 531 : && e->symtree->n.sym->ts.type == BT_CLASS
7944 : 44 : && e->ref && e->ref->type == REF_COMPONENT
7945 : 26 : && strcmp (e->ref->u.c.component->name, "_data") == 0)
7946 : 13312 : sym = e->symtree->n.sym;
7947 : :
7948 : 13312 : if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER)
7949 : : && e
7950 : 899 : && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION))
7951 : : {
7952 : 899 : symbol_attribute attr;
7953 : 899 : char *msg;
7954 : 899 : tree temp;
7955 : 899 : tree cond;
7956 : :
7957 : 899 : if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym))
7958 : : {
7959 : 32 : attr = CLASS_DATA (e->symtree->n.sym)->attr;
7960 : 32 : attr.pointer = attr.class_pointer;
7961 : : }
7962 : : else
7963 : 867 : attr = gfc_expr_attr (e);
7964 : :
7965 : 899 : if (attr.allocatable)
7966 : 150 : msg = xasprintf ("Allocatable argument '%s' is not allocated",
7967 : 150 : e->symtree->n.sym->name);
7968 : 749 : else if (attr.pointer)
7969 : 42 : msg = xasprintf ("Pointer argument '%s' is not associated",
7970 : 42 : e->symtree->n.sym->name);
7971 : : else
7972 : 707 : goto end_arg_check;
7973 : :
7974 : 192 : if (sym)
7975 : : {
7976 : 0 : temp = gfc_class_data_get (sym->backend_decl);
7977 : 0 : temp = gfc_conv_descriptor_data_get (temp);
7978 : : }
7979 : : else
7980 : : {
7981 : 192 : argse.descriptor_only = 1;
7982 : 192 : gfc_conv_expr_descriptor (&argse, actual->expr);
7983 : 192 : temp = gfc_conv_descriptor_data_get (argse.expr);
7984 : : }
7985 : :
7986 : 192 : cond = fold_build2_loc (input_location, EQ_EXPR,
7987 : : logical_type_node, temp,
7988 : 192 : fold_convert (TREE_TYPE (temp),
7989 : : null_pointer_node));
7990 : 192 : gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
7991 : :
7992 : 192 : free (msg);
7993 : : }
7994 : 12413 : end_arg_check:
7995 : :
7996 : 13312 : argse.data_not_needed = 1;
7997 : 13312 : if (gfc_is_class_array_function (e))
7998 : : {
7999 : : /* For functions that return a class array conv_expr_descriptor is not
8000 : : able to get the descriptor right. Therefore this special case. */
8001 : 6 : gfc_conv_expr_reference (&argse, e);
8002 : 6 : argse.expr = gfc_class_data_get (argse.expr);
8003 : : }
8004 : 13306 : else if (sym && sym->backend_decl)
8005 : : {
8006 : 14 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
8007 : 14 : argse.expr = gfc_class_data_get (sym->backend_decl);
8008 : : }
8009 : : else
8010 : 13292 : gfc_conv_expr_descriptor (&argse, actual->expr);
8011 : 13312 : gfc_add_block_to_block (&se->pre, &argse.pre);
8012 : 13312 : gfc_add_block_to_block (&se->post, &argse.post);
8013 : 13312 : arg1 = argse.expr;
8014 : :
8015 : 13312 : actual = actual->next;
8016 : 13312 : if (actual->expr)
8017 : : {
8018 : 7854 : stmtblock_t block;
8019 : 7854 : gfc_init_block (&block);
8020 : 7854 : gfc_init_se (&argse, NULL);
8021 : 7854 : gfc_conv_expr_type (&argse, actual->expr,
8022 : : gfc_array_index_type);
8023 : 7854 : gfc_add_block_to_block (&block, &argse.pre);
8024 : 7854 : tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8025 : : argse.expr, gfc_index_one_node);
8026 : 7854 : size = gfc_tree_array_size (&block, arg1, e, tmp);
8027 : :
8028 : : /* Unusually, for an intrinsic, size does not exclude
8029 : : an optional arg2, so we must test for it. */
8030 : 7854 : if (actual->expr->expr_type == EXPR_VARIABLE
8031 : 1875 : && actual->expr->symtree->n.sym->attr.dummy
8032 : 1875 : && actual->expr->symtree->n.sym->attr.optional)
8033 : : {
8034 : 31 : tree cond;
8035 : 31 : stmtblock_t block2;
8036 : 31 : gfc_init_block (&block2);
8037 : 31 : gfc_init_se (&argse, NULL);
8038 : 31 : argse.want_pointer = 1;
8039 : 31 : argse.data_not_needed = 1;
8040 : 31 : gfc_conv_expr (&argse, actual->expr);
8041 : 31 : gfc_add_block_to_block (&se->pre, &argse.pre);
8042 : : /* 'block2' contains the arg2 absent case, 'block' the arg2 present
8043 : : case; size_var can be used in both blocks. */
8044 : 31 : tree size_var = gfc_create_var (TREE_TYPE (size), "size");
8045 : 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8046 : 31 : TREE_TYPE (size_var), size_var, size);
8047 : 31 : gfc_add_expr_to_block (&block, tmp);
8048 : 31 : size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
8049 : 31 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8050 : 31 : TREE_TYPE (size_var), size_var, size);
8051 : 31 : gfc_add_expr_to_block (&block2, tmp);
8052 : 31 : cond = gfc_conv_expr_present (actual->expr->symtree->n.sym);
8053 : 31 : tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
8054 : : gfc_finish_block (&block2));
8055 : 31 : gfc_add_expr_to_block (&se->pre, tmp);
8056 : 31 : size = size_var;
8057 : 31 : }
8058 : : else
8059 : 7823 : gfc_add_block_to_block (&se->pre, &block);
8060 : : }
8061 : : else
8062 : 5458 : size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
8063 : 13312 : type = gfc_typenode_for_spec (&expr->ts);
8064 : 13312 : se->expr = convert (type, size);
8065 : 13312 : }
8066 : :
8067 : :
8068 : : /* Helper function to compute the size of a character variable,
8069 : : excluding the terminating null characters. The result has
8070 : : gfc_array_index_type type. */
8071 : :
8072 : : tree
8073 : 1724 : size_of_string_in_bytes (int kind, tree string_length)
8074 : : {
8075 : 1724 : tree bytesize;
8076 : 1724 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
8077 : :
8078 : 3448 : bytesize = build_int_cst (gfc_array_index_type,
8079 : 1724 : gfc_character_kinds[i].bit_size / 8);
8080 : :
8081 : 1724 : return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8082 : : bytesize,
8083 : 1724 : fold_convert (gfc_array_index_type, string_length));
8084 : : }
8085 : :
8086 : :
8087 : : static void
8088 : 1268 : gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
8089 : : {
8090 : 1268 : gfc_expr *arg;
8091 : 1268 : gfc_se argse;
8092 : 1268 : tree source_bytes;
8093 : 1268 : tree tmp;
8094 : 1268 : tree lower;
8095 : 1268 : tree upper;
8096 : 1268 : tree byte_size;
8097 : 1268 : tree field;
8098 : 1268 : int n;
8099 : :
8100 : 1268 : gfc_init_se (&argse, NULL);
8101 : 1268 : arg = expr->value.function.actual->expr;
8102 : :
8103 : 1268 : if (arg->rank || arg->ts.type == BT_ASSUMED)
8104 : 986 : gfc_conv_expr_descriptor (&argse, arg);
8105 : : else
8106 : 282 : gfc_conv_expr_reference (&argse, arg);
8107 : :
8108 : 1268 : if (arg->ts.type == BT_ASSUMED)
8109 : : {
8110 : : /* This only works if an array descriptor has been passed; thus, extract
8111 : : the size from the descriptor. */
8112 : 164 : gcc_assert (TYPE_PRECISION (gfc_array_index_type)
8113 : : == TYPE_PRECISION (size_type_node));
8114 : 164 : tmp = arg->symtree->n.sym->backend_decl;
8115 : 164 : tmp = DECL_LANG_SPECIFIC (tmp)
8116 : 60 : && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
8117 : 218 : ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
8118 : 164 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8119 : 164 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8120 : :
8121 : 164 : tmp = gfc_conv_descriptor_dtype (tmp);
8122 : 164 : field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
8123 : : GFC_DTYPE_ELEM_LEN);
8124 : 164 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8125 : : tmp, field, NULL_TREE);
8126 : :
8127 : 164 : byte_size = fold_convert (gfc_array_index_type, tmp);
8128 : : }
8129 : 1104 : else if (arg->ts.type == BT_CLASS)
8130 : : {
8131 : : /* Conv_expr_descriptor returns a component_ref to _data component of the
8132 : : class object. The class object may be a non-pointer object, e.g.
8133 : : located on the stack, or a memory location pointed to, e.g. a
8134 : : parameter, i.e., an indirect_ref. */
8135 : 944 : if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
8136 : 574 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
8137 : 198 : byte_size
8138 : 198 : = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
8139 : 376 : else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
8140 : 0 : byte_size = gfc_class_vtab_size_get (argse.expr);
8141 : 376 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr))
8142 : 376 : && TREE_CODE (argse.expr) == COMPONENT_REF)
8143 : 328 : byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8144 : 48 : else if (arg->rank > 0
8145 : 6 : || (arg->rank == 0
8146 : 6 : && arg->ref && arg->ref->type == REF_COMPONENT))
8147 : : /* The scalarizer added an additional temp. To get the class' vptr
8148 : : one has to look at the original backend_decl. */
8149 : 96 : byte_size = gfc_class_vtab_size_get (
8150 : 48 : GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8151 : : else
8152 : 0 : gcc_unreachable ();
8153 : : }
8154 : : else
8155 : : {
8156 : 530 : if (arg->ts.type == BT_CHARACTER)
8157 : 84 : byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8158 : : else
8159 : : {
8160 : 446 : if (arg->rank == 0)
8161 : 0 : byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8162 : : argse.expr));
8163 : : else
8164 : 446 : byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
8165 : 446 : byte_size = fold_convert (gfc_array_index_type,
8166 : : size_in_bytes (byte_size));
8167 : : }
8168 : : }
8169 : :
8170 : 1268 : if (arg->rank == 0)
8171 : 282 : se->expr = byte_size;
8172 : : else
8173 : : {
8174 : 986 : source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
8175 : 986 : gfc_add_modify (&argse.pre, source_bytes, byte_size);
8176 : :
8177 : 986 : if (arg->rank == -1)
8178 : : {
8179 : 357 : tree cond, loop_var, exit_label;
8180 : 357 : stmtblock_t body;
8181 : :
8182 : 357 : tmp = fold_convert (gfc_array_index_type,
8183 : : gfc_conv_descriptor_rank (argse.expr));
8184 : 357 : loop_var = gfc_create_var (gfc_array_index_type, "i");
8185 : 357 : gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
8186 : 357 : exit_label = gfc_build_label_decl (NULL_TREE);
8187 : :
8188 : : /* Create loop:
8189 : : for (;;)
8190 : : {
8191 : : if (i >= rank)
8192 : : goto exit;
8193 : : source_bytes = source_bytes * array.dim[i].extent;
8194 : : i = i + 1;
8195 : : }
8196 : : exit: */
8197 : 357 : gfc_start_block (&body);
8198 : 357 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
8199 : : loop_var, tmp);
8200 : 357 : tmp = build1_v (GOTO_EXPR, exit_label);
8201 : 357 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8202 : : cond, tmp, build_empty_stmt (input_location));
8203 : 357 : gfc_add_expr_to_block (&body, tmp);
8204 : :
8205 : 357 : lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
8206 : 357 : upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
8207 : 357 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8208 : 357 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8209 : : gfc_array_index_type, tmp, source_bytes);
8210 : 357 : gfc_add_modify (&body, source_bytes, tmp);
8211 : :
8212 : 357 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8213 : : gfc_array_index_type, loop_var,
8214 : : gfc_index_one_node);
8215 : 357 : gfc_add_modify_loc (input_location, &body, loop_var, tmp);
8216 : :
8217 : 357 : tmp = gfc_finish_block (&body);
8218 : :
8219 : 357 : tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
8220 : : tmp);
8221 : 357 : gfc_add_expr_to_block (&argse.pre, tmp);
8222 : :
8223 : 357 : tmp = build1_v (LABEL_EXPR, exit_label);
8224 : 357 : gfc_add_expr_to_block (&argse.pre, tmp);
8225 : : }
8226 : : else
8227 : : {
8228 : : /* Obtain the size of the array in bytes. */
8229 : 1798 : for (n = 0; n < arg->rank; n++)
8230 : : {
8231 : 1169 : tree idx;
8232 : 1169 : idx = gfc_rank_cst[n];
8233 : 1169 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8234 : 1169 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8235 : 1169 : tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
8236 : 1169 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8237 : : gfc_array_index_type, tmp, source_bytes);
8238 : 1169 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8239 : : }
8240 : : }
8241 : 986 : se->expr = source_bytes;
8242 : : }
8243 : :
8244 : 1268 : gfc_add_block_to_block (&se->pre, &argse.pre);
8245 : 1268 : }
8246 : :
8247 : :
8248 : : static void
8249 : 700 : gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
8250 : : {
8251 : 700 : gfc_expr *arg;
8252 : 700 : gfc_se argse;
8253 : 700 : tree type, result_type, tmp;
8254 : :
8255 : 700 : arg = expr->value.function.actual->expr;
8256 : :
8257 : 700 : gfc_init_se (&argse, NULL);
8258 : 700 : result_type = gfc_get_int_type (expr->ts.kind);
8259 : :
8260 : 700 : if (arg->rank == 0)
8261 : : {
8262 : 157 : if (arg->ts.type == BT_CLASS)
8263 : : {
8264 : 44 : gfc_add_vptr_component (arg);
8265 : 44 : gfc_add_size_component (arg);
8266 : 44 : gfc_conv_expr (&argse, arg);
8267 : 44 : tmp = fold_convert (result_type, argse.expr);
8268 : 44 : goto done;
8269 : : }
8270 : :
8271 : 113 : gfc_conv_expr_reference (&argse, arg);
8272 : 113 : type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8273 : : argse.expr));
8274 : : }
8275 : : else
8276 : : {
8277 : 543 : argse.want_pointer = 0;
8278 : 543 : gfc_conv_expr_descriptor (&argse, arg);
8279 : 543 : if (arg->ts.type == BT_CLASS)
8280 : : {
8281 : 12 : if (arg->rank > 0)
8282 : 12 : tmp = gfc_class_vtab_size_get (
8283 : 6 : GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
8284 : : else
8285 : 6 : tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
8286 : 12 : tmp = fold_convert (result_type, tmp);
8287 : 12 : goto done;
8288 : : }
8289 : 531 : type = gfc_get_element_type (TREE_TYPE (argse.expr));
8290 : : }
8291 : :
8292 : : /* Obtain the argument's word length. */
8293 : 644 : if (arg->ts.type == BT_CHARACTER)
8294 : 241 : tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
8295 : : else
8296 : 403 : tmp = size_in_bytes (type);
8297 : 644 : tmp = fold_convert (result_type, tmp);
8298 : :
8299 : 700 : done:
8300 : 700 : se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
8301 : 700 : build_int_cst (result_type, BITS_PER_UNIT));
8302 : 700 : gfc_add_block_to_block (&se->pre, &argse.pre);
8303 : 700 : }
8304 : :
8305 : :
8306 : : /* Intrinsic string comparison functions. */
8307 : :
8308 : : static void
8309 : 99 : gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
8310 : : {
8311 : 99 : tree args[4];
8312 : :
8313 : 99 : gfc_conv_intrinsic_function_args (se, expr, args, 4);
8314 : :
8315 : 99 : se->expr
8316 : 198 : = gfc_build_compare_string (args[0], args[1], args[2], args[3],
8317 : 99 : expr->value.function.actual->expr->ts.kind,
8318 : : op);
8319 : 99 : se->expr = fold_build2_loc (input_location, op,
8320 : : gfc_typenode_for_spec (&expr->ts), se->expr,
8321 : 99 : build_int_cst (TREE_TYPE (se->expr), 0));
8322 : 99 : }
8323 : :
8324 : : /* Generate a call to the adjustl/adjustr library function. */
8325 : : static void
8326 : 455 : gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
8327 : : {
8328 : 455 : tree args[3];
8329 : 455 : tree len;
8330 : 455 : tree type;
8331 : 455 : tree var;
8332 : 455 : tree tmp;
8333 : :
8334 : 455 : gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
8335 : 455 : len = args[1];
8336 : :
8337 : 455 : type = TREE_TYPE (args[2]);
8338 : 455 : var = gfc_conv_string_tmp (se, type, len);
8339 : 455 : args[0] = var;
8340 : :
8341 : 455 : tmp = build_call_expr_loc (input_location,
8342 : : fndecl, 3, args[0], args[1], args[2]);
8343 : 455 : gfc_add_expr_to_block (&se->pre, tmp);
8344 : 455 : se->expr = var;
8345 : 455 : se->string_length = len;
8346 : 455 : }
8347 : :
8348 : :
8349 : : /* Generate code for the TRANSFER intrinsic:
8350 : : For scalar results:
8351 : : DEST = TRANSFER (SOURCE, MOLD)
8352 : : where:
8353 : : typeof<DEST> = typeof<MOLD>
8354 : : and:
8355 : : MOLD is scalar.
8356 : :
8357 : : For array results:
8358 : : DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
8359 : : where:
8360 : : typeof<DEST> = typeof<MOLD>
8361 : : and:
8362 : : N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
8363 : : sizeof (DEST(0) * SIZE). */
8364 : : static void
8365 : 3101 : gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
8366 : : {
8367 : 3101 : tree tmp;
8368 : 3101 : tree tmpdecl;
8369 : 3101 : tree ptr;
8370 : 3101 : tree extent;
8371 : 3101 : tree source;
8372 : 3101 : tree source_type;
8373 : 3101 : tree source_bytes;
8374 : 3101 : tree mold_type;
8375 : 3101 : tree dest_word_len;
8376 : 3101 : tree size_words;
8377 : 3101 : tree size_bytes;
8378 : 3101 : tree upper;
8379 : 3101 : tree lower;
8380 : 3101 : tree stmt;
8381 : 3101 : tree class_ref = NULL_TREE;
8382 : 3101 : gfc_actual_arglist *arg;
8383 : 3101 : gfc_se argse;
8384 : 3101 : gfc_array_info *info;
8385 : 3101 : stmtblock_t block;
8386 : 3101 : int n;
8387 : 3101 : bool scalar_mold;
8388 : 3101 : gfc_expr *source_expr, *mold_expr, *class_expr;
8389 : :
8390 : 3101 : info = NULL;
8391 : 3101 : if (se->loop)
8392 : 432 : info = &se->ss->info->data.array;
8393 : :
8394 : : /* Convert SOURCE. The output from this stage is:-
8395 : : source_bytes = length of the source in bytes
8396 : : source = pointer to the source data. */
8397 : 3101 : arg = expr->value.function.actual;
8398 : 3101 : source_expr = arg->expr;
8399 : :
8400 : : /* Ensure double transfer through LOGICAL preserves all
8401 : : the needed bits. */
8402 : 3101 : if (arg->expr->expr_type == EXPR_FUNCTION
8403 : 2179 : && arg->expr->value.function.esym == NULL
8404 : 2167 : && arg->expr->value.function.isym != NULL
8405 : 2167 : && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
8406 : 12 : && arg->expr->ts.type == BT_LOGICAL
8407 : 12 : && expr->ts.type != arg->expr->ts.type)
8408 : 12 : arg->expr->value.function.name = "__transfer_in_transfer";
8409 : :
8410 : 3101 : gfc_init_se (&argse, NULL);
8411 : :
8412 : 3101 : source_bytes = gfc_create_var (gfc_array_index_type, NULL);
8413 : :
8414 : : /* Obtain the pointer to source and the length of source in bytes. */
8415 : 3101 : if (arg->expr->rank == 0)
8416 : : {
8417 : 2795 : gfc_conv_expr_reference (&argse, arg->expr);
8418 : 2795 : if (arg->expr->ts.type == BT_CLASS)
8419 : : {
8420 : 19 : tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
8421 : 19 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8422 : 7 : source = gfc_class_data_get (tmp);
8423 : : else
8424 : : {
8425 : : /* Array elements are evaluated as a reference to the data.
8426 : : To obtain the vptr for the element size, the argument
8427 : : expression must be stripped to the class reference and
8428 : : re-evaluated. The pre and post blocks are not needed. */
8429 : 12 : gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
8430 : 12 : source = argse.expr;
8431 : 12 : class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
8432 : 12 : gfc_init_se (&argse, NULL);
8433 : 12 : gfc_conv_expr (&argse, class_expr);
8434 : 12 : class_ref = argse.expr;
8435 : : }
8436 : : }
8437 : : else
8438 : 2776 : source = argse.expr;
8439 : :
8440 : : /* Obtain the source word length. */
8441 : 2795 : switch (arg->expr->ts.type)
8442 : : {
8443 : 303 : case BT_CHARACTER:
8444 : 303 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8445 : : argse.string_length);
8446 : 303 : break;
8447 : 19 : case BT_CLASS:
8448 : 19 : if (class_ref != NULL_TREE)
8449 : 12 : tmp = gfc_class_vtab_size_get (class_ref);
8450 : : else
8451 : 7 : tmp = gfc_class_vtab_size_get (argse.expr);
8452 : : break;
8453 : 2473 : default:
8454 : 2473 : source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8455 : : source));
8456 : 2473 : tmp = fold_convert (gfc_array_index_type,
8457 : : size_in_bytes (source_type));
8458 : 2473 : break;
8459 : : }
8460 : : }
8461 : : else
8462 : : {
8463 : 306 : argse.want_pointer = 0;
8464 : 306 : gfc_conv_expr_descriptor (&argse, arg->expr);
8465 : 306 : source = gfc_conv_descriptor_data_get (argse.expr);
8466 : 306 : source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8467 : :
8468 : : /* Repack the source if not simply contiguous. */
8469 : 306 : if (!gfc_is_simply_contiguous (arg->expr, false, true))
8470 : : {
8471 : 50 : tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
8472 : :
8473 : 50 : if (warn_array_temporaries)
8474 : 0 : gfc_warning (OPT_Warray_temporaries,
8475 : : "Creating array temporary at %L", &expr->where);
8476 : :
8477 : 50 : source = build_call_expr_loc (input_location,
8478 : : gfor_fndecl_in_pack, 1, tmp);
8479 : 50 : source = gfc_evaluate_now (source, &argse.pre);
8480 : :
8481 : : /* Free the temporary. */
8482 : 50 : gfc_start_block (&block);
8483 : 50 : tmp = gfc_call_free (source);
8484 : 50 : gfc_add_expr_to_block (&block, tmp);
8485 : 50 : stmt = gfc_finish_block (&block);
8486 : :
8487 : : /* Clean up if it was repacked. */
8488 : 50 : gfc_init_block (&block);
8489 : 50 : tmp = gfc_conv_array_data (argse.expr);
8490 : 50 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8491 : : source, tmp);
8492 : 50 : tmp = build3_v (COND_EXPR, tmp, stmt,
8493 : : build_empty_stmt (input_location));
8494 : 50 : gfc_add_expr_to_block (&block, tmp);
8495 : 50 : gfc_add_block_to_block (&block, &se->post);
8496 : 50 : gfc_init_block (&se->post);
8497 : 50 : gfc_add_block_to_block (&se->post, &block);
8498 : : }
8499 : :
8500 : : /* Obtain the source word length. */
8501 : 306 : if (arg->expr->ts.type == BT_CHARACTER)
8502 : 149 : tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8503 : : argse.string_length);
8504 : : else
8505 : 157 : tmp = fold_convert (gfc_array_index_type,
8506 : : size_in_bytes (source_type));
8507 : :
8508 : : /* Obtain the size of the array in bytes. */
8509 : 306 : extent = gfc_create_var (gfc_array_index_type, NULL);
8510 : 642 : for (n = 0; n < arg->expr->rank; n++)
8511 : : {
8512 : 336 : tree idx;
8513 : 336 : idx = gfc_rank_cst[n];
8514 : 336 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8515 : 336 : lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8516 : 336 : upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8517 : 336 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8518 : : gfc_array_index_type, upper, lower);
8519 : 336 : gfc_add_modify (&argse.pre, extent, tmp);
8520 : 336 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
8521 : : gfc_array_index_type, extent,
8522 : : gfc_index_one_node);
8523 : 336 : tmp = fold_build2_loc (input_location, MULT_EXPR,
8524 : : gfc_array_index_type, tmp, source_bytes);
8525 : : }
8526 : : }
8527 : :
8528 : 3101 : gfc_add_modify (&argse.pre, source_bytes, tmp);
8529 : 3101 : gfc_add_block_to_block (&se->pre, &argse.pre);
8530 : 3101 : gfc_add_block_to_block (&se->post, &argse.post);
8531 : :
8532 : : /* Now convert MOLD. The outputs are:
8533 : : mold_type = the TREE type of MOLD
8534 : : dest_word_len = destination word length in bytes. */
8535 : 3101 : arg = arg->next;
8536 : 3101 : mold_expr = arg->expr;
8537 : :
8538 : 3101 : gfc_init_se (&argse, NULL);
8539 : :
8540 : 3101 : scalar_mold = arg->expr->rank == 0;
8541 : :
8542 : 3101 : if (arg->expr->rank == 0)
8543 : : {
8544 : 2828 : gfc_conv_expr_reference (&argse, arg->expr);
8545 : 2828 : mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8546 : : argse.expr));
8547 : : }
8548 : : else
8549 : : {
8550 : 273 : gfc_init_se (&argse, NULL);
8551 : 273 : argse.want_pointer = 0;
8552 : 273 : gfc_conv_expr_descriptor (&argse, arg->expr);
8553 : 273 : mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8554 : : }
8555 : :
8556 : 3101 : gfc_add_block_to_block (&se->pre, &argse.pre);
8557 : 3101 : gfc_add_block_to_block (&se->post, &argse.post);
8558 : :
8559 : 3101 : if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8560 : : {
8561 : : /* If this TRANSFER is nested in another TRANSFER, use a type
8562 : : that preserves all bits. */
8563 : 12 : if (arg->expr->ts.type == BT_LOGICAL)
8564 : 12 : mold_type = gfc_get_int_type (arg->expr->ts.kind);
8565 : : }
8566 : :
8567 : : /* Obtain the destination word length. */
8568 : 3101 : switch (arg->expr->ts.type)
8569 : : {
8570 : 423 : case BT_CHARACTER:
8571 : 423 : tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
8572 : 423 : mold_type = gfc_get_character_type_len (arg->expr->ts.kind,
8573 : : argse.string_length);
8574 : 423 : break;
8575 : 6 : case BT_CLASS:
8576 : 6 : tmp = gfc_class_vtab_size_get (argse.expr);
8577 : 6 : break;
8578 : 2672 : default:
8579 : 2672 : tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8580 : 2672 : break;
8581 : : }
8582 : 3101 : dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8583 : 3101 : gfc_add_modify (&se->pre, dest_word_len, tmp);
8584 : :
8585 : : /* Finally convert SIZE, if it is present. */
8586 : 3101 : arg = arg->next;
8587 : 3101 : size_words = gfc_create_var (gfc_array_index_type, NULL);
8588 : :
8589 : 3101 : if (arg->expr)
8590 : : {
8591 : 241 : gfc_init_se (&argse, NULL);
8592 : 241 : gfc_conv_expr_reference (&argse, arg->expr);
8593 : 241 : tmp = convert (gfc_array_index_type,
8594 : : build_fold_indirect_ref_loc (input_location,
8595 : : argse.expr));
8596 : 241 : gfc_add_block_to_block (&se->pre, &argse.pre);
8597 : 241 : gfc_add_block_to_block (&se->post, &argse.post);
8598 : : }
8599 : : else
8600 : : tmp = NULL_TREE;
8601 : :
8602 : : /* Separate array and scalar results. */
8603 : 3101 : if (scalar_mold && tmp == NULL_TREE)
8604 : 2669 : goto scalar_transfer;
8605 : :
8606 : 432 : size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8607 : 432 : if (tmp != NULL_TREE)
8608 : 241 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8609 : : tmp, dest_word_len);
8610 : : else
8611 : : tmp = source_bytes;
8612 : :
8613 : 432 : gfc_add_modify (&se->pre, size_bytes, tmp);
8614 : 432 : gfc_add_modify (&se->pre, size_words,
8615 : : fold_build2_loc (input_location, CEIL_DIV_EXPR,
8616 : : gfc_array_index_type,
8617 : : size_bytes, dest_word_len));
8618 : :
8619 : : /* Evaluate the bounds of the result. If the loop range exists, we have
8620 : : to check if it is too large. If so, we modify loop->to be consistent
8621 : : with min(size, size(source)). Otherwise, size is made consistent with
8622 : : the loop range, so that the right number of bytes is transferred.*/
8623 : 432 : n = se->loop->order[0];
8624 : 432 : if (se->loop->to[n] != NULL_TREE)
8625 : : {
8626 : 231 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8627 : : se->loop->to[n], se->loop->from[n]);
8628 : 231 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8629 : : tmp, gfc_index_one_node);
8630 : 231 : tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8631 : : tmp, size_words);
8632 : 231 : gfc_add_modify (&se->pre, size_words, tmp);
8633 : 231 : gfc_add_modify (&se->pre, size_bytes,
8634 : : fold_build2_loc (input_location, MULT_EXPR,
8635 : : gfc_array_index_type,
8636 : : size_words, dest_word_len));
8637 : 462 : upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8638 : 231 : size_words, se->loop->from[n]);
8639 : 231 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8640 : : upper, gfc_index_one_node);
8641 : : }
8642 : : else
8643 : : {
8644 : 201 : upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8645 : : size_words, gfc_index_one_node);
8646 : 201 : se->loop->from[n] = gfc_index_zero_node;
8647 : : }
8648 : :
8649 : 432 : se->loop->to[n] = upper;
8650 : :
8651 : : /* Build a destination descriptor, using the pointer, source, as the
8652 : : data field. */
8653 : 432 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
8654 : : NULL_TREE, false, true, false, &expr->where);
8655 : :
8656 : : /* Cast the pointer to the result. */
8657 : 432 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
8658 : 432 : tmp = fold_convert (pvoid_type_node, tmp);
8659 : :
8660 : : /* Use memcpy to do the transfer. */
8661 : 432 : tmp
8662 : 432 : = build_call_expr_loc (input_location,
8663 : : builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
8664 : : fold_convert (pvoid_type_node, source),
8665 : : fold_convert (size_type_node,
8666 : : fold_build2_loc (input_location,
8667 : : MIN_EXPR,
8668 : : gfc_array_index_type,
8669 : : size_bytes,
8670 : : source_bytes)));
8671 : 432 : gfc_add_expr_to_block (&se->pre, tmp);
8672 : :
8673 : 432 : se->expr = info->descriptor;
8674 : 432 : if (expr->ts.type == BT_CHARACTER)
8675 : : {
8676 : 250 : tmp = fold_convert (gfc_charlen_type_node,
8677 : : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
8678 : 250 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
8679 : : gfc_charlen_type_node,
8680 : : dest_word_len, tmp);
8681 : : }
8682 : :
8683 : 432 : return;
8684 : :
8685 : : /* Deal with scalar results. */
8686 : 2669 : scalar_transfer:
8687 : 2669 : extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8688 : : dest_word_len, source_bytes);
8689 : 2669 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8690 : : extent, gfc_index_zero_node);
8691 : :
8692 : 2669 : if (expr->ts.type == BT_CHARACTER)
8693 : : {
8694 : 173 : tree direct, indirect, free;
8695 : :
8696 : 173 : ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
8697 : 173 : tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
8698 : : "transfer");
8699 : :
8700 : : /* If source is longer than the destination, use a pointer to
8701 : : the source directly. */
8702 : 173 : gfc_init_block (&block);
8703 : 173 : gfc_add_modify (&block, tmpdecl, ptr);
8704 : 173 : direct = gfc_finish_block (&block);
8705 : :
8706 : : /* Otherwise, allocate a string with the length of the destination
8707 : : and copy the source into it. */
8708 : 173 : gfc_init_block (&block);
8709 : 173 : tmp = gfc_get_pchar_type (expr->ts.kind);
8710 : 173 : tmp = gfc_call_malloc (&block, tmp, dest_word_len);
8711 : 173 : gfc_add_modify (&block, tmpdecl,
8712 : 173 : fold_convert (TREE_TYPE (ptr), tmp));
8713 : 173 : tmp = build_call_expr_loc (input_location,
8714 : : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
8715 : : fold_convert (pvoid_type_node, tmpdecl),
8716 : : fold_convert (pvoid_type_node, ptr),
8717 : : fold_convert (size_type_node, extent));
8718 : 173 : gfc_add_expr_to_block (&block, tmp);
8719 : 173 : indirect = gfc_finish_block (&block);
8720 : :
8721 : : /* Wrap it up with the condition. */
8722 : 173 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
8723 : : dest_word_len, source_bytes);
8724 : 173 : tmp = build3_v (COND_EXPR, tmp, direct, indirect);
8725 : 173 : gfc_add_expr_to_block (&se->pre, tmp);
8726 : :
8727 : : /* Free the temporary string, if necessary. */
8728 : 173 : free = gfc_call_free (tmpdecl);
8729 : 173 : tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
8730 : : dest_word_len, source_bytes);
8731 : 173 : tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
8732 : 173 : gfc_add_expr_to_block (&se->post, tmp);
8733 : :
8734 : 173 : se->expr = tmpdecl;
8735 : 173 : tmp = fold_convert (gfc_charlen_type_node,
8736 : : TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)));
8737 : 173 : se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
8738 : : gfc_charlen_type_node,
8739 : : dest_word_len, tmp);
8740 : : }
8741 : : else
8742 : : {
8743 : 2496 : tmpdecl = gfc_create_var (mold_type, "transfer");
8744 : :
8745 : 2496 : ptr = convert (build_pointer_type (mold_type), source);
8746 : :
8747 : : /* For CLASS results, allocate the needed memory first. */
8748 : 2496 : if (mold_expr->ts.type == BT_CLASS)
8749 : : {
8750 : 6 : tree cdata;
8751 : 6 : cdata = gfc_class_data_get (tmpdecl);
8752 : 6 : tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
8753 : 6 : gfc_add_modify (&se->pre, cdata, tmp);
8754 : : }
8755 : :
8756 : : /* Use memcpy to do the transfer. */
8757 : 2496 : if (mold_expr->ts.type == BT_CLASS)
8758 : 6 : tmp = gfc_class_data_get (tmpdecl);
8759 : : else
8760 : 2490 : tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
8761 : :
8762 : 2496 : tmp = build_call_expr_loc (input_location,
8763 : : builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
8764 : : fold_convert (pvoid_type_node, tmp),
8765 : : fold_convert (pvoid_type_node, ptr),
8766 : : fold_convert (size_type_node, extent));
8767 : 2496 : gfc_add_expr_to_block (&se->pre, tmp);
8768 : :
8769 : : /* For CLASS results, set the _vptr. */
8770 : 2496 : if (mold_expr->ts.type == BT_CLASS)
8771 : : {
8772 : 6 : tree vptr;
8773 : 6 : gfc_symbol *vtab;
8774 : 6 : vptr = gfc_class_vptr_get (tmpdecl);
8775 : 6 : vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
8776 : 6 : gcc_assert (vtab);
8777 : 6 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
8778 : 6 : gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
8779 : : }
8780 : :
8781 : 2496 : se->expr = tmpdecl;
8782 : : }
8783 : : }
8784 : :
8785 : :
8786 : : /* Generate a call to caf_is_present. */
8787 : :
8788 : : static tree
8789 : 60 : trans_caf_is_present (gfc_se *se, gfc_expr *expr)
8790 : : {
8791 : 60 : tree caf_reference, caf_decl, token, image_index;
8792 : :
8793 : : /* Compile the reference chain. */
8794 : 60 : caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr);
8795 : 60 : gcc_assert (caf_reference != NULL_TREE);
8796 : :
8797 : 60 : caf_decl = gfc_get_tree_for_caf_expr (expr);
8798 : 60 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
8799 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
8800 : 60 : image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl);
8801 : 60 : gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
8802 : : expr);
8803 : :
8804 : 60 : return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present,
8805 : 60 : 3, token, image_index, caf_reference);
8806 : : }
8807 : :
8808 : :
8809 : : /* Test whether this ref-chain refs this image only. */
8810 : :
8811 : : static bool
8812 : 60 : caf_this_image_ref (gfc_ref *ref)
8813 : : {
8814 : 60 : for ( ; ref; ref = ref->next)
8815 : 60 : if (ref->type == REF_ARRAY && ref->u.ar.codimen)
8816 : 60 : return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE;
8817 : :
8818 : : return false;
8819 : : }
8820 : :
8821 : :
8822 : : /* Generate code for the ALLOCATED intrinsic.
8823 : : Generate inline code that directly check the address of the argument. */
8824 : :
8825 : : static void
8826 : 6651 : gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
8827 : : {
8828 : 6651 : gfc_se arg1se;
8829 : 6651 : tree tmp;
8830 : 6651 : bool coindexed_caf_comp = false;
8831 : 6651 : gfc_expr *e = expr->value.function.actual->expr;
8832 : :
8833 : 6651 : gfc_init_se (&arg1se, NULL);
8834 : 6651 : if (e->ts.type == BT_CLASS)
8835 : : {
8836 : : /* Make sure that class array expressions have both a _data
8837 : : component reference and an array reference.... */
8838 : 873 : if (CLASS_DATA (e)->attr.dimension)
8839 : 424 : gfc_add_class_array_ref (e);
8840 : : /* .... whilst scalars only need the _data component. */
8841 : : else
8842 : 449 : gfc_add_data_component (e);
8843 : : }
8844 : :
8845 : : /* When 'e' references an allocatable component in a coarray, then call
8846 : : the caf-library function caf_is_present (). */
8847 : 6651 : if (flag_coarray == GFC_FCOARRAY_LIB && e->expr_type == EXPR_FUNCTION
8848 : 66 : && e->value.function.isym
8849 : 66 : && e->value.function.isym->id == GFC_ISYM_CAF_GET)
8850 : : {
8851 : 66 : e = e->value.function.actual->expr;
8852 : 66 : if (gfc_expr_attr (e).codimension)
8853 : : {
8854 : : /* Last partref is the coindexed coarray. As coarrays are collectively
8855 : : (de)allocated, the allocation status must be the same as the one of
8856 : : the local allocation. Convert to local access. */
8857 : 9 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
8858 : 9 : if (ref->type == REF_ARRAY && ref->u.ar.codimen)
8859 : : {
8860 : 6 : for (int i = ref->u.ar.dimen;
8861 : 18 : i < ref->u.ar.dimen + ref->u.ar.codimen; ++i)
8862 : 12 : ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
8863 : : break;
8864 : : }
8865 : : }
8866 : 60 : else if (!caf_this_image_ref (e->ref))
8867 : 60 : coindexed_caf_comp = true;
8868 : : }
8869 : 60 : if (coindexed_caf_comp)
8870 : 60 : tmp = trans_caf_is_present (se, e);
8871 : : else
8872 : : {
8873 : 6591 : if (e->rank == 0)
8874 : : {
8875 : : /* Allocatable scalar. */
8876 : 2620 : arg1se.want_pointer = 1;
8877 : 2620 : gfc_conv_expr (&arg1se, e);
8878 : 2620 : tmp = arg1se.expr;
8879 : : }
8880 : : else
8881 : : {
8882 : : /* Allocatable array. */
8883 : 3971 : arg1se.descriptor_only = 1;
8884 : 3971 : gfc_conv_expr_descriptor (&arg1se, e);
8885 : 3971 : tmp = gfc_conv_descriptor_data_get (arg1se.expr);
8886 : : }
8887 : :
8888 : 6591 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
8889 : 6591 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
8890 : : }
8891 : :
8892 : : /* Components of pointer array references sometimes come back with a pre block. */
8893 : 6651 : if (arg1se.pre.head)
8894 : 6 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
8895 : :
8896 : 6651 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
8897 : 6651 : }
8898 : :
8899 : :
8900 : : /* Generate code for the ASSOCIATED intrinsic.
8901 : : If both POINTER and TARGET are arrays, generate a call to library function
8902 : : _gfor_associated, and pass descriptors of POINTER and TARGET to it.
8903 : : In other cases, generate inline code that directly compare the address of
8904 : : POINTER with the address of TARGET. */
8905 : :
8906 : : static void
8907 : 7886 : gfc_conv_associated (gfc_se *se, gfc_expr *expr)
8908 : : {
8909 : 7886 : gfc_actual_arglist *arg1;
8910 : 7886 : gfc_actual_arglist *arg2;
8911 : 7886 : gfc_se arg1se;
8912 : 7886 : gfc_se arg2se;
8913 : 7886 : tree tmp2;
8914 : 7886 : tree tmp;
8915 : 7886 : tree nonzero_arraylen = NULL_TREE;
8916 : 7886 : gfc_ss *ss;
8917 : 7886 : bool scalar;
8918 : :
8919 : 7886 : gfc_init_se (&arg1se, NULL);
8920 : 7886 : gfc_init_se (&arg2se, NULL);
8921 : 7886 : arg1 = expr->value.function.actual;
8922 : 7886 : arg2 = arg1->next;
8923 : :
8924 : : /* Check whether the expression is a scalar or not; we cannot use
8925 : : arg1->expr->rank as it can be nonzero for proc pointers. */
8926 : 7886 : ss = gfc_walk_expr (arg1->expr);
8927 : 7886 : scalar = ss == gfc_ss_terminator;
8928 : 7886 : if (!scalar)
8929 : 3196 : gfc_free_ss_chain (ss);
8930 : :
8931 : 7886 : if (!arg2->expr)
8932 : : {
8933 : : /* No optional target. */
8934 : 6105 : if (scalar)
8935 : : {
8936 : : /* A pointer to a scalar. */
8937 : 3854 : arg1se.want_pointer = 1;
8938 : 3854 : gfc_conv_expr (&arg1se, arg1->expr);
8939 : 3854 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
8940 : 3854 : && arg1->expr->symtree->n.sym->attr.dummy)
8941 : 78 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
8942 : : arg1se.expr);
8943 : 3854 : if (arg1->expr->ts.type == BT_CLASS)
8944 : : {
8945 : 384 : tmp2 = gfc_class_data_get (arg1se.expr);
8946 : 384 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8947 : 0 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8948 : : }
8949 : : else
8950 : 3470 : tmp2 = arg1se.expr;
8951 : : }
8952 : : else
8953 : : {
8954 : : /* A pointer to an array. */
8955 : 2251 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
8956 : 2251 : tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
8957 : : }
8958 : 6105 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
8959 : 6105 : gfc_add_block_to_block (&se->post, &arg1se.post);
8960 : 6105 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
8961 : 6105 : fold_convert (TREE_TYPE (tmp2), null_pointer_node));
8962 : 6105 : se->expr = tmp;
8963 : : }
8964 : : else
8965 : : {
8966 : : /* An optional target. */
8967 : 1781 : if (arg2->expr->ts.type == BT_CLASS
8968 : 24 : && arg2->expr->expr_type != EXPR_FUNCTION)
8969 : 18 : gfc_add_data_component (arg2->expr);
8970 : :
8971 : 1781 : if (scalar)
8972 : : {
8973 : : /* A pointer to a scalar. */
8974 : 836 : arg1se.want_pointer = 1;
8975 : 836 : gfc_conv_expr (&arg1se, arg1->expr);
8976 : 836 : if (arg1->expr->symtree->n.sym->attr.proc_pointer
8977 : 836 : && arg1->expr->symtree->n.sym->attr.dummy)
8978 : 42 : arg1se.expr = build_fold_indirect_ref_loc (input_location,
8979 : : arg1se.expr);
8980 : 836 : if (arg1->expr->ts.type == BT_CLASS)
8981 : 246 : arg1se.expr = gfc_class_data_get (arg1se.expr);
8982 : :
8983 : 836 : arg2se.want_pointer = 1;
8984 : 836 : gfc_conv_expr (&arg2se, arg2->expr);
8985 : 836 : if (arg2->expr->symtree->n.sym->attr.proc_pointer
8986 : 836 : && arg2->expr->symtree->n.sym->attr.dummy)
8987 : 0 : arg2se.expr = build_fold_indirect_ref_loc (input_location,
8988 : : arg2se.expr);
8989 : 836 : if (arg2->expr->ts.type == BT_CLASS)
8990 : : {
8991 : 6 : arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre);
8992 : 6 : arg2se.expr = gfc_class_data_get (arg2se.expr);
8993 : : }
8994 : 836 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
8995 : 836 : gfc_add_block_to_block (&se->post, &arg1se.post);
8996 : 836 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
8997 : 836 : gfc_add_block_to_block (&se->post, &arg2se.post);
8998 : 836 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
8999 : : arg1se.expr, arg2se.expr);
9000 : 836 : tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9001 : : arg1se.expr, null_pointer_node);
9002 : 836 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9003 : : logical_type_node, tmp, tmp2);
9004 : : }
9005 : : else
9006 : : {
9007 : : /* An array pointer of zero length is not associated if target is
9008 : : present. */
9009 : 945 : arg1se.descriptor_only = 1;
9010 : 945 : gfc_conv_expr_lhs (&arg1se, arg1->expr);
9011 : 945 : if (arg1->expr->rank == -1)
9012 : : {
9013 : 84 : tmp = gfc_conv_descriptor_rank (arg1se.expr);
9014 : 168 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9015 : 84 : TREE_TYPE (tmp), tmp,
9016 : 84 : build_int_cst (TREE_TYPE (tmp), 1));
9017 : : }
9018 : : else
9019 : 861 : tmp = gfc_rank_cst[arg1->expr->rank - 1];
9020 : 945 : tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
9021 : 945 : if (arg2->expr->rank != 0)
9022 : 915 : nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
9023 : : logical_type_node, tmp,
9024 : 915 : build_int_cst (TREE_TYPE (tmp), 0));
9025 : :
9026 : : /* A pointer to an array, call library function _gfor_associated. */
9027 : 945 : arg1se.want_pointer = 1;
9028 : 945 : gfc_conv_expr_descriptor (&arg1se, arg1->expr);
9029 : 945 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9030 : 945 : gfc_add_block_to_block (&se->post, &arg1se.post);
9031 : :
9032 : 945 : arg2se.want_pointer = 1;
9033 : 945 : arg2se.force_no_tmp = 1;
9034 : 945 : if (arg2->expr->rank != 0)
9035 : 915 : gfc_conv_expr_descriptor (&arg2se, arg2->expr);
9036 : : else
9037 : : {
9038 : 30 : gfc_conv_expr (&arg2se, arg2->expr);
9039 : 30 : arg2se.expr
9040 : 30 : = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
9041 : : gfc_expr_attr (arg2->expr));
9042 : 30 : arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
9043 : : }
9044 : 945 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9045 : 945 : gfc_add_block_to_block (&se->post, &arg2se.post);
9046 : 945 : se->expr = build_call_expr_loc (input_location,
9047 : : gfor_fndecl_associated, 2,
9048 : : arg1se.expr, arg2se.expr);
9049 : 945 : se->expr = convert (logical_type_node, se->expr);
9050 : 945 : if (arg2->expr->rank != 0)
9051 : 915 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9052 : : logical_type_node, se->expr,
9053 : : nonzero_arraylen);
9054 : : }
9055 : :
9056 : : /* If target is present zero character length pointers cannot
9057 : : be associated. */
9058 : 1781 : if (arg1->expr->ts.type == BT_CHARACTER)
9059 : : {
9060 : 630 : tmp = arg1se.string_length;
9061 : 630 : tmp = fold_build2_loc (input_location, NE_EXPR,
9062 : : logical_type_node, tmp,
9063 : 630 : build_zero_cst (TREE_TYPE (tmp)));
9064 : 630 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9065 : : logical_type_node, se->expr, tmp);
9066 : : }
9067 : : }
9068 : :
9069 : 7886 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9070 : 7886 : }
9071 : :
9072 : :
9073 : : /* Generate code for the SAME_TYPE_AS intrinsic.
9074 : : Generate inline code that directly checks the vindices. */
9075 : :
9076 : : static void
9077 : 397 : gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
9078 : : {
9079 : 397 : gfc_expr *a, *b;
9080 : 397 : gfc_se se1, se2;
9081 : 397 : tree tmp;
9082 : 397 : tree conda = NULL_TREE, condb = NULL_TREE;
9083 : :
9084 : 397 : gfc_init_se (&se1, NULL);
9085 : 397 : gfc_init_se (&se2, NULL);
9086 : :
9087 : 397 : a = expr->value.function.actual->expr;
9088 : 397 : b = expr->value.function.actual->next->expr;
9089 : :
9090 : 397 : bool unlimited_poly_a = UNLIMITED_POLY (a);
9091 : 397 : bool unlimited_poly_b = UNLIMITED_POLY (b);
9092 : 397 : if (unlimited_poly_a)
9093 : : {
9094 : 105 : se1.want_pointer = 1;
9095 : 105 : gfc_add_vptr_component (a);
9096 : : }
9097 : 292 : else if (a->ts.type == BT_CLASS)
9098 : : {
9099 : 250 : gfc_add_vptr_component (a);
9100 : 250 : gfc_add_hash_component (a);
9101 : : }
9102 : 42 : else if (a->ts.type == BT_DERIVED)
9103 : 42 : a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9104 : 42 : a->ts.u.derived->hash_value);
9105 : :
9106 : 397 : if (unlimited_poly_b)
9107 : : {
9108 : 66 : se2.want_pointer = 1;
9109 : 66 : gfc_add_vptr_component (b);
9110 : : }
9111 : 331 : else if (b->ts.type == BT_CLASS)
9112 : : {
9113 : 163 : gfc_add_vptr_component (b);
9114 : 163 : gfc_add_hash_component (b);
9115 : : }
9116 : 168 : else if (b->ts.type == BT_DERIVED)
9117 : 168 : b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
9118 : 168 : b->ts.u.derived->hash_value);
9119 : :
9120 : 397 : gfc_conv_expr (&se1, a);
9121 : 397 : gfc_conv_expr (&se2, b);
9122 : :
9123 : 397 : if (unlimited_poly_a)
9124 : : {
9125 : 105 : conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9126 : : se1.expr,
9127 : 105 : build_int_cst (TREE_TYPE (se1.expr), 0));
9128 : 105 : se1.expr = gfc_vptr_hash_get (se1.expr);
9129 : : }
9130 : :
9131 : 397 : if (unlimited_poly_b)
9132 : : {
9133 : 66 : condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9134 : : se2.expr,
9135 : 66 : build_int_cst (TREE_TYPE (se2.expr), 0));
9136 : 66 : se2.expr = gfc_vptr_hash_get (se2.expr);
9137 : : }
9138 : :
9139 : 397 : tmp = fold_build2_loc (input_location, EQ_EXPR,
9140 : : logical_type_node, se1.expr,
9141 : 397 : fold_convert (TREE_TYPE (se1.expr), se2.expr));
9142 : :
9143 : 397 : if (conda)
9144 : 105 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9145 : : logical_type_node, conda, tmp);
9146 : :
9147 : 397 : if (condb)
9148 : 66 : tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
9149 : : logical_type_node, condb, tmp);
9150 : :
9151 : 397 : se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
9152 : 397 : }
9153 : :
9154 : :
9155 : : /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
9156 : :
9157 : : static void
9158 : 42 : gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
9159 : : {
9160 : 42 : tree args[2];
9161 : :
9162 : 42 : gfc_conv_intrinsic_function_args (se, expr, args, 2);
9163 : 42 : se->expr = build_call_expr_loc (input_location,
9164 : : gfor_fndecl_sc_kind, 2, args[0], args[1]);
9165 : 42 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9166 : 42 : }
9167 : :
9168 : :
9169 : : /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
9170 : :
9171 : : static void
9172 : 45 : gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
9173 : : {
9174 : 45 : tree arg, type;
9175 : :
9176 : 45 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9177 : :
9178 : : /* The argument to SELECTED_INT_KIND is INTEGER(4). */
9179 : 45 : type = gfc_get_int_type (4);
9180 : 45 : arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
9181 : :
9182 : : /* Convert it to the required type. */
9183 : 45 : type = gfc_typenode_for_spec (&expr->ts);
9184 : 45 : se->expr = build_call_expr_loc (input_location,
9185 : : gfor_fndecl_si_kind, 1, arg);
9186 : 45 : se->expr = fold_convert (type, se->expr);
9187 : 45 : }
9188 : :
9189 : :
9190 : : /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
9191 : :
9192 : : static void
9193 : 82 : gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
9194 : : {
9195 : 82 : gfc_actual_arglist *actual;
9196 : 82 : tree type;
9197 : 82 : gfc_se argse;
9198 : 82 : vec<tree, va_gc> *args = NULL;
9199 : :
9200 : 328 : for (actual = expr->value.function.actual; actual; actual = actual->next)
9201 : : {
9202 : 246 : gfc_init_se (&argse, se);
9203 : :
9204 : : /* Pass a NULL pointer for an absent arg. */
9205 : 246 : if (actual->expr == NULL)
9206 : 96 : argse.expr = null_pointer_node;
9207 : : else
9208 : : {
9209 : 150 : gfc_typespec ts;
9210 : 150 : gfc_clear_ts (&ts);
9211 : :
9212 : 150 : if (actual->expr->ts.kind != gfc_c_int_kind)
9213 : : {
9214 : : /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
9215 : 0 : ts.type = BT_INTEGER;
9216 : 0 : ts.kind = gfc_c_int_kind;
9217 : 0 : gfc_convert_type (actual->expr, &ts, 2);
9218 : : }
9219 : 150 : gfc_conv_expr_reference (&argse, actual->expr);
9220 : : }
9221 : :
9222 : 246 : gfc_add_block_to_block (&se->pre, &argse.pre);
9223 : 246 : gfc_add_block_to_block (&se->post, &argse.post);
9224 : 246 : vec_safe_push (args, argse.expr);
9225 : : }
9226 : :
9227 : : /* Convert it to the required type. */
9228 : 82 : type = gfc_typenode_for_spec (&expr->ts);
9229 : 82 : se->expr = build_call_expr_loc_vec (input_location,
9230 : : gfor_fndecl_sr_kind, args);
9231 : 82 : se->expr = fold_convert (type, se->expr);
9232 : 82 : }
9233 : :
9234 : :
9235 : : /* Generate code for TRIM (A) intrinsic function. */
9236 : :
9237 : : static void
9238 : 569 : gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
9239 : : {
9240 : 569 : tree var;
9241 : 569 : tree len;
9242 : 569 : tree addr;
9243 : 569 : tree tmp;
9244 : 569 : tree cond;
9245 : 569 : tree fndecl;
9246 : 569 : tree function;
9247 : 569 : tree *args;
9248 : 569 : unsigned int num_args;
9249 : :
9250 : 569 : num_args = gfc_intrinsic_argument_list_length (expr) + 2;
9251 : 569 : args = XALLOCAVEC (tree, num_args);
9252 : :
9253 : 569 : var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
9254 : 569 : addr = gfc_build_addr_expr (ppvoid_type_node, var);
9255 : 569 : len = gfc_create_var (gfc_charlen_type_node, "len");
9256 : :
9257 : 569 : gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
9258 : 569 : args[0] = gfc_build_addr_expr (NULL_TREE, len);
9259 : 569 : args[1] = addr;
9260 : :
9261 : 569 : if (expr->ts.kind == 1)
9262 : 547 : function = gfor_fndecl_string_trim;
9263 : 22 : else if (expr->ts.kind == 4)
9264 : 22 : function = gfor_fndecl_string_trim_char4;
9265 : : else
9266 : 0 : gcc_unreachable ();
9267 : :
9268 : 569 : fndecl = build_addr (function);
9269 : 569 : tmp = build_call_array_loc (input_location,
9270 : 569 : TREE_TYPE (TREE_TYPE (function)), fndecl,
9271 : : num_args, args);
9272 : 569 : gfc_add_expr_to_block (&se->pre, tmp);
9273 : :
9274 : : /* Free the temporary afterwards, if necessary. */
9275 : 569 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9276 : 569 : len, build_int_cst (TREE_TYPE (len), 0));
9277 : 569 : tmp = gfc_call_free (var);
9278 : 569 : tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
9279 : 569 : gfc_add_expr_to_block (&se->post, tmp);
9280 : :
9281 : 569 : se->expr = var;
9282 : 569 : se->string_length = len;
9283 : 569 : }
9284 : :
9285 : :
9286 : : /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
9287 : :
9288 : : static void
9289 : 499 : gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
9290 : : {
9291 : 499 : tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
9292 : 499 : tree type, cond, tmp, count, exit_label, n, max, largest;
9293 : 499 : tree size;
9294 : 499 : stmtblock_t block, body;
9295 : 499 : int i;
9296 : :
9297 : : /* We store in charsize the size of a character. */
9298 : 499 : i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
9299 : 499 : size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
9300 : :
9301 : : /* Get the arguments. */
9302 : 499 : gfc_conv_intrinsic_function_args (se, expr, args, 3);
9303 : 499 : slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
9304 : 499 : src = args[1];
9305 : 499 : ncopies = gfc_evaluate_now (args[2], &se->pre);
9306 : 499 : ncopies_type = TREE_TYPE (ncopies);
9307 : :
9308 : : /* Check that NCOPIES is not negative. */
9309 : 499 : cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
9310 : 499 : build_int_cst (ncopies_type, 0));
9311 : 499 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9312 : : "Argument NCOPIES of REPEAT intrinsic is negative "
9313 : : "(its value is %ld)",
9314 : : fold_convert (long_integer_type_node, ncopies));
9315 : :
9316 : : /* If the source length is zero, any non negative value of NCOPIES
9317 : : is valid, and nothing happens. */
9318 : 499 : n = gfc_create_var (ncopies_type, "ncopies");
9319 : 499 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9320 : : size_zero_node);
9321 : 499 : tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
9322 : 499 : build_int_cst (ncopies_type, 0), ncopies);
9323 : 499 : gfc_add_modify (&se->pre, n, tmp);
9324 : 499 : ncopies = n;
9325 : :
9326 : : /* Check that ncopies is not too large: ncopies should be less than
9327 : : (or equal to) MAX / slen, where MAX is the maximal integer of
9328 : : the gfc_charlen_type_node type. If slen == 0, we need a special
9329 : : case to avoid the division by zero. */
9330 : 499 : max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
9331 : 499 : fold_convert (sizetype,
9332 : : TYPE_MAX_VALUE (gfc_charlen_type_node)),
9333 : : slen);
9334 : 499 : largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
9335 : 499 : ? sizetype : ncopies_type;
9336 : 499 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
9337 : : fold_convert (largest, ncopies),
9338 : : fold_convert (largest, max));
9339 : 499 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
9340 : : size_zero_node);
9341 : 499 : cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
9342 : : logical_false_node, cond);
9343 : 499 : gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
9344 : : "Argument NCOPIES of REPEAT intrinsic is too large");
9345 : :
9346 : : /* Compute the destination length. */
9347 : 499 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
9348 : : fold_convert (gfc_charlen_type_node, slen),
9349 : : fold_convert (gfc_charlen_type_node, ncopies));
9350 : 499 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
9351 : 499 : dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
9352 : :
9353 : : /* Generate the code to do the repeat operation:
9354 : : for (i = 0; i < ncopies; i++)
9355 : : memmove (dest + (i * slen * size), src, slen*size); */
9356 : 499 : gfc_start_block (&block);
9357 : 499 : count = gfc_create_var (sizetype, "count");
9358 : 499 : gfc_add_modify (&block, count, size_zero_node);
9359 : 499 : exit_label = gfc_build_label_decl (NULL_TREE);
9360 : :
9361 : : /* Start the loop body. */
9362 : 499 : gfc_start_block (&body);
9363 : :
9364 : : /* Exit the loop if count >= ncopies. */
9365 : 499 : cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
9366 : : fold_convert (sizetype, ncopies));
9367 : 499 : tmp = build1_v (GOTO_EXPR, exit_label);
9368 : 499 : TREE_USED (exit_label) = 1;
9369 : 499 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9370 : : build_empty_stmt (input_location));
9371 : 499 : gfc_add_expr_to_block (&body, tmp);
9372 : :
9373 : : /* Call memmove (dest + (i*slen*size), src, slen*size). */
9374 : 499 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
9375 : : count);
9376 : 499 : tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
9377 : : size);
9378 : 499 : tmp = fold_build_pointer_plus_loc (input_location,
9379 : : fold_convert (pvoid_type_node, dest), tmp);
9380 : 499 : tmp = build_call_expr_loc (input_location,
9381 : : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9382 : : 3, tmp, src,
9383 : : fold_build2_loc (input_location, MULT_EXPR,
9384 : : size_type_node, slen, size));
9385 : 499 : gfc_add_expr_to_block (&body, tmp);
9386 : :
9387 : : /* Increment count. */
9388 : 499 : tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
9389 : : count, size_one_node);
9390 : 499 : gfc_add_modify (&body, count, tmp);
9391 : :
9392 : : /* Build the loop. */
9393 : 499 : tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
9394 : 499 : gfc_add_expr_to_block (&block, tmp);
9395 : :
9396 : : /* Add the exit label. */
9397 : 499 : tmp = build1_v (LABEL_EXPR, exit_label);
9398 : 499 : gfc_add_expr_to_block (&block, tmp);
9399 : :
9400 : : /* Finish the block. */
9401 : 499 : tmp = gfc_finish_block (&block);
9402 : 499 : gfc_add_expr_to_block (&se->pre, tmp);
9403 : :
9404 : : /* Set the result value. */
9405 : 499 : se->expr = dest;
9406 : 499 : se->string_length = dlen;
9407 : 499 : }
9408 : :
9409 : :
9410 : : /* Generate code for the IARGC intrinsic. */
9411 : :
9412 : : static void
9413 : 12 : gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
9414 : : {
9415 : 12 : tree tmp;
9416 : 12 : tree fndecl;
9417 : 12 : tree type;
9418 : :
9419 : : /* Call the library function. This always returns an INTEGER(4). */
9420 : 12 : fndecl = gfor_fndecl_iargc;
9421 : 12 : tmp = build_call_expr_loc (input_location,
9422 : : fndecl, 0);
9423 : :
9424 : : /* Convert it to the required type. */
9425 : 12 : type = gfc_typenode_for_spec (&expr->ts);
9426 : 12 : tmp = fold_convert (type, tmp);
9427 : :
9428 : 12 : se->expr = tmp;
9429 : 12 : }
9430 : :
9431 : :
9432 : : /* Generate code for the KILL intrinsic. */
9433 : :
9434 : : static void
9435 : 8 : conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
9436 : : {
9437 : 8 : tree *args;
9438 : 8 : tree int4_type_node = gfc_get_int_type (4);
9439 : 8 : tree pid;
9440 : 8 : tree sig;
9441 : 8 : tree tmp;
9442 : 8 : unsigned int num_args;
9443 : :
9444 : 8 : num_args = gfc_intrinsic_argument_list_length (expr);
9445 : 8 : args = XALLOCAVEC (tree, num_args);
9446 : 8 : gfc_conv_intrinsic_function_args (se, expr, args, num_args);
9447 : :
9448 : : /* Convert PID to a INTEGER(4) entity. */
9449 : 8 : pid = convert (int4_type_node, args[0]);
9450 : :
9451 : : /* Convert SIG to a INTEGER(4) entity. */
9452 : 8 : sig = convert (int4_type_node, args[1]);
9453 : :
9454 : 8 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
9455 : :
9456 : 8 : se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
9457 : 8 : }
9458 : :
9459 : :
9460 : : static tree
9461 : 15 : conv_intrinsic_kill_sub (gfc_code *code)
9462 : : {
9463 : 15 : stmtblock_t block;
9464 : 15 : gfc_se se, se_stat;
9465 : 15 : tree int4_type_node = gfc_get_int_type (4);
9466 : 15 : tree pid;
9467 : 15 : tree sig;
9468 : 15 : tree statp;
9469 : 15 : tree tmp;
9470 : :
9471 : : /* Make the function call. */
9472 : 15 : gfc_init_block (&block);
9473 : 15 : gfc_init_se (&se, NULL);
9474 : :
9475 : : /* Convert PID to a INTEGER(4) entity. */
9476 : 15 : gfc_conv_expr (&se, code->ext.actual->expr);
9477 : 15 : gfc_add_block_to_block (&block, &se.pre);
9478 : 15 : pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9479 : 15 : gfc_add_block_to_block (&block, &se.post);
9480 : :
9481 : : /* Convert SIG to a INTEGER(4) entity. */
9482 : 15 : gfc_conv_expr (&se, code->ext.actual->next->expr);
9483 : 15 : gfc_add_block_to_block (&block, &se.pre);
9484 : 15 : sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
9485 : 15 : gfc_add_block_to_block (&block, &se.post);
9486 : :
9487 : : /* Deal with an optional STATUS. */
9488 : 15 : if (code->ext.actual->next->next->expr)
9489 : : {
9490 : 10 : gfc_init_se (&se_stat, NULL);
9491 : 10 : gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
9492 : 10 : statp = gfc_create_var (gfc_get_int_type (4), "_statp");
9493 : : }
9494 : : else
9495 : : statp = NULL_TREE;
9496 : :
9497 : 25 : tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
9498 : 10 : statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
9499 : :
9500 : 15 : gfc_add_expr_to_block (&block, tmp);
9501 : :
9502 : 15 : if (statp && statp != se_stat.expr)
9503 : 10 : gfc_add_modify (&block, se_stat.expr,
9504 : 10 : fold_convert (TREE_TYPE (se_stat.expr), statp));
9505 : :
9506 : 15 : return gfc_finish_block (&block);
9507 : : }
9508 : :
9509 : :
9510 : :
9511 : : /* The loc intrinsic returns the address of its argument as
9512 : : gfc_index_integer_kind integer. */
9513 : :
9514 : : static void
9515 : 8251 : gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
9516 : : {
9517 : 8251 : tree temp_var;
9518 : 8251 : gfc_expr *arg_expr;
9519 : :
9520 : 8251 : gcc_assert (!se->ss);
9521 : :
9522 : 8251 : arg_expr = expr->value.function.actual->expr;
9523 : 8251 : if (arg_expr->rank == 0)
9524 : : {
9525 : 5876 : if (arg_expr->ts.type == BT_CLASS)
9526 : 18 : gfc_add_data_component (arg_expr);
9527 : 5876 : gfc_conv_expr_reference (se, arg_expr);
9528 : : }
9529 : : else
9530 : 2375 : gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
9531 : 8251 : se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
9532 : :
9533 : : /* Create a temporary variable for loc return value. Without this,
9534 : : we get an error an ICE in gcc/expr.cc(expand_expr_addr_expr_1). */
9535 : 8251 : temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
9536 : 8251 : gfc_add_modify (&se->pre, temp_var, se->expr);
9537 : 8251 : se->expr = temp_var;
9538 : 8251 : }
9539 : :
9540 : :
9541 : : /* The following routine generates code for the intrinsic
9542 : : functions from the ISO_C_BINDING module:
9543 : : * C_LOC
9544 : : * C_FUNLOC
9545 : : * C_ASSOCIATED */
9546 : :
9547 : : static void
9548 : 7682 : conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
9549 : : {
9550 : 7682 : gfc_actual_arglist *arg = expr->value.function.actual;
9551 : :
9552 : 7682 : if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
9553 : : {
9554 : 5459 : if (arg->expr->rank == 0)
9555 : 1679 : gfc_conv_expr_reference (se, arg->expr);
9556 : 3780 : else if (gfc_is_simply_contiguous (arg->expr, false, false))
9557 : 2746 : gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9558 : : else
9559 : : {
9560 : 1034 : gfc_conv_expr_descriptor (se, arg->expr);
9561 : 1034 : se->expr = gfc_conv_descriptor_data_get (se->expr);
9562 : : }
9563 : :
9564 : : /* TODO -- the following two lines shouldn't be necessary, but if
9565 : : they're removed, a bug is exposed later in the code path.
9566 : : This workaround was thus introduced, but will have to be
9567 : : removed; please see PR 35150 for details about the issue. */
9568 : 5459 : se->expr = convert (pvoid_type_node, se->expr);
9569 : 5459 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9570 : : }
9571 : 2223 : else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9572 : 231 : gfc_conv_expr_reference (se, arg->expr);
9573 : 1992 : else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9574 : : {
9575 : 1992 : gfc_se arg1se;
9576 : 1992 : gfc_se arg2se;
9577 : :
9578 : : /* Build the addr_expr for the first argument. The argument is
9579 : : already an *address* so we don't need to set want_pointer in
9580 : : the gfc_se. */
9581 : 1992 : gfc_init_se (&arg1se, NULL);
9582 : 1992 : gfc_conv_expr (&arg1se, arg->expr);
9583 : 1992 : gfc_add_block_to_block (&se->pre, &arg1se.pre);
9584 : 1992 : gfc_add_block_to_block (&se->post, &arg1se.post);
9585 : :
9586 : : /* See if we were given two arguments. */
9587 : 1992 : if (arg->next->expr == NULL)
9588 : : /* Only given one arg so generate a null and do a
9589 : : not-equal comparison against the first arg. */
9590 : 1653 : se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9591 : : arg1se.expr,
9592 : 1653 : fold_convert (TREE_TYPE (arg1se.expr),
9593 : : null_pointer_node));
9594 : : else
9595 : : {
9596 : 339 : tree eq_expr;
9597 : 339 : tree not_null_expr;
9598 : :
9599 : : /* Given two arguments so build the arg2se from second arg. */
9600 : 339 : gfc_init_se (&arg2se, NULL);
9601 : 339 : gfc_conv_expr (&arg2se, arg->next->expr);
9602 : 339 : gfc_add_block_to_block (&se->pre, &arg2se.pre);
9603 : 339 : gfc_add_block_to_block (&se->post, &arg2se.post);
9604 : :
9605 : : /* Generate test to compare that the two args are equal. */
9606 : 339 : eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9607 : : arg1se.expr, arg2se.expr);
9608 : : /* Generate test to ensure that the first arg is not null. */
9609 : 339 : not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9610 : : logical_type_node,
9611 : : arg1se.expr, null_pointer_node);
9612 : :
9613 : : /* Finally, the generated test must check that both arg1 is not
9614 : : NULL and that it is equal to the second arg. */
9615 : 339 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9616 : : logical_type_node,
9617 : : not_null_expr, eq_expr);
9618 : : }
9619 : : }
9620 : : else
9621 : 0 : gcc_unreachable ();
9622 : 7682 : }
9623 : :
9624 : :
9625 : : /* The following routine generates code for the intrinsic
9626 : : subroutines from the ISO_C_BINDING module:
9627 : : * C_F_POINTER
9628 : : * C_F_PROCPOINTER. */
9629 : :
9630 : : static tree
9631 : 2542 : conv_isocbinding_subroutine (gfc_code *code)
9632 : : {
9633 : 2542 : gfc_se se;
9634 : 2542 : gfc_se cptrse;
9635 : 2542 : gfc_se fptrse;
9636 : 2542 : gfc_se shapese;
9637 : 2542 : gfc_ss *shape_ss;
9638 : 2542 : tree desc, dim, tmp, stride, offset;
9639 : 2542 : stmtblock_t body, block;
9640 : 2542 : gfc_loopinfo loop;
9641 : 2542 : gfc_actual_arglist *arg = code->ext.actual;
9642 : :
9643 : 2542 : gfc_init_se (&se, NULL);
9644 : 2542 : gfc_init_se (&cptrse, NULL);
9645 : 2542 : gfc_conv_expr (&cptrse, arg->expr);
9646 : 2542 : gfc_add_block_to_block (&se.pre, &cptrse.pre);
9647 : 2542 : gfc_add_block_to_block (&se.post, &cptrse.post);
9648 : :
9649 : 2542 : gfc_init_se (&fptrse, NULL);
9650 : 2542 : if (arg->next->expr->rank == 0)
9651 : : {
9652 : 2088 : fptrse.want_pointer = 1;
9653 : 2088 : gfc_conv_expr (&fptrse, arg->next->expr);
9654 : 2088 : gfc_add_block_to_block (&se.pre, &fptrse.pre);
9655 : 2088 : gfc_add_block_to_block (&se.post, &fptrse.post);
9656 : 2088 : if (arg->next->expr->symtree->n.sym->attr.proc_pointer
9657 : 2088 : && arg->next->expr->symtree->n.sym->attr.dummy)
9658 : 7 : fptrse.expr = build_fold_indirect_ref_loc (input_location,
9659 : : fptrse.expr);
9660 : 4176 : se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
9661 : 2088 : TREE_TYPE (fptrse.expr),
9662 : : fptrse.expr,
9663 : 2088 : fold_convert (TREE_TYPE (fptrse.expr),
9664 : : cptrse.expr));
9665 : 2088 : gfc_add_expr_to_block (&se.pre, se.expr);
9666 : 2088 : gfc_add_block_to_block (&se.pre, &se.post);
9667 : 2088 : return gfc_finish_block (&se.pre);
9668 : : }
9669 : :
9670 : 454 : gfc_start_block (&block);
9671 : :
9672 : : /* Get the descriptor of the Fortran pointer. */
9673 : 454 : fptrse.descriptor_only = 1;
9674 : 454 : gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
9675 : 454 : gfc_add_block_to_block (&block, &fptrse.pre);
9676 : 454 : desc = fptrse.expr;
9677 : :
9678 : : /* Set the span field. */
9679 : 454 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
9680 : 454 : tmp = fold_convert (gfc_array_index_type, tmp);
9681 : 454 : gfc_conv_descriptor_span_set (&block, desc, tmp);
9682 : :
9683 : : /* Set data value, dtype, and offset. */
9684 : 454 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
9685 : 454 : gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
9686 : 454 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
9687 : 454 : gfc_get_dtype (TREE_TYPE (desc)));
9688 : :
9689 : : /* Start scalarization of the bounds, using the shape argument. */
9690 : :
9691 : 454 : shape_ss = gfc_walk_expr (arg->next->next->expr);
9692 : 454 : gcc_assert (shape_ss != gfc_ss_terminator);
9693 : 454 : gfc_init_se (&shapese, NULL);
9694 : :
9695 : 454 : gfc_init_loopinfo (&loop);
9696 : 454 : gfc_add_ss_to_loop (&loop, shape_ss);
9697 : 454 : gfc_conv_ss_startstride (&loop);
9698 : 454 : gfc_conv_loop_setup (&loop, &arg->next->expr->where);
9699 : 454 : gfc_mark_ss_chain_used (shape_ss, 1);
9700 : :
9701 : 454 : gfc_copy_loopinfo_to_se (&shapese, &loop);
9702 : 454 : shapese.ss = shape_ss;
9703 : :
9704 : 454 : stride = gfc_create_var (gfc_array_index_type, "stride");
9705 : 454 : offset = gfc_create_var (gfc_array_index_type, "offset");
9706 : 454 : gfc_add_modify (&block, stride, gfc_index_one_node);
9707 : 454 : gfc_add_modify (&block, offset, gfc_index_zero_node);
9708 : :
9709 : : /* Loop body. */
9710 : 454 : gfc_start_scalarized_body (&loop, &body);
9711 : :
9712 : 454 : dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9713 : : loop.loopvar[0], loop.from[0]);
9714 : :
9715 : : /* Set bounds and stride. */
9716 : 454 : gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
9717 : 454 : gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
9718 : :
9719 : 454 : gfc_conv_expr (&shapese, arg->next->next->expr);
9720 : 454 : gfc_add_block_to_block (&body, &shapese.pre);
9721 : 454 : gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
9722 : 454 : gfc_add_block_to_block (&body, &shapese.post);
9723 : :
9724 : : /* Calculate offset. */
9725 : 454 : gfc_add_modify (&body, offset,
9726 : : fold_build2_loc (input_location, PLUS_EXPR,
9727 : : gfc_array_index_type, offset, stride));
9728 : : /* Update stride. */
9729 : 454 : gfc_add_modify (&body, stride,
9730 : : fold_build2_loc (input_location, MULT_EXPR,
9731 : : gfc_array_index_type, stride,
9732 : : fold_convert (gfc_array_index_type,
9733 : : shapese.expr)));
9734 : : /* Finish scalarization loop. */
9735 : 454 : gfc_trans_scalarizing_loops (&loop, &body);
9736 : 454 : gfc_add_block_to_block (&block, &loop.pre);
9737 : 454 : gfc_add_block_to_block (&block, &loop.post);
9738 : 454 : gfc_add_block_to_block (&block, &fptrse.post);
9739 : 454 : gfc_cleanup_loop (&loop);
9740 : :
9741 : 454 : gfc_add_modify (&block, offset,
9742 : : fold_build1_loc (input_location, NEGATE_EXPR,
9743 : : gfc_array_index_type, offset));
9744 : 454 : gfc_conv_descriptor_offset_set (&block, desc, offset);
9745 : :
9746 : 454 : gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
9747 : 454 : gfc_add_block_to_block (&se.pre, &se.post);
9748 : 454 : return gfc_finish_block (&se.pre);
9749 : : }
9750 : :
9751 : :
9752 : : /* Save and restore floating-point state. */
9753 : :
9754 : : tree
9755 : 900 : gfc_save_fp_state (stmtblock_t *block)
9756 : : {
9757 : 900 : tree type, fpstate, tmp;
9758 : :
9759 : 900 : type = build_array_type (char_type_node,
9760 : : build_range_type (size_type_node, size_zero_node,
9761 : 900 : size_int (GFC_FPE_STATE_BUFFER_SIZE)));
9762 : 900 : fpstate = gfc_create_var (type, "fpstate");
9763 : 900 : fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
9764 : :
9765 : 900 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
9766 : : 1, fpstate);
9767 : 900 : gfc_add_expr_to_block (block, tmp);
9768 : :
9769 : 900 : return fpstate;
9770 : : }
9771 : :
9772 : :
9773 : : void
9774 : 900 : gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
9775 : : {
9776 : 900 : tree tmp;
9777 : :
9778 : 900 : tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
9779 : : 1, fpstate);
9780 : 900 : gfc_add_expr_to_block (block, tmp);
9781 : 900 : }
9782 : :
9783 : :
9784 : : /* Generate code for arguments of IEEE functions. */
9785 : :
9786 : : static void
9787 : 12385 : conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
9788 : : int nargs)
9789 : : {
9790 : 12385 : gfc_actual_arglist *actual;
9791 : 12385 : gfc_expr *e;
9792 : 12385 : gfc_se argse;
9793 : 12385 : int arg;
9794 : :
9795 : 12385 : actual = expr->value.function.actual;
9796 : 34245 : for (arg = 0; arg < nargs; arg++, actual = actual->next)
9797 : : {
9798 : 21860 : gcc_assert (actual);
9799 : 21860 : e = actual->expr;
9800 : :
9801 : 21860 : gfc_init_se (&argse, se);
9802 : 21860 : gfc_conv_expr_val (&argse, e);
9803 : :
9804 : 21860 : gfc_add_block_to_block (&se->pre, &argse.pre);
9805 : 21860 : gfc_add_block_to_block (&se->post, &argse.post);
9806 : 21860 : argarray[arg] = argse.expr;
9807 : : }
9808 : 12385 : }
9809 : :
9810 : :
9811 : : /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE
9812 : : and IEEE_UNORDERED, which translate directly to GCC type-generic
9813 : : built-ins. */
9814 : :
9815 : : static void
9816 : 1062 : conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
9817 : : enum built_in_function code, int nargs)
9818 : : {
9819 : 1062 : tree args[2];
9820 : 1062 : gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args));
9821 : :
9822 : 1062 : conv_ieee_function_args (se, expr, args, nargs);
9823 : 1062 : se->expr = build_call_expr_loc_array (input_location,
9824 : : builtin_decl_explicit (code),
9825 : : nargs, args);
9826 : 2388 : STRIP_TYPE_NOPS (se->expr);
9827 : 1062 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9828 : 1062 : }
9829 : :
9830 : :
9831 : : /* Generate code for intrinsics IEEE_SIGNBIT. */
9832 : :
9833 : : static void
9834 : 624 : conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr)
9835 : : {
9836 : 624 : tree arg, signbit;
9837 : :
9838 : 624 : conv_ieee_function_args (se, expr, &arg, 1);
9839 : 624 : signbit = build_call_expr_loc (input_location,
9840 : : builtin_decl_explicit (BUILT_IN_SIGNBIT),
9841 : : 1, arg);
9842 : 624 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9843 : : signbit, integer_zero_node);
9844 : 624 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit);
9845 : 624 : }
9846 : :
9847 : :
9848 : : /* Generate code for IEEE_IS_NORMAL intrinsic:
9849 : : IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
9850 : :
9851 : : static void
9852 : 312 : conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
9853 : : {
9854 : 312 : tree arg, isnormal, iszero;
9855 : :
9856 : : /* Convert arg, evaluate it only once. */
9857 : 312 : conv_ieee_function_args (se, expr, &arg, 1);
9858 : 312 : arg = gfc_evaluate_now (arg, &se->pre);
9859 : :
9860 : 312 : isnormal = build_call_expr_loc (input_location,
9861 : : builtin_decl_explicit (BUILT_IN_ISNORMAL),
9862 : : 1, arg);
9863 : 312 : iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
9864 : 312 : build_real_from_int_cst (TREE_TYPE (arg),
9865 : 312 : integer_zero_node));
9866 : 312 : se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9867 : : logical_type_node, isnormal, iszero);
9868 : 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9869 : 312 : }
9870 : :
9871 : :
9872 : : /* Generate code for IEEE_IS_NEGATIVE intrinsic:
9873 : : IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
9874 : :
9875 : : static void
9876 : 312 : conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
9877 : : {
9878 : 312 : tree arg, signbit, isnan;
9879 : :
9880 : : /* Convert arg, evaluate it only once. */
9881 : 312 : conv_ieee_function_args (se, expr, &arg, 1);
9882 : 312 : arg = gfc_evaluate_now (arg, &se->pre);
9883 : :
9884 : 312 : isnan = build_call_expr_loc (input_location,
9885 : : builtin_decl_explicit (BUILT_IN_ISNAN),
9886 : : 1, arg);
9887 : 936 : STRIP_TYPE_NOPS (isnan);
9888 : :
9889 : 312 : signbit = build_call_expr_loc (input_location,
9890 : : builtin_decl_explicit (BUILT_IN_SIGNBIT),
9891 : : 1, arg);
9892 : 312 : signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9893 : : signbit, integer_zero_node);
9894 : :
9895 : 312 : se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9896 : : logical_type_node, signbit,
9897 : : fold_build1_loc (input_location, TRUTH_NOT_EXPR,
9898 : 312 : TREE_TYPE(isnan), isnan));
9899 : :
9900 : 312 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9901 : 312 : }
9902 : :
9903 : :
9904 : : /* Generate code for IEEE_LOGB and IEEE_RINT. */
9905 : :
9906 : : static void
9907 : 240 : conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
9908 : : enum built_in_function code)
9909 : : {
9910 : 240 : tree arg, decl, call, fpstate;
9911 : 240 : int argprec;
9912 : :
9913 : 240 : conv_ieee_function_args (se, expr, &arg, 1);
9914 : 240 : argprec = TYPE_PRECISION (TREE_TYPE (arg));
9915 : 240 : decl = builtin_decl_for_precision (code, argprec);
9916 : :
9917 : : /* Save floating-point state. */
9918 : 240 : fpstate = gfc_save_fp_state (&se->pre);
9919 : :
9920 : : /* Make the function call. */
9921 : 240 : call = build_call_expr_loc (input_location, decl, 1, arg);
9922 : 240 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
9923 : :
9924 : : /* Restore floating-point state. */
9925 : 240 : gfc_restore_fp_state (&se->post, fpstate);
9926 : 240 : }
9927 : :
9928 : :
9929 : : /* Generate code for IEEE_REM. */
9930 : :
9931 : : static void
9932 : 84 : conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
9933 : : {
9934 : 84 : tree args[2], decl, call, fpstate;
9935 : 84 : int argprec;
9936 : :
9937 : 84 : conv_ieee_function_args (se, expr, args, 2);
9938 : :
9939 : : /* If arguments have unequal size, convert them to the larger. */
9940 : 84 : if (TYPE_PRECISION (TREE_TYPE (args[0]))
9941 : 84 : > TYPE_PRECISION (TREE_TYPE (args[1])))
9942 : 6 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
9943 : 78 : else if (TYPE_PRECISION (TREE_TYPE (args[1]))
9944 : 78 : > TYPE_PRECISION (TREE_TYPE (args[0])))
9945 : 24 : args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
9946 : :
9947 : 84 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9948 : 84 : decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
9949 : :
9950 : : /* Save floating-point state. */
9951 : 84 : fpstate = gfc_save_fp_state (&se->pre);
9952 : :
9953 : : /* Make the function call. */
9954 : 84 : call = build_call_expr_loc_array (input_location, decl, 2, args);
9955 : 84 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
9956 : :
9957 : : /* Restore floating-point state. */
9958 : 84 : gfc_restore_fp_state (&se->post, fpstate);
9959 : 84 : }
9960 : :
9961 : :
9962 : : /* Generate code for IEEE_NEXT_AFTER. */
9963 : :
9964 : : static void
9965 : 180 : conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
9966 : : {
9967 : 180 : tree args[2], decl, call, fpstate;
9968 : 180 : int argprec;
9969 : :
9970 : 180 : conv_ieee_function_args (se, expr, args, 2);
9971 : :
9972 : : /* Result has the characteristics of first argument. */
9973 : 180 : args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
9974 : 180 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9975 : 180 : decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
9976 : :
9977 : : /* Save floating-point state. */
9978 : 180 : fpstate = gfc_save_fp_state (&se->pre);
9979 : :
9980 : : /* Make the function call. */
9981 : 180 : call = build_call_expr_loc_array (input_location, decl, 2, args);
9982 : 180 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
9983 : :
9984 : : /* Restore floating-point state. */
9985 : 180 : gfc_restore_fp_state (&se->post, fpstate);
9986 : 180 : }
9987 : :
9988 : :
9989 : : /* Generate code for IEEE_SCALB. */
9990 : :
9991 : : static void
9992 : 228 : conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
9993 : : {
9994 : 228 : tree args[2], decl, call, huge, type;
9995 : 228 : int argprec, n;
9996 : :
9997 : 228 : conv_ieee_function_args (se, expr, args, 2);
9998 : :
9999 : : /* Result has the characteristics of first argument. */
10000 : 228 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10001 : 228 : decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
10002 : :
10003 : 228 : if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
10004 : : {
10005 : : /* We need to fold the integer into the range of a C int. */
10006 : 18 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10007 : 18 : type = TREE_TYPE (args[1]);
10008 : :
10009 : 18 : n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
10010 : 18 : huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
10011 : : gfc_c_int_kind);
10012 : 18 : huge = fold_convert (type, huge);
10013 : 18 : args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
10014 : : huge);
10015 : 18 : args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
10016 : : fold_build1_loc (input_location, NEGATE_EXPR,
10017 : : type, huge));
10018 : : }
10019 : :
10020 : 228 : args[1] = fold_convert (integer_type_node, args[1]);
10021 : :
10022 : : /* Make the function call. */
10023 : 228 : call = build_call_expr_loc_array (input_location, decl, 2, args);
10024 : 228 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10025 : 228 : }
10026 : :
10027 : :
10028 : : /* Generate code for IEEE_COPY_SIGN. */
10029 : :
10030 : : static void
10031 : 576 : conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
10032 : : {
10033 : 576 : tree args[2], decl, sign;
10034 : 576 : int argprec;
10035 : :
10036 : 576 : conv_ieee_function_args (se, expr, args, 2);
10037 : :
10038 : : /* Get the sign of the second argument. */
10039 : 576 : sign = build_call_expr_loc (input_location,
10040 : : builtin_decl_explicit (BUILT_IN_SIGNBIT),
10041 : : 1, args[1]);
10042 : 576 : sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10043 : : sign, integer_zero_node);
10044 : :
10045 : : /* Create a value of one, with the right sign. */
10046 : 576 : sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
10047 : : sign,
10048 : : fold_build1_loc (input_location, NEGATE_EXPR,
10049 : : integer_type_node,
10050 : : integer_one_node),
10051 : : integer_one_node);
10052 : 576 : args[1] = fold_convert (TREE_TYPE (args[0]), sign);
10053 : :
10054 : 576 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10055 : 576 : decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
10056 : :
10057 : 576 : se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
10058 : 576 : }
10059 : :
10060 : :
10061 : : /* Generate code for IEEE_CLASS. */
10062 : :
10063 : : static void
10064 : 648 : conv_intrinsic_ieee_class (gfc_se *se, gfc_expr *expr)
10065 : : {
10066 : 648 : tree arg, c, t1, t2, t3, t4;
10067 : :
10068 : : /* Convert arg, evaluate it only once. */
10069 : 648 : conv_ieee_function_args (se, expr, &arg, 1);
10070 : 648 : arg = gfc_evaluate_now (arg, &se->pre);
10071 : :
10072 : 648 : c = build_call_expr_loc (input_location,
10073 : : builtin_decl_explicit (BUILT_IN_FPCLASSIFY), 6,
10074 : 648 : build_int_cst (integer_type_node, IEEE_QUIET_NAN),
10075 : : build_int_cst (integer_type_node,
10076 : 648 : IEEE_POSITIVE_INF),
10077 : : build_int_cst (integer_type_node,
10078 : 648 : IEEE_POSITIVE_NORMAL),
10079 : : build_int_cst (integer_type_node,
10080 : 648 : IEEE_POSITIVE_DENORMAL),
10081 : : build_int_cst (integer_type_node,
10082 : 648 : IEEE_POSITIVE_ZERO),
10083 : : arg);
10084 : 648 : c = gfc_evaluate_now (c, &se->pre);
10085 : 648 : t1 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10086 : : c, build_int_cst (integer_type_node,
10087 : 648 : IEEE_QUIET_NAN));
10088 : 648 : t2 = build_call_expr_loc (input_location,
10089 : : builtin_decl_explicit (BUILT_IN_ISSIGNALING), 1,
10090 : : arg);
10091 : 648 : t2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10092 : 648 : t2, build_zero_cst (TREE_TYPE (t2)));
10093 : 648 : t1 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10094 : : logical_type_node, t1, t2);
10095 : 648 : t3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10096 : : c, build_int_cst (integer_type_node,
10097 : 648 : IEEE_POSITIVE_ZERO));
10098 : 648 : t4 = build_call_expr_loc (input_location,
10099 : : builtin_decl_explicit (BUILT_IN_SIGNBIT), 1,
10100 : : arg);
10101 : 648 : t4 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10102 : 648 : t4, build_zero_cst (TREE_TYPE (t4)));
10103 : 648 : t3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10104 : : logical_type_node, t3, t4);
10105 : 648 : int s = IEEE_NEGATIVE_ZERO + IEEE_POSITIVE_ZERO;
10106 : 648 : gcc_assert (IEEE_NEGATIVE_INF == s - IEEE_POSITIVE_INF);
10107 : 648 : gcc_assert (IEEE_NEGATIVE_NORMAL == s - IEEE_POSITIVE_NORMAL);
10108 : 648 : gcc_assert (IEEE_NEGATIVE_DENORMAL == s - IEEE_POSITIVE_DENORMAL);
10109 : 648 : gcc_assert (IEEE_NEGATIVE_SUBNORMAL == s - IEEE_POSITIVE_SUBNORMAL);
10110 : 648 : gcc_assert (IEEE_NEGATIVE_ZERO == s - IEEE_POSITIVE_ZERO);
10111 : 648 : t4 = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (c),
10112 : 648 : build_int_cst (TREE_TYPE (c), s), c);
10113 : 648 : t3 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c),
10114 : : t3, t4, c);
10115 : 648 : t1 = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (c), t1,
10116 : 648 : build_int_cst (TREE_TYPE (c), IEEE_SIGNALING_NAN),
10117 : : t3);
10118 : 648 : tree type = gfc_typenode_for_spec (&expr->ts);
10119 : : /* Perform a quick sanity check that the return type is
10120 : : IEEE_CLASS_TYPE derived type defined in
10121 : : libgfortran/ieee/ieee_arithmetic.F90
10122 : : Primarily check that it is a derived type with a single
10123 : : member in it. */
10124 : 648 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10125 : 648 : tree field = NULL_TREE;
10126 : 1296 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10127 : 648 : if (TREE_CODE (f) == FIELD_DECL)
10128 : : {
10129 : 648 : gcc_assert (field == NULL_TREE);
10130 : : field = f;
10131 : : }
10132 : 648 : gcc_assert (field);
10133 : 648 : t1 = fold_convert (TREE_TYPE (field), t1);
10134 : 648 : se->expr = build_constructor_single (type, field, t1);
10135 : 648 : }
10136 : :
10137 : :
10138 : : /* Generate code for IEEE_VALUE. */
10139 : :
10140 : : static void
10141 : 1039 : conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr)
10142 : : {
10143 : 1039 : tree args[2], arg, ret, tmp;
10144 : 1039 : stmtblock_t body;
10145 : :
10146 : : /* Convert args, evaluate the second one only once. */
10147 : 1039 : conv_ieee_function_args (se, expr, args, 2);
10148 : 1039 : arg = gfc_evaluate_now (args[1], &se->pre);
10149 : :
10150 : 1039 : tree type = TREE_TYPE (arg);
10151 : : /* Perform a quick sanity check that the second argument's type is
10152 : : IEEE_CLASS_TYPE derived type defined in
10153 : : libgfortran/ieee/ieee_arithmetic.F90
10154 : : Primarily check that it is a derived type with a single
10155 : : member in it. */
10156 : 1039 : gcc_assert (TREE_CODE (type) == RECORD_TYPE);
10157 : 1039 : tree field = NULL_TREE;
10158 : 2078 : for (tree f = TYPE_FIELDS (type); f != NULL_TREE; f = DECL_CHAIN (f))
10159 : 1039 : if (TREE_CODE (f) == FIELD_DECL)
10160 : : {
10161 : 1039 : gcc_assert (field == NULL_TREE);
10162 : : field = f;
10163 : : }
10164 : 1039 : gcc_assert (field);
10165 : 1039 : arg = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10166 : : arg, field, NULL_TREE);
10167 : 1039 : arg = gfc_evaluate_now (arg, &se->pre);
10168 : :
10169 : 1039 : type = gfc_typenode_for_spec (&expr->ts);
10170 : 1039 : gcc_assert (SCALAR_FLOAT_TYPE_P (type));
10171 : 1039 : ret = gfc_create_var (type, NULL);
10172 : :
10173 : 1039 : gfc_init_block (&body);
10174 : :
10175 : 1039 : tree end_label = gfc_build_label_decl (NULL_TREE);
10176 : 11429 : for (int c = IEEE_SIGNALING_NAN; c <= IEEE_POSITIVE_INF; ++c)
10177 : : {
10178 : 10390 : tree label = gfc_build_label_decl (NULL_TREE);
10179 : 10390 : tree low = build_int_cst (TREE_TYPE (arg), c);
10180 : 10390 : tmp = build_case_label (low, low, label);
10181 : 10390 : gfc_add_expr_to_block (&body, tmp);
10182 : :
10183 : 10390 : REAL_VALUE_TYPE real;
10184 : 10390 : int k;
10185 : 10390 : switch (c)
10186 : : {
10187 : 1039 : case IEEE_SIGNALING_NAN:
10188 : 1039 : real_nan (&real, "", 0, TYPE_MODE (type));
10189 : 1039 : break;
10190 : 1039 : case IEEE_QUIET_NAN:
10191 : 1039 : real_nan (&real, "", 1, TYPE_MODE (type));
10192 : 1039 : break;
10193 : 1039 : case IEEE_NEGATIVE_INF:
10194 : 1039 : real_inf (&real);
10195 : 1039 : real = real_value_negate (&real);
10196 : 1039 : break;
10197 : 1039 : case IEEE_NEGATIVE_NORMAL:
10198 : 1039 : real_from_integer (&real, TYPE_MODE (type), -42, SIGNED);
10199 : 1039 : break;
10200 : 1039 : case IEEE_NEGATIVE_DENORMAL:
10201 : 1039 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10202 : 1039 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10203 : : type, GFC_RND_MODE);
10204 : 1039 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10205 : 1039 : real = real_value_negate (&real);
10206 : 1039 : break;
10207 : 1039 : case IEEE_NEGATIVE_ZERO:
10208 : 1039 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10209 : 1039 : real = real_value_negate (&real);
10210 : 1039 : break;
10211 : 1039 : case IEEE_POSITIVE_ZERO:
10212 : : /* Make this also the default: label. The other possibility
10213 : : would be to add a separate default: label followed by
10214 : : __builtin_unreachable (). */
10215 : 1039 : label = gfc_build_label_decl (NULL_TREE);
10216 : 1039 : tmp = build_case_label (NULL_TREE, NULL_TREE, label);
10217 : 1039 : gfc_add_expr_to_block (&body, tmp);
10218 : 1039 : real_from_integer (&real, TYPE_MODE (type), 0, SIGNED);
10219 : 1039 : break;
10220 : 1039 : case IEEE_POSITIVE_DENORMAL:
10221 : 1039 : k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
10222 : 1039 : real_from_mpfr (&real, gfc_real_kinds[k].tiny,
10223 : : type, GFC_RND_MODE);
10224 : 1039 : real_arithmetic (&real, RDIV_EXPR, &real, &dconst2);
10225 : 1039 : break;
10226 : 1039 : case IEEE_POSITIVE_NORMAL:
10227 : 1039 : real_from_integer (&real, TYPE_MODE (type), 42, SIGNED);
10228 : 1039 : break;
10229 : 1039 : case IEEE_POSITIVE_INF:
10230 : 1039 : real_inf (&real);
10231 : 1039 : break;
10232 : : default:
10233 : : gcc_unreachable ();
10234 : : }
10235 : :
10236 : 10390 : tree val = build_real (type, real);
10237 : 10390 : gfc_add_modify (&body, ret, val);
10238 : :
10239 : 10390 : tmp = build1_v (GOTO_EXPR, end_label);
10240 : 10390 : gfc_add_expr_to_block (&body, tmp);
10241 : : }
10242 : :
10243 : 1039 : tmp = gfc_finish_block (&body);
10244 : 1039 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, arg, tmp);
10245 : 1039 : gfc_add_expr_to_block (&se->pre, tmp);
10246 : :
10247 : 1039 : tmp = build1_v (LABEL_EXPR, end_label);
10248 : 1039 : gfc_add_expr_to_block (&se->pre, tmp);
10249 : :
10250 : 1039 : se->expr = ret;
10251 : 1039 : }
10252 : :
10253 : :
10254 : : /* Generate code for IEEE_FMA. */
10255 : :
10256 : : static void
10257 : 120 : conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr)
10258 : : {
10259 : 120 : tree args[3], decl, call;
10260 : 120 : int argprec;
10261 : :
10262 : 120 : conv_ieee_function_args (se, expr, args, 3);
10263 : :
10264 : : /* All three arguments should have the same type. */
10265 : 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10266 : 120 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2])));
10267 : :
10268 : : /* Call the type-generic FMA built-in. */
10269 : 120 : argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
10270 : 120 : decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec);
10271 : 120 : call = build_call_expr_loc_array (input_location, decl, 3, args);
10272 : :
10273 : : /* Convert to the final type. */
10274 : 120 : se->expr = fold_convert (TREE_TYPE (args[0]), call);
10275 : 120 : }
10276 : :
10277 : :
10278 : : /* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */
10279 : :
10280 : : static void
10281 : 3072 : conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max,
10282 : : const char *name)
10283 : : {
10284 : 3072 : tree args[2], func;
10285 : 3072 : built_in_function fn;
10286 : :
10287 : 3072 : conv_ieee_function_args (se, expr, args, 2);
10288 : 3072 : gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1])));
10289 : 3072 : args[0] = gfc_evaluate_now (args[0], &se->pre);
10290 : 3072 : args[1] = gfc_evaluate_now (args[1], &se->pre);
10291 : :
10292 : 3072 : if (startswith (name, "mag"))
10293 : : {
10294 : : /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions
10295 : : fminmag() and fmaxmag(), which do not exist as built-ins.
10296 : :
10297 : : Following glibc, we emit this:
10298 : :
10299 : : fminmag (x, y) {
10300 : : ax = ABS (x);
10301 : : ay = ABS (y);
10302 : : if (isless (ax, ay))
10303 : : return x;
10304 : : else if (isgreater (ax, ay))
10305 : : return y;
10306 : : else if (ax == ay)
10307 : : return x < y ? x : y;
10308 : : else if (issignaling (x) || issignaling (y))
10309 : : return x + y;
10310 : : else
10311 : : return isnan (y) ? x : y;
10312 : : }
10313 : :
10314 : : fmaxmag (x, y) {
10315 : : ax = ABS (x);
10316 : : ay = ABS (y);
10317 : : if (isgreater (ax, ay))
10318 : : return x;
10319 : : else if (isless (ax, ay))
10320 : : return y;
10321 : : else if (ax == ay)
10322 : : return x > y ? x : y;
10323 : : else if (issignaling (x) || issignaling (y))
10324 : : return x + y;
10325 : : else
10326 : : return isnan (y) ? x : y;
10327 : : }
10328 : :
10329 : : */
10330 : :
10331 : 1536 : tree abs0, abs1, sig0, sig1;
10332 : 1536 : tree cond1, cond2, cond3, cond4, cond5;
10333 : 1536 : tree res;
10334 : 1536 : tree type = TREE_TYPE (args[0]);
10335 : :
10336 : 1536 : func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
10337 : 1536 : abs0 = build_call_expr_loc (input_location, func, 1, args[0]);
10338 : 1536 : abs1 = build_call_expr_loc (input_location, func, 1, args[1]);
10339 : 1536 : abs0 = gfc_evaluate_now (abs0, &se->pre);
10340 : 1536 : abs1 = gfc_evaluate_now (abs1, &se->pre);
10341 : :
10342 : 1536 : cond5 = build_call_expr_loc (input_location,
10343 : : builtin_decl_explicit (BUILT_IN_ISNAN),
10344 : : 1, args[1]);
10345 : 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond5,
10346 : : args[0], args[1]);
10347 : :
10348 : 1536 : sig0 = build_call_expr_loc (input_location,
10349 : : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
10350 : : 1, args[0]);
10351 : 1536 : sig1 = build_call_expr_loc (input_location,
10352 : : builtin_decl_explicit (BUILT_IN_ISSIGNALING),
10353 : : 1, args[1]);
10354 : 1536 : cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
10355 : : logical_type_node, sig0, sig1);
10356 : 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond4,
10357 : : fold_build2_loc (input_location, PLUS_EXPR,
10358 : : type, args[0], args[1]),
10359 : : res);
10360 : :
10361 : 1536 : cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10362 : : abs0, abs1);
10363 : 2304 : res = fold_build3_loc (input_location, COND_EXPR, type, cond3,
10364 : : fold_build2_loc (input_location,
10365 : : max ? MAX_EXPR : MIN_EXPR,
10366 : : type, args[0], args[1]),
10367 : : res);
10368 : :
10369 : 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER);
10370 : 1536 : cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10371 : 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond2,
10372 : : args[1], res);
10373 : :
10374 : 2304 : func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS);
10375 : 1536 : cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1);
10376 : 1536 : res = fold_build3_loc (input_location, COND_EXPR, type, cond1,
10377 : : args[0], res);
10378 : :
10379 : 1536 : se->expr = res;
10380 : : }
10381 : : else
10382 : : {
10383 : : /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */
10384 : 1536 : fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN;
10385 : 1536 : func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind);
10386 : 1536 : se->expr = build_call_expr_loc_array (input_location, func, 2, args);
10387 : : }
10388 : 3072 : }
10389 : :
10390 : :
10391 : : /* Generate code for comparison functions IEEE_QUIET_* and
10392 : : IEEE_SIGNALING_*. */
10393 : :
10394 : : static void
10395 : 3888 : conv_intrinsic_ieee_comparison (gfc_se * se, gfc_expr * expr, int signaling,
10396 : : const char *name)
10397 : : {
10398 : 3888 : tree args[2];
10399 : 3888 : tree arg1, arg2, res;
10400 : :
10401 : : /* Evaluate arguments only once. */
10402 : 3888 : conv_ieee_function_args (se, expr, args, 2);
10403 : 3888 : arg1 = gfc_evaluate_now (args[0], &se->pre);
10404 : 3888 : arg2 = gfc_evaluate_now (args[1], &se->pre);
10405 : :
10406 : 3888 : if (startswith (name, "eq"))
10407 : : {
10408 : 648 : if (signaling)
10409 : 324 : res = build_call_expr_loc (input_location,
10410 : : builtin_decl_explicit (BUILT_IN_ISEQSIG),
10411 : : 2, arg1, arg2);
10412 : : else
10413 : 324 : res = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10414 : : arg1, arg2);
10415 : : }
10416 : 3240 : else if (startswith (name, "ne"))
10417 : : {
10418 : 648 : if (signaling)
10419 : : {
10420 : 324 : res = build_call_expr_loc (input_location,
10421 : : builtin_decl_explicit (BUILT_IN_ISEQSIG),
10422 : : 2, arg1, arg2);
10423 : 324 : res = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
10424 : : logical_type_node, res);
10425 : : }
10426 : : else
10427 : 324 : res = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10428 : : arg1, arg2);
10429 : : }
10430 : 2592 : else if (startswith (name, "ge"))
10431 : : {
10432 : 648 : if (signaling)
10433 : 324 : res = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10434 : : arg1, arg2);
10435 : : else
10436 : 324 : res = build_call_expr_loc (input_location,
10437 : : builtin_decl_explicit (BUILT_IN_ISGREATEREQUAL),
10438 : : 2, arg1, arg2);
10439 : : }
10440 : 1944 : else if (startswith (name, "gt"))
10441 : : {
10442 : 648 : if (signaling)
10443 : 324 : res = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
10444 : : arg1, arg2);
10445 : : else
10446 : 324 : res = build_call_expr_loc (input_location,
10447 : : builtin_decl_explicit (BUILT_IN_ISGREATER),
10448 : : 2, arg1, arg2);
10449 : : }
10450 : 1296 : else if (startswith (name, "le"))
10451 : : {
10452 : 648 : if (signaling)
10453 : 324 : res = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
10454 : : arg1, arg2);
10455 : : else
10456 : 324 : res = build_call_expr_loc (input_location,
10457 : : builtin_decl_explicit (BUILT_IN_ISLESSEQUAL),
10458 : : 2, arg1, arg2);
10459 : : }
10460 : 648 : else if (startswith (name, "lt"))
10461 : : {
10462 : 648 : if (signaling)
10463 : 324 : res = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10464 : : arg1, arg2);
10465 : : else
10466 : 324 : res = build_call_expr_loc (input_location,
10467 : : builtin_decl_explicit (BUILT_IN_ISLESS),
10468 : : 2, arg1, arg2);
10469 : : }
10470 : : else
10471 : 0 : gcc_unreachable ();
10472 : :
10473 : 3888 : se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), res);
10474 : 3888 : }
10475 : :
10476 : :
10477 : : /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
10478 : : module. */
10479 : :
10480 : : bool
10481 : 13807 : gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
10482 : : {
10483 : 13807 : const char *name = expr->value.function.name;
10484 : :
10485 : 13807 : if (startswith (name, "_gfortran_ieee_is_nan"))
10486 : 522 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
10487 : 13285 : else if (startswith (name, "_gfortran_ieee_is_finite"))
10488 : 372 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
10489 : 12913 : else if (startswith (name, "_gfortran_ieee_unordered"))
10490 : 168 : conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
10491 : 12745 : else if (startswith (name, "_gfortran_ieee_signbit"))
10492 : 624 : conv_intrinsic_ieee_signbit (se, expr);
10493 : 12121 : else if (startswith (name, "_gfortran_ieee_is_normal"))
10494 : 312 : conv_intrinsic_ieee_is_normal (se, expr);
10495 : 11809 : else if (startswith (name, "_gfortran_ieee_is_negative"))
10496 : 312 : conv_intrinsic_ieee_is_negative (se, expr);
10497 : 11497 : else if (startswith (name, "_gfortran_ieee_copy_sign"))
10498 : 576 : conv_intrinsic_ieee_copy_sign (se, expr);
10499 : 10921 : else if (startswith (name, "_gfortran_ieee_scalb"))
10500 : 228 : conv_intrinsic_ieee_scalb (se, expr);
10501 : 10693 : else if (startswith (name, "_gfortran_ieee_next_after"))
10502 : 180 : conv_intrinsic_ieee_next_after (se, expr);
10503 : 10513 : else if (startswith (name, "_gfortran_ieee_rem"))
10504 : 84 : conv_intrinsic_ieee_rem (se, expr);
10505 : 10429 : else if (startswith (name, "_gfortran_ieee_logb"))
10506 : 144 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
10507 : 10285 : else if (startswith (name, "_gfortran_ieee_rint"))
10508 : 96 : conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
10509 : 10189 : else if (startswith (name, "ieee_class_") && ISDIGIT (name[11]))
10510 : 648 : conv_intrinsic_ieee_class (se, expr);
10511 : 9541 : else if (startswith (name, "ieee_value_") && ISDIGIT (name[11]))
10512 : 1039 : conv_intrinsic_ieee_value (se, expr);
10513 : 8502 : else if (startswith (name, "_gfortran_ieee_fma"))
10514 : 120 : conv_intrinsic_ieee_fma (se, expr);
10515 : 8382 : else if (startswith (name, "_gfortran_ieee_min_num_"))
10516 : 1536 : conv_intrinsic_ieee_minmax (se, expr, 0, name + 23);
10517 : 6846 : else if (startswith (name, "_gfortran_ieee_max_num_"))
10518 : 1536 : conv_intrinsic_ieee_minmax (se, expr, 1, name + 23);
10519 : 5310 : else if (startswith (name, "_gfortran_ieee_quiet_"))
10520 : 1944 : conv_intrinsic_ieee_comparison (se, expr, 0, name + 21);
10521 : 3366 : else if (startswith (name, "_gfortran_ieee_signaling_"))
10522 : 1944 : conv_intrinsic_ieee_comparison (se, expr, 1, name + 25);
10523 : : else
10524 : : /* It is not among the functions we translate directly. We return
10525 : : false, so a library function call is emitted. */
10526 : : return false;
10527 : :
10528 : : return true;
10529 : : }
10530 : :
10531 : :
10532 : : /* Generate a direct call to malloc() for the MALLOC intrinsic. */
10533 : :
10534 : : static void
10535 : 16 : gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
10536 : : {
10537 : 16 : tree arg, res, restype;
10538 : :
10539 : 16 : gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
10540 : 16 : arg = fold_convert (size_type_node, arg);
10541 : 16 : res = build_call_expr_loc (input_location,
10542 : : builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
10543 : 16 : restype = gfc_typenode_for_spec (&expr->ts);
10544 : 16 : se->expr = fold_convert (restype, res);
10545 : 16 : }
10546 : :
10547 : :
10548 : : /* Generate code for an intrinsic function. Some map directly to library
10549 : : calls, others get special handling. In some cases the name of the function
10550 : : used depends on the type specifiers. */
10551 : :
10552 : : void
10553 : 212098 : gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
10554 : : {
10555 : 212098 : const char *name;
10556 : 212098 : int lib, kind;
10557 : 212098 : tree fndecl;
10558 : :
10559 : 212098 : name = &expr->value.function.name[2];
10560 : :
10561 : 212098 : if (expr->rank > 0)
10562 : : {
10563 : 29409 : lib = gfc_is_intrinsic_libcall (expr);
10564 : 29409 : if (lib != 0)
10565 : : {
10566 : 14868 : if (lib == 1)
10567 : 9381 : se->ignore_optional = 1;
10568 : :
10569 : 14868 : switch (expr->value.function.isym->id)
10570 : : {
10571 : 3990 : case GFC_ISYM_EOSHIFT:
10572 : 3990 : case GFC_ISYM_PACK:
10573 : 3990 : case GFC_ISYM_RESHAPE:
10574 : : /* For all of those the first argument specifies the type and the
10575 : : third is optional. */
10576 : 3990 : conv_generic_with_optional_char_arg (se, expr, 1, 3);
10577 : 3990 : break;
10578 : :
10579 : 1068 : case GFC_ISYM_FINDLOC:
10580 : 1068 : gfc_conv_intrinsic_findloc (se, expr);
10581 : 1068 : break;
10582 : :
10583 : 2118 : case GFC_ISYM_MINLOC:
10584 : 2118 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
10585 : 2118 : break;
10586 : :
10587 : 1100 : case GFC_ISYM_MAXLOC:
10588 : 1100 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
10589 : 1100 : break;
10590 : :
10591 : 6592 : default:
10592 : 6592 : gfc_conv_intrinsic_funcall (se, expr);
10593 : 6592 : break;
10594 : : }
10595 : :
10596 : 14868 : return;
10597 : : }
10598 : : }
10599 : :
10600 : 197230 : switch (expr->value.function.isym->id)
10601 : : {
10602 : 0 : case GFC_ISYM_NONE:
10603 : 0 : gcc_unreachable ();
10604 : :
10605 : 499 : case GFC_ISYM_REPEAT:
10606 : 499 : gfc_conv_intrinsic_repeat (se, expr);
10607 : 499 : break;
10608 : :
10609 : 569 : case GFC_ISYM_TRIM:
10610 : 569 : gfc_conv_intrinsic_trim (se, expr);
10611 : 569 : break;
10612 : :
10613 : 42 : case GFC_ISYM_SC_KIND:
10614 : 42 : gfc_conv_intrinsic_sc_kind (se, expr);
10615 : 42 : break;
10616 : :
10617 : 45 : case GFC_ISYM_SI_KIND:
10618 : 45 : gfc_conv_intrinsic_si_kind (se, expr);
10619 : 45 : break;
10620 : :
10621 : 82 : case GFC_ISYM_SR_KIND:
10622 : 82 : gfc_conv_intrinsic_sr_kind (se, expr);
10623 : 82 : break;
10624 : :
10625 : 228 : case GFC_ISYM_EXPONENT:
10626 : 228 : gfc_conv_intrinsic_exponent (se, expr);
10627 : 228 : break;
10628 : :
10629 : 316 : case GFC_ISYM_SCAN:
10630 : 316 : kind = expr->value.function.actual->expr->ts.kind;
10631 : 316 : if (kind == 1)
10632 : 250 : fndecl = gfor_fndecl_string_scan;
10633 : 66 : else if (kind == 4)
10634 : 66 : fndecl = gfor_fndecl_string_scan_char4;
10635 : : else
10636 : 0 : gcc_unreachable ();
10637 : :
10638 : 316 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
10639 : 316 : break;
10640 : :
10641 : 94 : case GFC_ISYM_VERIFY:
10642 : 94 : kind = expr->value.function.actual->expr->ts.kind;
10643 : 94 : if (kind == 1)
10644 : 70 : fndecl = gfor_fndecl_string_verify;
10645 : 24 : else if (kind == 4)
10646 : 24 : fndecl = gfor_fndecl_string_verify_char4;
10647 : : else
10648 : 0 : gcc_unreachable ();
10649 : :
10650 : 94 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
10651 : 94 : break;
10652 : :
10653 : 6651 : case GFC_ISYM_ALLOCATED:
10654 : 6651 : gfc_conv_allocated (se, expr);
10655 : 6651 : break;
10656 : :
10657 : 7886 : case GFC_ISYM_ASSOCIATED:
10658 : 7886 : gfc_conv_associated(se, expr);
10659 : 7886 : break;
10660 : :
10661 : 397 : case GFC_ISYM_SAME_TYPE_AS:
10662 : 397 : gfc_conv_same_type_as (se, expr);
10663 : 397 : break;
10664 : :
10665 : 7598 : case GFC_ISYM_ABS:
10666 : 7598 : gfc_conv_intrinsic_abs (se, expr);
10667 : 7598 : break;
10668 : :
10669 : 344 : case GFC_ISYM_ADJUSTL:
10670 : 344 : if (expr->ts.kind == 1)
10671 : 290 : fndecl = gfor_fndecl_adjustl;
10672 : 54 : else if (expr->ts.kind == 4)
10673 : 54 : fndecl = gfor_fndecl_adjustl_char4;
10674 : : else
10675 : 0 : gcc_unreachable ();
10676 : :
10677 : 344 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
10678 : 344 : break;
10679 : :
10680 : 111 : case GFC_ISYM_ADJUSTR:
10681 : 111 : if (expr->ts.kind == 1)
10682 : 56 : fndecl = gfor_fndecl_adjustr;
10683 : 55 : else if (expr->ts.kind == 4)
10684 : 55 : fndecl = gfor_fndecl_adjustr_char4;
10685 : : else
10686 : 0 : gcc_unreachable ();
10687 : :
10688 : 111 : gfc_conv_intrinsic_adjust (se, expr, fndecl);
10689 : 111 : break;
10690 : :
10691 : 432 : case GFC_ISYM_AIMAG:
10692 : 432 : gfc_conv_intrinsic_imagpart (se, expr);
10693 : 432 : break;
10694 : :
10695 : 146 : case GFC_ISYM_AINT:
10696 : 146 : gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
10697 : 146 : break;
10698 : :
10699 : 441 : case GFC_ISYM_ALL:
10700 : 441 : gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
10701 : 441 : break;
10702 : :
10703 : 74 : case GFC_ISYM_ANINT:
10704 : 74 : gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
10705 : 74 : break;
10706 : :
10707 : 90 : case GFC_ISYM_AND:
10708 : 90 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
10709 : 90 : break;
10710 : :
10711 : 28979 : case GFC_ISYM_ANY:
10712 : 28979 : gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
10713 : 28979 : break;
10714 : :
10715 : 216 : case GFC_ISYM_ACOSD:
10716 : 216 : case GFC_ISYM_ASIND:
10717 : 216 : case GFC_ISYM_ATAND:
10718 : 216 : gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id);
10719 : 216 : break;
10720 : :
10721 : 102 : case GFC_ISYM_COTAN:
10722 : 102 : gfc_conv_intrinsic_cotan (se, expr);
10723 : 102 : break;
10724 : :
10725 : 108 : case GFC_ISYM_COTAND:
10726 : 108 : gfc_conv_intrinsic_cotand (se, expr);
10727 : 108 : break;
10728 : :
10729 : 72 : case GFC_ISYM_ATAN2D:
10730 : 72 : gfc_conv_intrinsic_atan2d (se, expr);
10731 : 72 : break;
10732 : :
10733 : 138 : case GFC_ISYM_BTEST:
10734 : 138 : gfc_conv_intrinsic_btest (se, expr);
10735 : 138 : break;
10736 : :
10737 : 42 : case GFC_ISYM_BGE:
10738 : 42 : gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
10739 : 42 : break;
10740 : :
10741 : 42 : case GFC_ISYM_BGT:
10742 : 42 : gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
10743 : 42 : break;
10744 : :
10745 : 42 : case GFC_ISYM_BLE:
10746 : 42 : gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
10747 : 42 : break;
10748 : :
10749 : 42 : case GFC_ISYM_BLT:
10750 : 42 : gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
10751 : 42 : break;
10752 : :
10753 : 7682 : case GFC_ISYM_C_ASSOCIATED:
10754 : 7682 : case GFC_ISYM_C_FUNLOC:
10755 : 7682 : case GFC_ISYM_C_LOC:
10756 : 7682 : conv_isocbinding_function (se, expr);
10757 : 7682 : break;
10758 : :
10759 : 2019 : case GFC_ISYM_ACHAR:
10760 : 2019 : case GFC_ISYM_CHAR:
10761 : 2019 : gfc_conv_intrinsic_char (se, expr);
10762 : 2019 : break;
10763 : :
10764 : 31503 : case GFC_ISYM_CONVERSION:
10765 : 31503 : case GFC_ISYM_DBLE:
10766 : 31503 : case GFC_ISYM_DFLOAT:
10767 : 31503 : case GFC_ISYM_FLOAT:
10768 : 31503 : case GFC_ISYM_LOGICAL:
10769 : 31503 : case GFC_ISYM_REAL:
10770 : 31503 : case GFC_ISYM_REALPART:
10771 : 31503 : case GFC_ISYM_SNGL:
10772 : 31503 : gfc_conv_intrinsic_conversion (se, expr);
10773 : 31503 : break;
10774 : :
10775 : : /* Integer conversions are handled separately to make sure we get the
10776 : : correct rounding mode. */
10777 : 2263 : case GFC_ISYM_INT:
10778 : 2263 : case GFC_ISYM_INT2:
10779 : 2263 : case GFC_ISYM_INT8:
10780 : 2263 : case GFC_ISYM_LONG:
10781 : 2263 : gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
10782 : 2263 : break;
10783 : :
10784 : 161 : case GFC_ISYM_NINT:
10785 : 161 : gfc_conv_intrinsic_int (se, expr, RND_ROUND);
10786 : 161 : break;
10787 : :
10788 : 16 : case GFC_ISYM_CEILING:
10789 : 16 : gfc_conv_intrinsic_int (se, expr, RND_CEIL);
10790 : 16 : break;
10791 : :
10792 : 116 : case GFC_ISYM_FLOOR:
10793 : 116 : gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
10794 : 116 : break;
10795 : :
10796 : 2487 : case GFC_ISYM_MOD:
10797 : 2487 : gfc_conv_intrinsic_mod (se, expr, 0);
10798 : 2487 : break;
10799 : :
10800 : 453 : case GFC_ISYM_MODULO:
10801 : 453 : gfc_conv_intrinsic_mod (se, expr, 1);
10802 : 453 : break;
10803 : :
10804 : 642 : case GFC_ISYM_CAF_GET:
10805 : 642 : gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE,
10806 : : false, NULL);
10807 : 642 : break;
10808 : :
10809 : 409 : case GFC_ISYM_CMPLX:
10810 : 409 : gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
10811 : 409 : break;
10812 : :
10813 : 10 : case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
10814 : 10 : gfc_conv_intrinsic_iargc (se, expr);
10815 : 10 : break;
10816 : :
10817 : 6 : case GFC_ISYM_COMPLEX:
10818 : 6 : gfc_conv_intrinsic_cmplx (se, expr, 1);
10819 : 6 : break;
10820 : :
10821 : 255 : case GFC_ISYM_CONJG:
10822 : 255 : gfc_conv_intrinsic_conjg (se, expr);
10823 : 255 : break;
10824 : :
10825 : 142 : case GFC_ISYM_COUNT:
10826 : 142 : gfc_conv_intrinsic_count (se, expr);
10827 : 142 : break;
10828 : :
10829 : 0 : case GFC_ISYM_CTIME:
10830 : 0 : gfc_conv_intrinsic_ctime (se, expr);
10831 : 0 : break;
10832 : :
10833 : 96 : case GFC_ISYM_DIM:
10834 : 96 : gfc_conv_intrinsic_dim (se, expr);
10835 : 96 : break;
10836 : :
10837 : 111 : case GFC_ISYM_DOT_PRODUCT:
10838 : 111 : gfc_conv_intrinsic_dot_product (se, expr);
10839 : 111 : break;
10840 : :
10841 : 13 : case GFC_ISYM_DPROD:
10842 : 13 : gfc_conv_intrinsic_dprod (se, expr);
10843 : 13 : break;
10844 : :
10845 : 30 : case GFC_ISYM_DSHIFTL:
10846 : 30 : gfc_conv_intrinsic_dshift (se, expr, true);
10847 : 30 : break;
10848 : :
10849 : 30 : case GFC_ISYM_DSHIFTR:
10850 : 30 : gfc_conv_intrinsic_dshift (se, expr, false);
10851 : 30 : break;
10852 : :
10853 : 0 : case GFC_ISYM_FDATE:
10854 : 0 : gfc_conv_intrinsic_fdate (se, expr);
10855 : 0 : break;
10856 : :
10857 : 60 : case GFC_ISYM_FRACTION:
10858 : 60 : gfc_conv_intrinsic_fraction (se, expr);
10859 : 60 : break;
10860 : :
10861 : 18 : case GFC_ISYM_IALL:
10862 : 18 : gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
10863 : 18 : break;
10864 : :
10865 : 592 : case GFC_ISYM_IAND:
10866 : 592 : gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
10867 : 592 : break;
10868 : :
10869 : 6 : case GFC_ISYM_IANY:
10870 : 6 : gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
10871 : 6 : break;
10872 : :
10873 : 156 : case GFC_ISYM_IBCLR:
10874 : 156 : gfc_conv_intrinsic_singlebitop (se, expr, 0);
10875 : 156 : break;
10876 : :
10877 : 27 : case GFC_ISYM_IBITS:
10878 : 27 : gfc_conv_intrinsic_ibits (se, expr);
10879 : 27 : break;
10880 : :
10881 : 126 : case GFC_ISYM_IBSET:
10882 : 126 : gfc_conv_intrinsic_singlebitop (se, expr, 1);
10883 : 126 : break;
10884 : :
10885 : 1971 : case GFC_ISYM_IACHAR:
10886 : 1971 : case GFC_ISYM_ICHAR:
10887 : : /* We assume ASCII character sequence. */
10888 : 1971 : gfc_conv_intrinsic_ichar (se, expr);
10889 : 1971 : break;
10890 : :
10891 : 2 : case GFC_ISYM_IARGC:
10892 : 2 : gfc_conv_intrinsic_iargc (se, expr);
10893 : 2 : break;
10894 : :
10895 : 662 : case GFC_ISYM_IEOR:
10896 : 662 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
10897 : 662 : break;
10898 : :
10899 : 328 : case GFC_ISYM_INDEX:
10900 : 328 : kind = expr->value.function.actual->expr->ts.kind;
10901 : 328 : if (kind == 1)
10902 : 262 : fndecl = gfor_fndecl_string_index;
10903 : 66 : else if (kind == 4)
10904 : 66 : fndecl = gfor_fndecl_string_index_char4;
10905 : : else
10906 : 0 : gcc_unreachable ();
10907 : :
10908 : 328 : gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
10909 : 328 : break;
10910 : :
10911 : 475 : case GFC_ISYM_IOR:
10912 : 475 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
10913 : 475 : break;
10914 : :
10915 : 6 : case GFC_ISYM_IPARITY:
10916 : 6 : gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
10917 : 6 : break;
10918 : :
10919 : 6 : case GFC_ISYM_IS_IOSTAT_END:
10920 : 6 : gfc_conv_has_intvalue (se, expr, LIBERROR_END);
10921 : 6 : break;
10922 : :
10923 : 18 : case GFC_ISYM_IS_IOSTAT_EOR:
10924 : 18 : gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
10925 : 18 : break;
10926 : :
10927 : 621 : case GFC_ISYM_IS_CONTIGUOUS:
10928 : 621 : gfc_conv_intrinsic_is_contiguous (se, expr);
10929 : 621 : break;
10930 : :
10931 : 432 : case GFC_ISYM_ISNAN:
10932 : 432 : gfc_conv_intrinsic_isnan (se, expr);
10933 : 432 : break;
10934 : :
10935 : 8 : case GFC_ISYM_KILL:
10936 : 8 : conv_intrinsic_kill (se, expr);
10937 : 8 : break;
10938 : :
10939 : 90 : case GFC_ISYM_LSHIFT:
10940 : 90 : gfc_conv_intrinsic_shift (se, expr, false, false);
10941 : 90 : break;
10942 : :
10943 : 24 : case GFC_ISYM_RSHIFT:
10944 : 24 : gfc_conv_intrinsic_shift (se, expr, true, true);
10945 : 24 : break;
10946 : :
10947 : 48 : case GFC_ISYM_SHIFTA:
10948 : 48 : gfc_conv_intrinsic_shift (se, expr, true, true);
10949 : 48 : break;
10950 : :
10951 : 147 : case GFC_ISYM_SHIFTL:
10952 : 147 : gfc_conv_intrinsic_shift (se, expr, false, false);
10953 : 147 : break;
10954 : :
10955 : 42 : case GFC_ISYM_SHIFTR:
10956 : 42 : gfc_conv_intrinsic_shift (se, expr, true, false);
10957 : 42 : break;
10958 : :
10959 : 252 : case GFC_ISYM_ISHFT:
10960 : 252 : gfc_conv_intrinsic_ishft (se, expr);
10961 : 252 : break;
10962 : :
10963 : 622 : case GFC_ISYM_ISHFTC:
10964 : 622 : gfc_conv_intrinsic_ishftc (se, expr);
10965 : 622 : break;
10966 : :
10967 : 270 : case GFC_ISYM_LEADZ:
10968 : 270 : gfc_conv_intrinsic_leadz (se, expr);
10969 : 270 : break;
10970 : :
10971 : 282 : case GFC_ISYM_TRAILZ:
10972 : 282 : gfc_conv_intrinsic_trailz (se, expr);
10973 : 282 : break;
10974 : :
10975 : 103 : case GFC_ISYM_POPCNT:
10976 : 103 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
10977 : 103 : break;
10978 : :
10979 : 31 : case GFC_ISYM_POPPAR:
10980 : 31 : gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
10981 : 31 : break;
10982 : :
10983 : 5487 : case GFC_ISYM_LBOUND:
10984 : 5487 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
10985 : 5487 : break;
10986 : :
10987 : 176 : case GFC_ISYM_LCOBOUND:
10988 : 176 : conv_intrinsic_cobound (se, expr);
10989 : 176 : break;
10990 : :
10991 : 744 : case GFC_ISYM_TRANSPOSE:
10992 : : /* The scalarizer has already been set up for reversed dimension access
10993 : : order ; now we just get the argument value normally. */
10994 : 744 : gfc_conv_expr (se, expr->value.function.actual->expr);
10995 : 744 : break;
10996 : :
10997 : 5228 : case GFC_ISYM_LEN:
10998 : 5228 : gfc_conv_intrinsic_len (se, expr);
10999 : 5228 : break;
11000 : :
11001 : 2273 : case GFC_ISYM_LEN_TRIM:
11002 : 2273 : gfc_conv_intrinsic_len_trim (se, expr);
11003 : 2273 : break;
11004 : :
11005 : 18 : case GFC_ISYM_LGE:
11006 : 18 : gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
11007 : 18 : break;
11008 : :
11009 : 36 : case GFC_ISYM_LGT:
11010 : 36 : gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
11011 : 36 : break;
11012 : :
11013 : 18 : case GFC_ISYM_LLE:
11014 : 18 : gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
11015 : 18 : break;
11016 : :
11017 : 27 : case GFC_ISYM_LLT:
11018 : 27 : gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
11019 : 27 : break;
11020 : :
11021 : 16 : case GFC_ISYM_MALLOC:
11022 : 16 : gfc_conv_intrinsic_malloc (se, expr);
11023 : 16 : break;
11024 : :
11025 : 32 : case GFC_ISYM_MASKL:
11026 : 32 : gfc_conv_intrinsic_mask (se, expr, 1);
11027 : 32 : break;
11028 : :
11029 : 32 : case GFC_ISYM_MASKR:
11030 : 32 : gfc_conv_intrinsic_mask (se, expr, 0);
11031 : 32 : break;
11032 : :
11033 : 998 : case GFC_ISYM_MAX:
11034 : 998 : if (expr->ts.type == BT_CHARACTER)
11035 : 138 : gfc_conv_intrinsic_minmax_char (se, expr, 1);
11036 : : else
11037 : 860 : gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
11038 : : break;
11039 : :
11040 : 1910 : case GFC_ISYM_MAXLOC:
11041 : 1910 : gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
11042 : 1910 : break;
11043 : :
11044 : 156 : case GFC_ISYM_FINDLOC:
11045 : 156 : gfc_conv_intrinsic_findloc (se, expr);
11046 : 156 : break;
11047 : :
11048 : 1009 : case GFC_ISYM_MAXVAL:
11049 : 1009 : gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
11050 : 1009 : break;
11051 : :
11052 : 917 : case GFC_ISYM_MERGE:
11053 : 917 : gfc_conv_intrinsic_merge (se, expr);
11054 : 917 : break;
11055 : :
11056 : 30 : case GFC_ISYM_MERGE_BITS:
11057 : 30 : gfc_conv_intrinsic_merge_bits (se, expr);
11058 : 30 : break;
11059 : :
11060 : 541 : case GFC_ISYM_MIN:
11061 : 541 : if (expr->ts.type == BT_CHARACTER)
11062 : 144 : gfc_conv_intrinsic_minmax_char (se, expr, -1);
11063 : : else
11064 : 397 : gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
11065 : : break;
11066 : :
11067 : 2300 : case GFC_ISYM_MINLOC:
11068 : 2300 : gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
11069 : 2300 : break;
11070 : :
11071 : 1304 : case GFC_ISYM_MINVAL:
11072 : 1304 : gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
11073 : 1304 : break;
11074 : :
11075 : 1610 : case GFC_ISYM_NEAREST:
11076 : 1610 : gfc_conv_intrinsic_nearest (se, expr);
11077 : 1610 : break;
11078 : :
11079 : 68 : case GFC_ISYM_NORM2:
11080 : 68 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
11081 : 68 : break;
11082 : :
11083 : 222 : case GFC_ISYM_NOT:
11084 : 222 : gfc_conv_intrinsic_not (se, expr);
11085 : 222 : break;
11086 : :
11087 : 12 : case GFC_ISYM_OR:
11088 : 12 : gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
11089 : 12 : break;
11090 : :
11091 : 36 : case GFC_ISYM_PARITY:
11092 : 36 : gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
11093 : 36 : break;
11094 : :
11095 : 4729 : case GFC_ISYM_PRESENT:
11096 : 4729 : gfc_conv_intrinsic_present (se, expr);
11097 : 4729 : break;
11098 : :
11099 : 338 : case GFC_ISYM_PRODUCT:
11100 : 338 : gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
11101 : 338 : break;
11102 : :
11103 : 9726 : case GFC_ISYM_RANK:
11104 : 9726 : gfc_conv_intrinsic_rank (se, expr);
11105 : 9726 : break;
11106 : :
11107 : 48 : case GFC_ISYM_RRSPACING:
11108 : 48 : gfc_conv_intrinsic_rrspacing (se, expr);
11109 : 48 : break;
11110 : :
11111 : 262 : case GFC_ISYM_SET_EXPONENT:
11112 : 262 : gfc_conv_intrinsic_set_exponent (se, expr);
11113 : 262 : break;
11114 : :
11115 : 72 : case GFC_ISYM_SCALE:
11116 : 72 : gfc_conv_intrinsic_scale (se, expr);
11117 : 72 : break;
11118 : :
11119 : 1989 : case GFC_ISYM_SHAPE:
11120 : 1989 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
11121 : 1989 : break;
11122 : :
11123 : 424 : case GFC_ISYM_SIGN:
11124 : 424 : gfc_conv_intrinsic_sign (se, expr);
11125 : 424 : break;
11126 : :
11127 : 13312 : case GFC_ISYM_SIZE:
11128 : 13312 : gfc_conv_intrinsic_size (se, expr);
11129 : 13312 : break;
11130 : :
11131 : 1268 : case GFC_ISYM_SIZEOF:
11132 : 1268 : case GFC_ISYM_C_SIZEOF:
11133 : 1268 : gfc_conv_intrinsic_sizeof (se, expr);
11134 : 1268 : break;
11135 : :
11136 : 700 : case GFC_ISYM_STORAGE_SIZE:
11137 : 700 : gfc_conv_intrinsic_storage_size (se, expr);
11138 : 700 : break;
11139 : :
11140 : 70 : case GFC_ISYM_SPACING:
11141 : 70 : gfc_conv_intrinsic_spacing (se, expr);
11142 : 70 : break;
11143 : :
11144 : 1733 : case GFC_ISYM_STRIDE:
11145 : 1733 : conv_intrinsic_stride (se, expr);
11146 : 1733 : break;
11147 : :
11148 : 1838 : case GFC_ISYM_SUM:
11149 : 1838 : gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
11150 : 1838 : break;
11151 : :
11152 : 31 : case GFC_ISYM_TEAM_NUMBER:
11153 : 31 : conv_intrinsic_team_number (se, expr);
11154 : 31 : break;
11155 : :
11156 : 3366 : case GFC_ISYM_TRANSFER:
11157 : 3366 : if (se->ss && se->ss->info->useflags)
11158 : : /* Access the previously obtained result. */
11159 : 265 : gfc_conv_tmp_array_ref (se);
11160 : : else
11161 : 3101 : gfc_conv_intrinsic_transfer (se, expr);
11162 : : break;
11163 : :
11164 : 0 : case GFC_ISYM_TTYNAM:
11165 : 0 : gfc_conv_intrinsic_ttynam (se, expr);
11166 : 0 : break;
11167 : :
11168 : 5500 : case GFC_ISYM_UBOUND:
11169 : 5500 : gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
11170 : 5500 : break;
11171 : :
11172 : 185 : case GFC_ISYM_UCOBOUND:
11173 : 185 : conv_intrinsic_cobound (se, expr);
11174 : 185 : break;
11175 : :
11176 : 18 : case GFC_ISYM_XOR:
11177 : 18 : gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
11178 : 18 : break;
11179 : :
11180 : 8251 : case GFC_ISYM_LOC:
11181 : 8251 : gfc_conv_intrinsic_loc (se, expr);
11182 : 8251 : break;
11183 : :
11184 : 845 : case GFC_ISYM_THIS_IMAGE:
11185 : : /* For num_images() == 1, handle as LCOBOUND. */
11186 : 845 : if (expr->value.function.actual->expr
11187 : 353 : && flag_coarray == GFC_FCOARRAY_SINGLE)
11188 : 208 : conv_intrinsic_cobound (se, expr);
11189 : : else
11190 : 637 : trans_this_image (se, expr);
11191 : : break;
11192 : :
11193 : 152 : case GFC_ISYM_IMAGE_INDEX:
11194 : 152 : trans_image_index (se, expr);
11195 : 152 : break;
11196 : :
11197 : 16 : case GFC_ISYM_IMAGE_STATUS:
11198 : 16 : conv_intrinsic_image_status (se, expr);
11199 : 16 : break;
11200 : :
11201 : 395 : case GFC_ISYM_NUM_IMAGES:
11202 : 395 : trans_num_images (se, expr);
11203 : 395 : break;
11204 : :
11205 : 1212 : case GFC_ISYM_ACCESS:
11206 : 1212 : case GFC_ISYM_CHDIR:
11207 : 1212 : case GFC_ISYM_CHMOD:
11208 : 1212 : case GFC_ISYM_DTIME:
11209 : 1212 : case GFC_ISYM_ETIME:
11210 : 1212 : case GFC_ISYM_EXTENDS_TYPE_OF:
11211 : 1212 : case GFC_ISYM_FGET:
11212 : 1212 : case GFC_ISYM_FGETC:
11213 : 1212 : case GFC_ISYM_FNUM:
11214 : 1212 : case GFC_ISYM_FPUT:
11215 : 1212 : case GFC_ISYM_FPUTC:
11216 : 1212 : case GFC_ISYM_FSTAT:
11217 : 1212 : case GFC_ISYM_FTELL:
11218 : 1212 : case GFC_ISYM_GETCWD:
11219 : 1212 : case GFC_ISYM_GETGID:
11220 : 1212 : case GFC_ISYM_GETPID:
11221 : 1212 : case GFC_ISYM_GETUID:
11222 : 1212 : case GFC_ISYM_HOSTNM:
11223 : 1212 : case GFC_ISYM_IERRNO:
11224 : 1212 : case GFC_ISYM_IRAND:
11225 : 1212 : case GFC_ISYM_ISATTY:
11226 : 1212 : case GFC_ISYM_JN2:
11227 : 1212 : case GFC_ISYM_LINK:
11228 : 1212 : case GFC_ISYM_LSTAT:
11229 : 1212 : case GFC_ISYM_MATMUL:
11230 : 1212 : case GFC_ISYM_MCLOCK:
11231 : 1212 : case GFC_ISYM_MCLOCK8:
11232 : 1212 : case GFC_ISYM_RAND:
11233 : 1212 : case GFC_ISYM_RENAME:
11234 : 1212 : case GFC_ISYM_SECOND:
11235 : 1212 : case GFC_ISYM_SECNDS:
11236 : 1212 : case GFC_ISYM_SIGNAL:
11237 : 1212 : case GFC_ISYM_STAT:
11238 : 1212 : case GFC_ISYM_SYMLNK:
11239 : 1212 : case GFC_ISYM_SYSTEM:
11240 : 1212 : case GFC_ISYM_TIME:
11241 : 1212 : case GFC_ISYM_TIME8:
11242 : 1212 : case GFC_ISYM_UMASK:
11243 : 1212 : case GFC_ISYM_UNLINK:
11244 : 1212 : case GFC_ISYM_YN2:
11245 : 1212 : gfc_conv_intrinsic_funcall (se, expr);
11246 : 1212 : break;
11247 : :
11248 : 0 : case GFC_ISYM_EOSHIFT:
11249 : 0 : case GFC_ISYM_PACK:
11250 : 0 : case GFC_ISYM_RESHAPE:
11251 : : /* For those, expr->rank should always be >0 and thus the if above the
11252 : : switch should have matched. */
11253 : 0 : gcc_unreachable ();
11254 : 3853 : break;
11255 : :
11256 : 3853 : default:
11257 : 3853 : gfc_conv_intrinsic_lib_function (se, expr);
11258 : 3853 : break;
11259 : : }
11260 : : }
11261 : :
11262 : :
11263 : : static gfc_ss *
11264 : 1598 : walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
11265 : : {
11266 : 1598 : gfc_ss *arg_ss, *tmp_ss;
11267 : 1598 : gfc_actual_arglist *arg;
11268 : :
11269 : 1598 : arg = expr->value.function.actual;
11270 : :
11271 : 1598 : gcc_assert (arg->expr);
11272 : :
11273 : 1598 : arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
11274 : 1598 : gcc_assert (arg_ss != gfc_ss_terminator);
11275 : :
11276 : : for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
11277 : : {
11278 : 1703 : if (tmp_ss->info->type != GFC_SS_SCALAR
11279 : : && tmp_ss->info->type != GFC_SS_REFERENCE)
11280 : : {
11281 : 1666 : gcc_assert (tmp_ss->dimen == 2);
11282 : :
11283 : : /* We just invert dimensions. */
11284 : 1666 : std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
11285 : : }
11286 : :
11287 : : /* Stop when tmp_ss points to the last valid element of the chain... */
11288 : 1703 : if (tmp_ss->next == gfc_ss_terminator)
11289 : : break;
11290 : : }
11291 : :
11292 : : /* ... so that we can attach the rest of the chain to it. */
11293 : 1598 : tmp_ss->next = ss;
11294 : :
11295 : 1598 : return arg_ss;
11296 : : }
11297 : :
11298 : :
11299 : : /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
11300 : : This has the side effect of reversing the nested list, so there is no
11301 : : need to call gfc_reverse_ss on it (the given list is assumed not to be
11302 : : reversed yet). */
11303 : :
11304 : : static gfc_ss *
11305 : 560 : nest_loop_dimension (gfc_ss *ss, int dim)
11306 : : {
11307 : 560 : int ss_dim, i;
11308 : 560 : gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
11309 : 560 : gfc_loopinfo *new_loop;
11310 : :
11311 : 560 : gcc_assert (ss != gfc_ss_terminator);
11312 : :
11313 : 1304 : for (; ss != gfc_ss_terminator; ss = ss->next)
11314 : : {
11315 : 744 : new_ss = gfc_get_ss ();
11316 : 744 : new_ss->next = prev_ss;
11317 : 744 : new_ss->parent = ss;
11318 : 744 : new_ss->info = ss->info;
11319 : 744 : new_ss->info->refcount++;
11320 : 744 : if (ss->dimen != 0)
11321 : : {
11322 : 685 : gcc_assert (ss->info->type != GFC_SS_SCALAR
11323 : : && ss->info->type != GFC_SS_REFERENCE);
11324 : :
11325 : 685 : new_ss->dimen = 1;
11326 : 685 : new_ss->dim[0] = ss->dim[dim];
11327 : :
11328 : 685 : gcc_assert (dim < ss->dimen);
11329 : :
11330 : 685 : ss_dim = --ss->dimen;
11331 : 1163 : for (i = dim; i < ss_dim; i++)
11332 : 478 : ss->dim[i] = ss->dim[i + 1];
11333 : :
11334 : 685 : ss->dim[ss_dim] = 0;
11335 : : }
11336 : 744 : prev_ss = new_ss;
11337 : :
11338 : 744 : if (ss->nested_ss)
11339 : : {
11340 : 81 : ss->nested_ss->parent = new_ss;
11341 : 81 : new_ss->nested_ss = ss->nested_ss;
11342 : : }
11343 : 744 : ss->nested_ss = new_ss;
11344 : : }
11345 : :
11346 : 560 : new_loop = gfc_get_loopinfo ();
11347 : 560 : gfc_init_loopinfo (new_loop);
11348 : :
11349 : 560 : gcc_assert (prev_ss != NULL);
11350 : 560 : gcc_assert (prev_ss != gfc_ss_terminator);
11351 : 560 : gfc_add_ss_to_loop (new_loop, prev_ss);
11352 : 560 : return new_ss->parent;
11353 : : }
11354 : :
11355 : :
11356 : : /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
11357 : : is to be inlined. */
11358 : :
11359 : : static gfc_ss *
11360 : 560 : walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
11361 : : {
11362 : 560 : gfc_ss *tmp_ss, *tail, *array_ss;
11363 : 560 : gfc_actual_arglist *arg1, *arg2, *arg3;
11364 : 560 : int sum_dim;
11365 : 560 : bool scalar_mask = false;
11366 : :
11367 : : /* The rank of the result will be determined later. */
11368 : 560 : arg1 = expr->value.function.actual;
11369 : 560 : arg2 = arg1->next;
11370 : 560 : arg3 = arg2->next;
11371 : 560 : gcc_assert (arg3 != NULL);
11372 : :
11373 : 560 : if (expr->rank == 0)
11374 : : return ss;
11375 : :
11376 : 560 : tmp_ss = gfc_ss_terminator;
11377 : :
11378 : 560 : if (arg3->expr)
11379 : : {
11380 : 118 : gfc_ss *mask_ss;
11381 : :
11382 : 118 : mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
11383 : 118 : if (mask_ss == tmp_ss)
11384 : 34 : scalar_mask = 1;
11385 : :
11386 : : tmp_ss = mask_ss;
11387 : : }
11388 : :
11389 : 560 : array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
11390 : 560 : gcc_assert (array_ss != tmp_ss);
11391 : :
11392 : : /* Odd thing: If the mask is scalar, it is used by the frontend after
11393 : : the array (to make an if around the nested loop). Thus it shall
11394 : : be after array_ss once the gfc_ss list is reversed. */
11395 : 560 : if (scalar_mask)
11396 : 34 : tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
11397 : : else
11398 : : tmp_ss = array_ss;
11399 : :
11400 : : /* "Hide" the dimension on which we will sum in the first arg's scalarization
11401 : : chain. */
11402 : 560 : sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
11403 : 560 : tail = nest_loop_dimension (tmp_ss, sum_dim);
11404 : 560 : tail->next = ss;
11405 : :
11406 : 560 : return tmp_ss;
11407 : : }
11408 : :
11409 : :
11410 : : static gfc_ss *
11411 : 2158 : walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
11412 : : {
11413 : :
11414 : 2158 : switch (expr->value.function.isym->id)
11415 : : {
11416 : 560 : case GFC_ISYM_PRODUCT:
11417 : 560 : case GFC_ISYM_SUM:
11418 : 560 : return walk_inline_intrinsic_arith (ss, expr);
11419 : :
11420 : 1598 : case GFC_ISYM_TRANSPOSE:
11421 : 1598 : return walk_inline_intrinsic_transpose (ss, expr);
11422 : :
11423 : 0 : default:
11424 : 0 : gcc_unreachable ();
11425 : : }
11426 : : gcc_unreachable ();
11427 : : }
11428 : :
11429 : :
11430 : : /* This generates code to execute before entering the scalarization loop.
11431 : : Currently does nothing. */
11432 : :
11433 : : void
11434 : 4970 : gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
11435 : : {
11436 : 4970 : switch (ss->info->expr->value.function.isym->id)
11437 : : {
11438 : 4970 : case GFC_ISYM_UBOUND:
11439 : 4970 : case GFC_ISYM_LBOUND:
11440 : 4970 : case GFC_ISYM_UCOBOUND:
11441 : 4970 : case GFC_ISYM_LCOBOUND:
11442 : 4970 : case GFC_ISYM_THIS_IMAGE:
11443 : 4970 : case GFC_ISYM_SHAPE:
11444 : 4970 : break;
11445 : :
11446 : 0 : default:
11447 : 0 : gcc_unreachable ();
11448 : : }
11449 : 4970 : }
11450 : :
11451 : :
11452 : : /* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
11453 : : one parameter are expanded into code inside the scalarization loop. */
11454 : :
11455 : : static gfc_ss *
11456 : 5518 : gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
11457 : : {
11458 : 5518 : if (expr->value.function.actual->expr->ts.type == BT_CLASS)
11459 : 314 : gfc_add_class_array_ref (expr->value.function.actual->expr);
11460 : :
11461 : : /* The two argument version returns a scalar. */
11462 : 5518 : if (expr->value.function.isym->id != GFC_ISYM_SHAPE
11463 : 3191 : && expr->value.function.actual->next->expr)
11464 : : return ss;
11465 : :
11466 : 5518 : return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
11467 : : }
11468 : :
11469 : :
11470 : : /* Walk an intrinsic array libcall. */
11471 : :
11472 : : static gfc_ss *
11473 : 10887 : gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
11474 : : {
11475 : 10887 : gcc_assert (expr->rank > 0);
11476 : 10887 : return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
11477 : : }
11478 : :
11479 : :
11480 : : /* Return whether the function call expression EXPR will be expanded
11481 : : inline by gfc_conv_intrinsic_function. */
11482 : :
11483 : : bool
11484 : 209314 : gfc_inline_intrinsic_function_p (gfc_expr *expr)
11485 : : {
11486 : 209314 : gfc_actual_arglist *args, *dim_arg, *mask_arg;
11487 : 209314 : gfc_expr *maskexpr;
11488 : :
11489 : 209314 : if (!expr->value.function.isym)
11490 : : return false;
11491 : :
11492 : 209278 : switch (expr->value.function.isym->id)
11493 : : {
11494 : 4797 : case GFC_ISYM_PRODUCT:
11495 : 4797 : case GFC_ISYM_SUM:
11496 : : /* Disable inline expansion if code size matters. */
11497 : 4797 : if (optimize_size)
11498 : : return false;
11499 : :
11500 : 4007 : args = expr->value.function.actual;
11501 : 4007 : dim_arg = args->next;
11502 : :
11503 : : /* We need to be able to subset the SUM argument at compile-time. */
11504 : 4007 : if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
11505 : : return false;
11506 : :
11507 : : /* FIXME: If MASK is optional for a more than two-dimensional
11508 : : argument, the scalarizer gets confused if the mask is
11509 : : absent. See PR 82995. For now, fall back to the library
11510 : : function. */
11511 : :
11512 : 3395 : mask_arg = dim_arg->next;
11513 : 3395 : maskexpr = mask_arg->expr;
11514 : :
11515 : 3395 : if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
11516 : 276 : && maskexpr->symtree->n.sym->attr.dummy
11517 : 276 : && maskexpr->symtree->n.sym->attr.optional)
11518 : : return false;
11519 : :
11520 : : return true;
11521 : :
11522 : : case GFC_ISYM_TRANSPOSE:
11523 : : return true;
11524 : :
11525 : : default:
11526 : : return false;
11527 : : }
11528 : : }
11529 : :
11530 : :
11531 : : /* Returns nonzero if the specified intrinsic function call maps directly to
11532 : : an external library call. Should only be used for functions that return
11533 : : arrays. */
11534 : :
11535 : : int
11536 : 52047 : gfc_is_intrinsic_libcall (gfc_expr * expr)
11537 : : {
11538 : 52047 : gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
11539 : 52047 : gcc_assert (expr->rank > 0);
11540 : :
11541 : 52047 : if (gfc_inline_intrinsic_function_p (expr))
11542 : : return 0;
11543 : :
11544 : 50389 : switch (expr->value.function.isym->id)
11545 : : {
11546 : : case GFC_ISYM_ALL:
11547 : : case GFC_ISYM_ANY:
11548 : : case GFC_ISYM_COUNT:
11549 : : case GFC_ISYM_FINDLOC:
11550 : : case GFC_ISYM_JN2:
11551 : : case GFC_ISYM_IANY:
11552 : : case GFC_ISYM_IALL:
11553 : : case GFC_ISYM_IPARITY:
11554 : : case GFC_ISYM_MATMUL:
11555 : : case GFC_ISYM_MAXLOC:
11556 : : case GFC_ISYM_MAXVAL:
11557 : : case GFC_ISYM_MINLOC:
11558 : : case GFC_ISYM_MINVAL:
11559 : : case GFC_ISYM_NORM2:
11560 : : case GFC_ISYM_PARITY:
11561 : : case GFC_ISYM_PRODUCT:
11562 : : case GFC_ISYM_SUM:
11563 : : case GFC_ISYM_SPREAD:
11564 : : case GFC_ISYM_YN2:
11565 : : /* Ignore absent optional parameters. */
11566 : : return 1;
11567 : :
11568 : 10707 : case GFC_ISYM_CSHIFT:
11569 : 10707 : case GFC_ISYM_EOSHIFT:
11570 : 10707 : case GFC_ISYM_GET_TEAM:
11571 : 10707 : case GFC_ISYM_FAILED_IMAGES:
11572 : 10707 : case GFC_ISYM_STOPPED_IMAGES:
11573 : 10707 : case GFC_ISYM_PACK:
11574 : 10707 : case GFC_ISYM_RESHAPE:
11575 : 10707 : case GFC_ISYM_UNPACK:
11576 : : /* Pass absent optional parameters. */
11577 : 10707 : return 2;
11578 : :
11579 : : default:
11580 : : return 0;
11581 : : }
11582 : : }
11583 : :
11584 : : /* Walk an intrinsic function. */
11585 : : gfc_ss *
11586 : 36070 : gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
11587 : : gfc_intrinsic_sym * isym)
11588 : : {
11589 : 36070 : gcc_assert (isym);
11590 : :
11591 : 36070 : if (isym->elemental)
11592 : 13180 : return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
11593 : : expr->value.function.isym,
11594 : 13180 : GFC_SS_SCALAR);
11595 : :
11596 : 22890 : if (expr->rank == 0)
11597 : : return ss;
11598 : :
11599 : 18563 : if (gfc_inline_intrinsic_function_p (expr))
11600 : 2158 : return walk_inline_intrinsic_function (ss, expr);
11601 : :
11602 : 16405 : if (gfc_is_intrinsic_libcall (expr))
11603 : 10053 : return gfc_walk_intrinsic_libfunc (ss, expr);
11604 : :
11605 : : /* Special cases. */
11606 : 6352 : switch (isym->id)
11607 : : {
11608 : 5518 : case GFC_ISYM_LBOUND:
11609 : 5518 : case GFC_ISYM_LCOBOUND:
11610 : 5518 : case GFC_ISYM_UBOUND:
11611 : 5518 : case GFC_ISYM_UCOBOUND:
11612 : 5518 : case GFC_ISYM_THIS_IMAGE:
11613 : 5518 : case GFC_ISYM_SHAPE:
11614 : 5518 : return gfc_walk_intrinsic_bound (ss, expr);
11615 : :
11616 : 834 : case GFC_ISYM_TRANSFER:
11617 : 834 : case GFC_ISYM_CAF_GET:
11618 : 834 : return gfc_walk_intrinsic_libfunc (ss, expr);
11619 : :
11620 : 0 : default:
11621 : : /* This probably meant someone forgot to add an intrinsic to the above
11622 : : list(s) when they implemented it, or something's gone horribly
11623 : : wrong. */
11624 : 0 : gcc_unreachable ();
11625 : : }
11626 : : }
11627 : :
11628 : : static tree
11629 : 63 : conv_co_collective (gfc_code *code)
11630 : : {
11631 : 63 : gfc_se argse;
11632 : 63 : stmtblock_t block, post_block;
11633 : 63 : tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
11634 : 63 : gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
11635 : :
11636 : 63 : gfc_start_block (&block);
11637 : 63 : gfc_init_block (&post_block);
11638 : :
11639 : 63 : if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
11640 : : {
11641 : 7 : opr_expr = code->ext.actual->next->expr;
11642 : 7 : image_idx_expr = code->ext.actual->next->next->expr;
11643 : 7 : stat_expr = code->ext.actual->next->next->next->expr;
11644 : 7 : errmsg_expr = code->ext.actual->next->next->next->next->expr;
11645 : : }
11646 : : else
11647 : : {
11648 : 56 : opr_expr = NULL;
11649 : 56 : image_idx_expr = code->ext.actual->next->expr;
11650 : 56 : stat_expr = code->ext.actual->next->next->expr;
11651 : 56 : errmsg_expr = code->ext.actual->next->next->next->expr;
11652 : : }
11653 : :
11654 : : /* stat. */
11655 : 63 : if (stat_expr)
11656 : : {
11657 : 49 : gfc_init_se (&argse, NULL);
11658 : 49 : gfc_conv_expr (&argse, stat_expr);
11659 : 49 : gfc_add_block_to_block (&block, &argse.pre);
11660 : 49 : gfc_add_block_to_block (&post_block, &argse.post);
11661 : 49 : stat = argse.expr;
11662 : 49 : if (flag_coarray != GFC_FCOARRAY_SINGLE)
11663 : 22 : stat = gfc_build_addr_expr (NULL_TREE, stat);
11664 : : }
11665 : 14 : else if (flag_coarray == GFC_FCOARRAY_SINGLE)
11666 : : stat = NULL_TREE;
11667 : : else
11668 : 8 : stat = null_pointer_node;
11669 : :
11670 : : /* Early exit for GFC_FCOARRAY_SINGLE. */
11671 : 63 : if (flag_coarray == GFC_FCOARRAY_SINGLE)
11672 : : {
11673 : 33 : if (stat != NULL_TREE)
11674 : : {
11675 : : /* For optional stats, check the pointer is valid before zero'ing. */
11676 : 27 : if (gfc_expr_attr (stat_expr).optional)
11677 : : {
11678 : 12 : tree tmp;
11679 : 12 : stmtblock_t ass_block;
11680 : 12 : gfc_start_block (&ass_block);
11681 : 12 : gfc_add_modify (&ass_block, stat,
11682 : 12 : fold_convert (TREE_TYPE (stat),
11683 : : integer_zero_node));
11684 : 12 : tmp = fold_build2 (NE_EXPR, logical_type_node,
11685 : : gfc_build_addr_expr (NULL_TREE, stat),
11686 : : null_pointer_node);
11687 : 12 : tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
11688 : : gfc_finish_block (&ass_block),
11689 : : build_empty_stmt (input_location));
11690 : 12 : gfc_add_expr_to_block (&block, tmp);
11691 : : }
11692 : : else
11693 : 15 : gfc_add_modify (&block, stat,
11694 : 15 : fold_convert (TREE_TYPE (stat), integer_zero_node));
11695 : : }
11696 : 33 : return gfc_finish_block (&block);
11697 : : }
11698 : :
11699 : 60 : gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
11700 : 30 : ? code->ext.actual->expr->ts.u.derived : NULL;
11701 : :
11702 : : /* Handle the array. */
11703 : 30 : gfc_init_se (&argse, NULL);
11704 : 30 : if (!derived || !derived->attr.alloc_comp
11705 : 1 : || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST)
11706 : : {
11707 : 29 : if (code->ext.actual->expr->rank == 0)
11708 : : {
11709 : 16 : symbol_attribute attr;
11710 : 16 : gfc_clear_attr (&attr);
11711 : 16 : gfc_init_se (&argse, NULL);
11712 : 16 : gfc_conv_expr (&argse, code->ext.actual->expr);
11713 : 16 : gfc_add_block_to_block (&block, &argse.pre);
11714 : 16 : gfc_add_block_to_block (&post_block, &argse.post);
11715 : 16 : array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
11716 : 16 : array = gfc_build_addr_expr (NULL_TREE, array);
11717 : : }
11718 : : else
11719 : : {
11720 : 13 : argse.want_pointer = 1;
11721 : 13 : gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
11722 : 13 : array = argse.expr;
11723 : : }
11724 : : }
11725 : :
11726 : 30 : gfc_add_block_to_block (&block, &argse.pre);
11727 : 30 : gfc_add_block_to_block (&post_block, &argse.post);
11728 : :
11729 : 30 : if (code->ext.actual->expr->ts.type == BT_CHARACTER)
11730 : 6 : strlen = argse.string_length;
11731 : : else
11732 : 24 : strlen = integer_zero_node;
11733 : :
11734 : : /* image_index. */
11735 : 30 : if (image_idx_expr)
11736 : : {
11737 : 22 : gfc_init_se (&argse, NULL);
11738 : 22 : gfc_conv_expr (&argse, image_idx_expr);
11739 : 22 : gfc_add_block_to_block (&block, &argse.pre);
11740 : 22 : gfc_add_block_to_block (&post_block, &argse.post);
11741 : 22 : image_index = fold_convert (integer_type_node, argse.expr);
11742 : : }
11743 : : else
11744 : 8 : image_index = integer_zero_node;
11745 : :
11746 : : /* errmsg. */
11747 : 30 : if (errmsg_expr)
11748 : : {
11749 : 17 : gfc_init_se (&argse, NULL);
11750 : 17 : gfc_conv_expr (&argse, errmsg_expr);
11751 : 17 : gfc_add_block_to_block (&block, &argse.pre);
11752 : 17 : gfc_add_block_to_block (&post_block, &argse.post);
11753 : 17 : errmsg = argse.expr;
11754 : 17 : errmsg_len = fold_convert (size_type_node, argse.string_length);
11755 : : }
11756 : : else
11757 : : {
11758 : 13 : errmsg = null_pointer_node;
11759 : 13 : errmsg_len = build_zero_cst (size_type_node);
11760 : : }
11761 : :
11762 : : /* Generate the function call. */
11763 : 30 : switch (code->resolved_isym->id)
11764 : : {
11765 : 12 : case GFC_ISYM_CO_BROADCAST:
11766 : 12 : fndecl = gfor_fndecl_co_broadcast;
11767 : 12 : break;
11768 : 5 : case GFC_ISYM_CO_MAX:
11769 : 5 : fndecl = gfor_fndecl_co_max;
11770 : 5 : break;
11771 : 4 : case GFC_ISYM_CO_MIN:
11772 : 4 : fndecl = gfor_fndecl_co_min;
11773 : 4 : break;
11774 : 5 : case GFC_ISYM_CO_REDUCE:
11775 : 5 : fndecl = gfor_fndecl_co_reduce;
11776 : 5 : break;
11777 : 4 : case GFC_ISYM_CO_SUM:
11778 : 4 : fndecl = gfor_fndecl_co_sum;
11779 : 4 : break;
11780 : 0 : default:
11781 : 0 : gcc_unreachable ();
11782 : : }
11783 : :
11784 : 30 : if (derived && derived->attr.alloc_comp
11785 : 1 : && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
11786 : : /* The derived type has the attribute 'alloc_comp'. */
11787 : : {
11788 : 2 : tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
11789 : 1 : code->ext.actual->expr->rank,
11790 : : image_index, stat, errmsg, errmsg_len);
11791 : 1 : gfc_add_expr_to_block (&block, tmp);
11792 : 1 : }
11793 : : else
11794 : : {
11795 : 29 : if (code->resolved_isym->id == GFC_ISYM_CO_SUM
11796 : 25 : || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
11797 : 15 : fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
11798 : : image_index, stat, errmsg, errmsg_len);
11799 : 14 : else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
11800 : 9 : fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
11801 : : image_index, stat, errmsg,
11802 : : strlen, errmsg_len);
11803 : : else
11804 : : {
11805 : 5 : tree opr, opr_flags;
11806 : :
11807 : : // FIXME: Handle TS29113's bind(C) strings with descriptor.
11808 : 5 : int opr_flag_int;
11809 : 5 : if (gfc_is_proc_ptr_comp (opr_expr))
11810 : : {
11811 : 0 : gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
11812 : 0 : opr_flag_int = sym->attr.dimension
11813 : 0 : || (sym->ts.type == BT_CHARACTER
11814 : 0 : && !sym->attr.is_bind_c)
11815 : 0 : ? GFC_CAF_BYREF : 0;
11816 : 0 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
11817 : 0 : && !sym->attr.is_bind_c
11818 : 0 : ? GFC_CAF_HIDDENLEN : 0;
11819 : 0 : opr_flag_int |= sym->formal->sym->attr.value
11820 : 0 : ? GFC_CAF_ARG_VALUE : 0;
11821 : : }
11822 : : else
11823 : : {
11824 : 5 : opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
11825 : 5 : ? GFC_CAF_BYREF : 0;
11826 : 10 : opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
11827 : 0 : && !opr_expr->symtree->n.sym->attr.is_bind_c
11828 : 5 : ? GFC_CAF_HIDDENLEN : 0;
11829 : 5 : opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
11830 : 5 : ? GFC_CAF_ARG_VALUE : 0;
11831 : : }
11832 : 5 : opr_flags = build_int_cst (integer_type_node, opr_flag_int);
11833 : 5 : gfc_conv_expr (&argse, opr_expr);
11834 : 5 : opr = argse.expr;
11835 : 5 : fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
11836 : : opr_flags, image_index, stat, errmsg,
11837 : : strlen, errmsg_len);
11838 : : }
11839 : : }
11840 : :
11841 : 30 : gfc_add_expr_to_block (&block, fndecl);
11842 : 30 : gfc_add_block_to_block (&block, &post_block);
11843 : :
11844 : 30 : return gfc_finish_block (&block);
11845 : : }
11846 : :
11847 : :
11848 : : static tree
11849 : 68 : conv_intrinsic_atomic_op (gfc_code *code)
11850 : : {
11851 : 68 : gfc_se argse;
11852 : 68 : tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
11853 : 68 : stmtblock_t block, post_block;
11854 : 68 : gfc_expr *atom_expr = code->ext.actual->expr;
11855 : 68 : gfc_expr *stat_expr;
11856 : 68 : built_in_function fn;
11857 : :
11858 : 68 : if (atom_expr->expr_type == EXPR_FUNCTION
11859 : 25 : && atom_expr->value.function.isym
11860 : 25 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
11861 : 25 : atom_expr = atom_expr->value.function.actual->expr;
11862 : :
11863 : 68 : gfc_start_block (&block);
11864 : 68 : gfc_init_block (&post_block);
11865 : :
11866 : 68 : gfc_init_se (&argse, NULL);
11867 : 68 : argse.want_pointer = 1;
11868 : 68 : gfc_conv_expr (&argse, atom_expr);
11869 : 68 : gfc_add_block_to_block (&block, &argse.pre);
11870 : 68 : gfc_add_block_to_block (&post_block, &argse.post);
11871 : 68 : atom = argse.expr;
11872 : :
11873 : 68 : gfc_init_se (&argse, NULL);
11874 : 68 : if (flag_coarray == GFC_FCOARRAY_LIB
11875 : 29 : && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
11876 : 28 : argse.want_pointer = 1;
11877 : 68 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
11878 : 68 : gfc_add_block_to_block (&block, &argse.pre);
11879 : 68 : gfc_add_block_to_block (&post_block, &argse.post);
11880 : 68 : value = argse.expr;
11881 : :
11882 : 68 : switch (code->resolved_isym->id)
11883 : : {
11884 : 42 : case GFC_ISYM_ATOMIC_ADD:
11885 : 42 : case GFC_ISYM_ATOMIC_AND:
11886 : 42 : case GFC_ISYM_ATOMIC_DEF:
11887 : 42 : case GFC_ISYM_ATOMIC_OR:
11888 : 42 : case GFC_ISYM_ATOMIC_XOR:
11889 : 42 : stat_expr = code->ext.actual->next->next->expr;
11890 : 42 : if (flag_coarray == GFC_FCOARRAY_LIB)
11891 : 18 : old = null_pointer_node;
11892 : : break;
11893 : 26 : default:
11894 : 26 : gfc_init_se (&argse, NULL);
11895 : 26 : if (flag_coarray == GFC_FCOARRAY_LIB)
11896 : 11 : argse.want_pointer = 1;
11897 : 26 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
11898 : 26 : gfc_add_block_to_block (&block, &argse.pre);
11899 : 26 : gfc_add_block_to_block (&post_block, &argse.post);
11900 : 26 : old = argse.expr;
11901 : 26 : stat_expr = code->ext.actual->next->next->next->expr;
11902 : : }
11903 : :
11904 : : /* STAT= */
11905 : 68 : if (stat_expr != NULL)
11906 : : {
11907 : 58 : gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
11908 : 58 : gfc_init_se (&argse, NULL);
11909 : 58 : if (flag_coarray == GFC_FCOARRAY_LIB)
11910 : 24 : argse.want_pointer = 1;
11911 : 58 : gfc_conv_expr_val (&argse, stat_expr);
11912 : 58 : gfc_add_block_to_block (&block, &argse.pre);
11913 : 58 : gfc_add_block_to_block (&post_block, &argse.post);
11914 : 58 : stat = argse.expr;
11915 : : }
11916 : 10 : else if (flag_coarray == GFC_FCOARRAY_LIB)
11917 : 5 : stat = null_pointer_node;
11918 : :
11919 : 68 : if (flag_coarray == GFC_FCOARRAY_LIB)
11920 : : {
11921 : 29 : tree image_index, caf_decl, offset, token;
11922 : 29 : int op;
11923 : :
11924 : 29 : switch (code->resolved_isym->id)
11925 : : {
11926 : : case GFC_ISYM_ATOMIC_ADD:
11927 : : case GFC_ISYM_ATOMIC_FETCH_ADD:
11928 : : op = (int) GFC_CAF_ATOMIC_ADD;
11929 : : break;
11930 : 6 : case GFC_ISYM_ATOMIC_AND:
11931 : 6 : case GFC_ISYM_ATOMIC_FETCH_AND:
11932 : 6 : op = (int) GFC_CAF_ATOMIC_AND;
11933 : 6 : break;
11934 : 6 : case GFC_ISYM_ATOMIC_OR:
11935 : 6 : case GFC_ISYM_ATOMIC_FETCH_OR:
11936 : 6 : op = (int) GFC_CAF_ATOMIC_OR;
11937 : 6 : break;
11938 : 6 : case GFC_ISYM_ATOMIC_XOR:
11939 : 6 : case GFC_ISYM_ATOMIC_FETCH_XOR:
11940 : 6 : op = (int) GFC_CAF_ATOMIC_XOR;
11941 : 6 : break;
11942 : 6 : case GFC_ISYM_ATOMIC_DEF:
11943 : 6 : op = 0; /* Unused. */
11944 : 6 : break;
11945 : 0 : default:
11946 : 0 : gcc_unreachable ();
11947 : : }
11948 : :
11949 : 29 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
11950 : 29 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
11951 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
11952 : :
11953 : 29 : if (gfc_is_coindexed (atom_expr))
11954 : 25 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
11955 : : else
11956 : 4 : image_index = integer_zero_node;
11957 : :
11958 : 29 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
11959 : : {
11960 : 28 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
11961 : 28 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
11962 : 28 : value = gfc_build_addr_expr (NULL_TREE, tmp);
11963 : : }
11964 : :
11965 : 29 : gfc_init_se (&argse, NULL);
11966 : 29 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
11967 : : atom_expr);
11968 : :
11969 : 29 : gfc_add_block_to_block (&block, &argse.pre);
11970 : 29 : if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
11971 : 6 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
11972 : : token, offset, image_index, value, stat,
11973 : : build_int_cst (integer_type_node,
11974 : 6 : (int) atom_expr->ts.type),
11975 : : build_int_cst (integer_type_node,
11976 : 6 : (int) atom_expr->ts.kind));
11977 : : else
11978 : 23 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
11979 : : build_int_cst (integer_type_node, op),
11980 : : token, offset, image_index, value, old, stat,
11981 : : build_int_cst (integer_type_node,
11982 : 23 : (int) atom_expr->ts.type),
11983 : : build_int_cst (integer_type_node,
11984 : 23 : (int) atom_expr->ts.kind));
11985 : :
11986 : 29 : gfc_add_expr_to_block (&block, tmp);
11987 : 29 : gfc_add_block_to_block (&block, &argse.post);
11988 : 29 : gfc_add_block_to_block (&block, &post_block);
11989 : 29 : return gfc_finish_block (&block);
11990 : : }
11991 : :
11992 : :
11993 : 39 : switch (code->resolved_isym->id)
11994 : : {
11995 : : case GFC_ISYM_ATOMIC_ADD:
11996 : : case GFC_ISYM_ATOMIC_FETCH_ADD:
11997 : : fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
11998 : : break;
11999 : 8 : case GFC_ISYM_ATOMIC_AND:
12000 : 8 : case GFC_ISYM_ATOMIC_FETCH_AND:
12001 : 8 : fn = BUILT_IN_ATOMIC_FETCH_AND_N;
12002 : 8 : break;
12003 : 9 : case GFC_ISYM_ATOMIC_DEF:
12004 : 9 : fn = BUILT_IN_ATOMIC_STORE_N;
12005 : 9 : break;
12006 : 8 : case GFC_ISYM_ATOMIC_OR:
12007 : 8 : case GFC_ISYM_ATOMIC_FETCH_OR:
12008 : 8 : fn = BUILT_IN_ATOMIC_FETCH_OR_N;
12009 : 8 : break;
12010 : 8 : case GFC_ISYM_ATOMIC_XOR:
12011 : 8 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12012 : 8 : fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
12013 : 8 : break;
12014 : 0 : default:
12015 : 0 : gcc_unreachable ();
12016 : : }
12017 : :
12018 : 39 : tmp = TREE_TYPE (TREE_TYPE (atom));
12019 : 78 : fn = (built_in_function) ((int) fn
12020 : 39 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12021 : 39 : + 1);
12022 : 39 : tree itype = TREE_TYPE (TREE_TYPE (atom));
12023 : 39 : tmp = builtin_decl_explicit (fn);
12024 : :
12025 : 39 : switch (code->resolved_isym->id)
12026 : : {
12027 : 24 : case GFC_ISYM_ATOMIC_ADD:
12028 : 24 : case GFC_ISYM_ATOMIC_AND:
12029 : 24 : case GFC_ISYM_ATOMIC_DEF:
12030 : 24 : case GFC_ISYM_ATOMIC_OR:
12031 : 24 : case GFC_ISYM_ATOMIC_XOR:
12032 : 24 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12033 : : fold_convert (itype, value),
12034 : 24 : build_int_cst (NULL, MEMMODEL_RELAXED));
12035 : 24 : gfc_add_expr_to_block (&block, tmp);
12036 : 24 : break;
12037 : 15 : default:
12038 : 15 : tmp = build_call_expr_loc (input_location, tmp, 3, atom,
12039 : : fold_convert (itype, value),
12040 : 15 : build_int_cst (NULL, MEMMODEL_RELAXED));
12041 : 15 : gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
12042 : 15 : break;
12043 : : }
12044 : :
12045 : 39 : if (stat != NULL_TREE)
12046 : 34 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12047 : 39 : gfc_add_block_to_block (&block, &post_block);
12048 : 39 : return gfc_finish_block (&block);
12049 : : }
12050 : :
12051 : :
12052 : : static tree
12053 : 119 : conv_intrinsic_atomic_ref (gfc_code *code)
12054 : : {
12055 : 119 : gfc_se argse;
12056 : 119 : tree tmp, atom, value, stat = NULL_TREE;
12057 : 119 : stmtblock_t block, post_block;
12058 : 119 : built_in_function fn;
12059 : 119 : gfc_expr *atom_expr = code->ext.actual->next->expr;
12060 : :
12061 : 119 : if (atom_expr->expr_type == EXPR_FUNCTION
12062 : 52 : && atom_expr->value.function.isym
12063 : 52 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12064 : 52 : atom_expr = atom_expr->value.function.actual->expr;
12065 : :
12066 : 119 : gfc_start_block (&block);
12067 : 119 : gfc_init_block (&post_block);
12068 : 119 : gfc_init_se (&argse, NULL);
12069 : 119 : argse.want_pointer = 1;
12070 : 119 : gfc_conv_expr (&argse, atom_expr);
12071 : 119 : gfc_add_block_to_block (&block, &argse.pre);
12072 : 119 : gfc_add_block_to_block (&post_block, &argse.post);
12073 : 119 : atom = argse.expr;
12074 : :
12075 : 119 : gfc_init_se (&argse, NULL);
12076 : 119 : if (flag_coarray == GFC_FCOARRAY_LIB
12077 : 58 : && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
12078 : 55 : argse.want_pointer = 1;
12079 : 119 : gfc_conv_expr (&argse, code->ext.actual->expr);
12080 : 119 : gfc_add_block_to_block (&block, &argse.pre);
12081 : 119 : gfc_add_block_to_block (&post_block, &argse.post);
12082 : 119 : value = argse.expr;
12083 : :
12084 : : /* STAT= */
12085 : 119 : if (code->ext.actual->next->next->expr != NULL)
12086 : : {
12087 : 110 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12088 : : == EXPR_VARIABLE);
12089 : 110 : gfc_init_se (&argse, NULL);
12090 : 110 : if (flag_coarray == GFC_FCOARRAY_LIB)
12091 : 54 : argse.want_pointer = 1;
12092 : 110 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12093 : 110 : gfc_add_block_to_block (&block, &argse.pre);
12094 : 110 : gfc_add_block_to_block (&post_block, &argse.post);
12095 : 110 : stat = argse.expr;
12096 : : }
12097 : 9 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12098 : 4 : stat = null_pointer_node;
12099 : :
12100 : 119 : if (flag_coarray == GFC_FCOARRAY_LIB)
12101 : : {
12102 : 58 : tree image_index, caf_decl, offset, token;
12103 : 58 : tree orig_value = NULL_TREE, vardecl = NULL_TREE;
12104 : :
12105 : 58 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12106 : 58 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12107 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12108 : :
12109 : 58 : if (gfc_is_coindexed (atom_expr))
12110 : 52 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12111 : : else
12112 : 6 : image_index = integer_zero_node;
12113 : :
12114 : 58 : gfc_init_se (&argse, NULL);
12115 : 58 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12116 : : atom_expr);
12117 : 58 : gfc_add_block_to_block (&block, &argse.pre);
12118 : :
12119 : : /* Different type, need type conversion. */
12120 : 58 : if (!POINTER_TYPE_P (TREE_TYPE (value)))
12121 : : {
12122 : 3 : vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
12123 : 3 : orig_value = value;
12124 : 3 : value = gfc_build_addr_expr (NULL_TREE, vardecl);
12125 : : }
12126 : :
12127 : 58 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
12128 : : token, offset, image_index, value, stat,
12129 : : build_int_cst (integer_type_node,
12130 : 58 : (int) atom_expr->ts.type),
12131 : : build_int_cst (integer_type_node,
12132 : 58 : (int) atom_expr->ts.kind));
12133 : 58 : gfc_add_expr_to_block (&block, tmp);
12134 : 58 : if (vardecl != NULL_TREE)
12135 : 3 : gfc_add_modify (&block, orig_value,
12136 : 3 : fold_convert (TREE_TYPE (orig_value), vardecl));
12137 : 58 : gfc_add_block_to_block (&block, &argse.post);
12138 : 58 : gfc_add_block_to_block (&block, &post_block);
12139 : 58 : return gfc_finish_block (&block);
12140 : : }
12141 : :
12142 : 61 : tmp = TREE_TYPE (TREE_TYPE (atom));
12143 : 122 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
12144 : 61 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12145 : 61 : + 1);
12146 : 61 : tmp = builtin_decl_explicit (fn);
12147 : 61 : tmp = build_call_expr_loc (input_location, tmp, 2, atom,
12148 : : build_int_cst (integer_type_node,
12149 : 61 : MEMMODEL_RELAXED));
12150 : 61 : gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
12151 : :
12152 : 61 : if (stat != NULL_TREE)
12153 : 56 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12154 : 61 : gfc_add_block_to_block (&block, &post_block);
12155 : 61 : return gfc_finish_block (&block);
12156 : : }
12157 : :
12158 : :
12159 : : static tree
12160 : 10 : conv_intrinsic_atomic_cas (gfc_code *code)
12161 : : {
12162 : 10 : gfc_se argse;
12163 : 10 : tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
12164 : 10 : stmtblock_t block, post_block;
12165 : 10 : built_in_function fn;
12166 : 10 : gfc_expr *atom_expr = code->ext.actual->expr;
12167 : :
12168 : 10 : if (atom_expr->expr_type == EXPR_FUNCTION
12169 : 4 : && atom_expr->value.function.isym
12170 : 4 : && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12171 : 4 : atom_expr = atom_expr->value.function.actual->expr;
12172 : :
12173 : 10 : gfc_init_block (&block);
12174 : 10 : gfc_init_block (&post_block);
12175 : 10 : gfc_init_se (&argse, NULL);
12176 : 10 : argse.want_pointer = 1;
12177 : 10 : gfc_conv_expr (&argse, atom_expr);
12178 : 10 : atom = argse.expr;
12179 : :
12180 : 10 : gfc_init_se (&argse, NULL);
12181 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB)
12182 : 4 : argse.want_pointer = 1;
12183 : 10 : gfc_conv_expr (&argse, code->ext.actual->next->expr);
12184 : 10 : gfc_add_block_to_block (&block, &argse.pre);
12185 : 10 : gfc_add_block_to_block (&post_block, &argse.post);
12186 : 10 : old = argse.expr;
12187 : :
12188 : 10 : gfc_init_se (&argse, NULL);
12189 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB)
12190 : 4 : argse.want_pointer = 1;
12191 : 10 : gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
12192 : 10 : gfc_add_block_to_block (&block, &argse.pre);
12193 : 10 : gfc_add_block_to_block (&post_block, &argse.post);
12194 : 10 : comp = argse.expr;
12195 : :
12196 : 10 : gfc_init_se (&argse, NULL);
12197 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB
12198 : 4 : && code->ext.actual->next->next->next->expr->ts.kind
12199 : 4 : == atom_expr->ts.kind)
12200 : 4 : argse.want_pointer = 1;
12201 : 10 : gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
12202 : 10 : gfc_add_block_to_block (&block, &argse.pre);
12203 : 10 : gfc_add_block_to_block (&post_block, &argse.post);
12204 : 10 : new_val = argse.expr;
12205 : :
12206 : : /* STAT= */
12207 : 10 : if (code->ext.actual->next->next->next->next->expr != NULL)
12208 : : {
12209 : 10 : gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
12210 : : == EXPR_VARIABLE);
12211 : 10 : gfc_init_se (&argse, NULL);
12212 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB)
12213 : 4 : argse.want_pointer = 1;
12214 : 10 : gfc_conv_expr_val (&argse,
12215 : 10 : code->ext.actual->next->next->next->next->expr);
12216 : 10 : gfc_add_block_to_block (&block, &argse.pre);
12217 : 10 : gfc_add_block_to_block (&post_block, &argse.post);
12218 : 10 : stat = argse.expr;
12219 : : }
12220 : 0 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12221 : 0 : stat = null_pointer_node;
12222 : :
12223 : 10 : if (flag_coarray == GFC_FCOARRAY_LIB)
12224 : : {
12225 : 4 : tree image_index, caf_decl, offset, token;
12226 : :
12227 : 4 : caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
12228 : 4 : if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
12229 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
12230 : :
12231 : 4 : if (gfc_is_coindexed (atom_expr))
12232 : 4 : image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
12233 : : else
12234 : 0 : image_index = integer_zero_node;
12235 : :
12236 : 4 : if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
12237 : : {
12238 : 4 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
12239 : 4 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
12240 : 4 : new_val = gfc_build_addr_expr (NULL_TREE, tmp);
12241 : : }
12242 : :
12243 : : /* Convert a constant to a pointer. */
12244 : 4 : if (!POINTER_TYPE_P (TREE_TYPE (comp)))
12245 : : {
12246 : 4 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
12247 : 4 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
12248 : 4 : comp = gfc_build_addr_expr (NULL_TREE, tmp);
12249 : : }
12250 : :
12251 : 4 : gfc_init_se (&argse, NULL);
12252 : 4 : gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
12253 : : atom_expr);
12254 : 4 : gfc_add_block_to_block (&block, &argse.pre);
12255 : :
12256 : 4 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
12257 : : token, offset, image_index, old, comp, new_val,
12258 : : stat, build_int_cst (integer_type_node,
12259 : 4 : (int) atom_expr->ts.type),
12260 : : build_int_cst (integer_type_node,
12261 : 4 : (int) atom_expr->ts.kind));
12262 : 4 : gfc_add_expr_to_block (&block, tmp);
12263 : 4 : gfc_add_block_to_block (&block, &argse.post);
12264 : 4 : gfc_add_block_to_block (&block, &post_block);
12265 : 4 : return gfc_finish_block (&block);
12266 : : }
12267 : :
12268 : 6 : tmp = TREE_TYPE (TREE_TYPE (atom));
12269 : 12 : fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
12270 : 6 : + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
12271 : 6 : + 1);
12272 : 6 : tmp = builtin_decl_explicit (fn);
12273 : :
12274 : 6 : gfc_add_modify (&block, old, comp);
12275 : 12 : tmp = build_call_expr_loc (input_location, tmp, 6, atom,
12276 : : gfc_build_addr_expr (NULL, old),
12277 : 6 : fold_convert (TREE_TYPE (old), new_val),
12278 : : boolean_false_node,
12279 : 6 : build_int_cst (NULL, MEMMODEL_RELAXED),
12280 : 6 : build_int_cst (NULL, MEMMODEL_RELAXED));
12281 : 6 : gfc_add_expr_to_block (&block, tmp);
12282 : :
12283 : 6 : if (stat != NULL_TREE)
12284 : 6 : gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
12285 : 6 : gfc_add_block_to_block (&block, &post_block);
12286 : 6 : return gfc_finish_block (&block);
12287 : : }
12288 : :
12289 : : static tree
12290 : 70 : conv_intrinsic_event_query (gfc_code *code)
12291 : : {
12292 : 70 : gfc_se se, argse;
12293 : 70 : tree stat = NULL_TREE, stat2 = NULL_TREE;
12294 : 70 : tree count = NULL_TREE, count2 = NULL_TREE;
12295 : :
12296 : 70 : gfc_expr *event_expr = code->ext.actual->expr;
12297 : :
12298 : 70 : if (code->ext.actual->next->next->expr)
12299 : : {
12300 : 12 : gcc_assert (code->ext.actual->next->next->expr->expr_type
12301 : : == EXPR_VARIABLE);
12302 : 12 : gfc_init_se (&argse, NULL);
12303 : 12 : gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
12304 : 12 : stat = argse.expr;
12305 : : }
12306 : 58 : else if (flag_coarray == GFC_FCOARRAY_LIB)
12307 : 29 : stat = null_pointer_node;
12308 : :
12309 : 70 : if (code->ext.actual->next->expr)
12310 : : {
12311 : 70 : gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
12312 : 70 : gfc_init_se (&argse, NULL);
12313 : 70 : gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
12314 : 70 : count = argse.expr;
12315 : : }
12316 : :
12317 : 70 : gfc_start_block (&se.pre);
12318 : 70 : if (flag_coarray == GFC_FCOARRAY_LIB)
12319 : : {
12320 : 35 : tree tmp, token, image_index;
12321 : 35 : tree index = build_zero_cst (gfc_array_index_type);
12322 : :
12323 : 35 : if (event_expr->expr_type == EXPR_FUNCTION
12324 : 0 : && event_expr->value.function.isym
12325 : 0 : && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
12326 : 0 : event_expr = event_expr->value.function.actual->expr;
12327 : :
12328 : 35 : tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
12329 : :
12330 : 35 : if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
12331 : 35 : || event_expr->symtree->n.sym->ts.u.derived->from_intmod
12332 : : != INTMOD_ISO_FORTRAN_ENV
12333 : 35 : || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
12334 : : != ISOFORTRAN_EVENT_TYPE)
12335 : : {
12336 : 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
12337 : : "yet supported", &event_expr->where);
12338 : 0 : return NULL_TREE;
12339 : : }
12340 : :
12341 : 35 : if (gfc_is_coindexed (event_expr))
12342 : : {
12343 : 0 : gfc_error ("The event variable at %L shall not be coindexed",
12344 : : &event_expr->where);
12345 : 0 : return NULL_TREE;
12346 : : }
12347 : :
12348 : 35 : image_index = integer_zero_node;
12349 : :
12350 : 35 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
12351 : : event_expr);
12352 : :
12353 : : /* For arrays, obtain the array index. */
12354 : 35 : if (gfc_expr_attr (event_expr).dimension)
12355 : : {
12356 : 26 : tree desc, tmp, extent, lbound, ubound;
12357 : 26 : gfc_array_ref *ar, ar2;
12358 : 26 : int i;
12359 : :
12360 : : /* TODO: Extend this, once DT components are supported. */
12361 : 26 : ar = &event_expr->ref->u.ar;
12362 : 26 : ar2 = *ar;
12363 : 26 : memset (ar, '\0', sizeof (*ar));
12364 : 26 : ar->as = ar2.as;
12365 : 26 : ar->type = AR_FULL;
12366 : :
12367 : 26 : gfc_init_se (&argse, NULL);
12368 : 26 : argse.descriptor_only = 1;
12369 : 26 : gfc_conv_expr_descriptor (&argse, event_expr);
12370 : 26 : gfc_add_block_to_block (&se.pre, &argse.pre);
12371 : 26 : desc = argse.expr;
12372 : 26 : *ar = ar2;
12373 : :
12374 : 26 : extent = build_one_cst (gfc_array_index_type);
12375 : 78 : for (i = 0; i < ar->dimen; i++)
12376 : : {
12377 : 26 : gfc_init_se (&argse, NULL);
12378 : 26 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
12379 : 26 : gfc_add_block_to_block (&argse.pre, &argse.pre);
12380 : 26 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
12381 : 26 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12382 : 26 : TREE_TYPE (lbound), argse.expr, lbound);
12383 : 26 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12384 : 26 : TREE_TYPE (tmp), extent, tmp);
12385 : 26 : index = fold_build2_loc (input_location, PLUS_EXPR,
12386 : 26 : TREE_TYPE (tmp), index, tmp);
12387 : 26 : if (i < ar->dimen - 1)
12388 : : {
12389 : 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
12390 : 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
12391 : 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
12392 : 0 : TREE_TYPE (tmp), extent, tmp);
12393 : : }
12394 : : }
12395 : : }
12396 : :
12397 : 35 : if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
12398 : : {
12399 : 0 : count2 = count;
12400 : 0 : count = gfc_create_var (integer_type_node, "count");
12401 : : }
12402 : :
12403 : 35 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
12404 : : {
12405 : 0 : stat2 = stat;
12406 : 0 : stat = gfc_create_var (integer_type_node, "stat");
12407 : : }
12408 : :
12409 : 35 : index = fold_convert (size_type_node, index);
12410 : 70 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
12411 : : token, index, image_index, count
12412 : 35 : ? gfc_build_addr_expr (NULL, count) : count,
12413 : 35 : stat != null_pointer_node
12414 : 6 : ? gfc_build_addr_expr (NULL, stat) : stat);
12415 : 35 : gfc_add_expr_to_block (&se.pre, tmp);
12416 : :
12417 : 35 : if (count2 != NULL_TREE)
12418 : 0 : gfc_add_modify (&se.pre, count2,
12419 : 0 : fold_convert (TREE_TYPE (count2), count));
12420 : :
12421 : 35 : if (stat2 != NULL_TREE)
12422 : 0 : gfc_add_modify (&se.pre, stat2,
12423 : 0 : fold_convert (TREE_TYPE (stat2), stat));
12424 : :
12425 : 35 : return gfc_finish_block (&se.pre);
12426 : : }
12427 : :
12428 : 35 : gfc_init_se (&argse, NULL);
12429 : 35 : gfc_conv_expr_val (&argse, code->ext.actual->expr);
12430 : 35 : gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
12431 : :
12432 : 35 : if (stat != NULL_TREE)
12433 : 6 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
12434 : :
12435 : 35 : return gfc_finish_block (&se.pre);
12436 : : }
12437 : :
12438 : :
12439 : : /* This is a peculiar case because of the need to do dependency checking.
12440 : : It is called via trans-stmt.cc(gfc_trans_call), where it is picked out as
12441 : : a special case and this function called instead of
12442 : : gfc_conv_procedure_call. */
12443 : : void
12444 : 173 : gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args,
12445 : : gfc_loopinfo *loop)
12446 : : {
12447 : 173 : gfc_actual_arglist *actual;
12448 : 173 : gfc_se argse[5];
12449 : 173 : gfc_expr *arg[5];
12450 : 173 : gfc_ss *lss;
12451 : 173 : int n;
12452 : :
12453 : 173 : tree from, frompos, len, to, topos;
12454 : 173 : tree lenmask, oldbits, newbits, bitsize;
12455 : 173 : tree type, utype, above, mask1, mask2;
12456 : :
12457 : 173 : if (loop)
12458 : 67 : lss = loop->ss;
12459 : : else
12460 : 106 : lss = gfc_ss_terminator;
12461 : :
12462 : : actual = actual_args;
12463 : 1038 : for (n = 0; n < 5; n++, actual = actual->next)
12464 : : {
12465 : 865 : arg[n] = actual->expr;
12466 : 865 : gfc_init_se (&argse[n], NULL);
12467 : :
12468 : 865 : if (lss != gfc_ss_terminator)
12469 : : {
12470 : 335 : gfc_copy_loopinfo_to_se (&argse[n], loop);
12471 : : /* Find the ss for the expression if it is there. */
12472 : 335 : argse[n].ss = lss;
12473 : 335 : gfc_mark_ss_chain_used (lss, 1);
12474 : : }
12475 : :
12476 : 865 : gfc_conv_expr (&argse[n], arg[n]);
12477 : :
12478 : 865 : if (loop)
12479 : 335 : lss = argse[n].ss;
12480 : : }
12481 : :
12482 : 173 : from = argse[0].expr;
12483 : 173 : frompos = argse[1].expr;
12484 : 173 : len = argse[2].expr;
12485 : 173 : to = argse[3].expr;
12486 : 173 : topos = argse[4].expr;
12487 : :
12488 : : /* The type of the result (TO). */
12489 : 173 : type = TREE_TYPE (to);
12490 : 173 : bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type));
12491 : :
12492 : : /* Optionally generate code for runtime argument check. */
12493 : 173 : if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
12494 : : {
12495 : 18 : tree nbits, below, ccond;
12496 : 18 : tree fp = fold_convert (long_integer_type_node, frompos);
12497 : 18 : tree ln = fold_convert (long_integer_type_node, len);
12498 : 18 : tree tp = fold_convert (long_integer_type_node, topos);
12499 : 18 : below = fold_build2_loc (input_location, LT_EXPR,
12500 : : logical_type_node, frompos,
12501 : 18 : build_int_cst (TREE_TYPE (frompos), 0));
12502 : 18 : above = fold_build2_loc (input_location, GT_EXPR,
12503 : : logical_type_node, frompos,
12504 : 18 : fold_convert (TREE_TYPE (frompos), bitsize));
12505 : 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
12506 : : logical_type_node, below, above);
12507 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
12508 : 18 : &arg[1]->where,
12509 : : "FROMPOS argument (%ld) out of range 0:%d "
12510 : : "in intrinsic MVBITS", fp, bitsize);
12511 : 18 : below = fold_build2_loc (input_location, LT_EXPR,
12512 : : logical_type_node, len,
12513 : 18 : build_int_cst (TREE_TYPE (len), 0));
12514 : 18 : above = fold_build2_loc (input_location, GT_EXPR,
12515 : : logical_type_node, len,
12516 : 18 : fold_convert (TREE_TYPE (len), bitsize));
12517 : 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
12518 : : logical_type_node, below, above);
12519 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[2].pre,
12520 : 18 : &arg[2]->where,
12521 : : "LEN argument (%ld) out of range 0:%d "
12522 : : "in intrinsic MVBITS", ln, bitsize);
12523 : 18 : below = fold_build2_loc (input_location, LT_EXPR,
12524 : : logical_type_node, topos,
12525 : 18 : build_int_cst (TREE_TYPE (topos), 0));
12526 : 18 : above = fold_build2_loc (input_location, GT_EXPR,
12527 : : logical_type_node, topos,
12528 : 18 : fold_convert (TREE_TYPE (topos), bitsize));
12529 : 18 : ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
12530 : : logical_type_node, below, above);
12531 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
12532 : 18 : &arg[4]->where,
12533 : : "TOPOS argument (%ld) out of range 0:%d "
12534 : : "in intrinsic MVBITS", tp, bitsize);
12535 : :
12536 : : /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short
12537 : : integers. Additions below cannot overflow. */
12538 : 18 : nbits = fold_convert (long_integer_type_node, bitsize);
12539 : 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
12540 : : long_integer_type_node, fp, ln);
12541 : 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
12542 : : logical_type_node, above, nbits);
12543 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[1].pre,
12544 : : &arg[1]->where,
12545 : : "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12546 : : "in intrinsic MVBITS", fp, ln, bitsize);
12547 : 18 : above = fold_build2_loc (input_location, PLUS_EXPR,
12548 : : long_integer_type_node, tp, ln);
12549 : 18 : ccond = fold_build2_loc (input_location, GT_EXPR,
12550 : : logical_type_node, above, nbits);
12551 : 18 : gfc_trans_runtime_check (true, false, ccond, &argse[4].pre,
12552 : : &arg[4]->where,
12553 : : "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) "
12554 : : "in intrinsic MVBITS", tp, ln, bitsize);
12555 : : }
12556 : :
12557 : 1038 : for (n = 0; n < 5; n++)
12558 : : {
12559 : 865 : gfc_add_block_to_block (&se->pre, &argse[n].pre);
12560 : 865 : gfc_add_block_to_block (&se->post, &argse[n].post);
12561 : : }
12562 : :
12563 : : /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */
12564 : 173 : above = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
12565 : 173 : len, fold_convert (TREE_TYPE (len), bitsize));
12566 : 173 : mask1 = build_int_cst (type, -1);
12567 : 173 : mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
12568 : 173 : build_int_cst (type, 1), len);
12569 : 173 : mask2 = fold_build2_loc (input_location, MINUS_EXPR, type,
12570 : 173 : mask2, build_int_cst (type, 1));
12571 : 173 : lenmask = fold_build3_loc (input_location, COND_EXPR, type,
12572 : : above, mask1, mask2);
12573 : :
12574 : : /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS.
12575 : : * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is
12576 : : * not strictly necessary; artificial bits from rshift will be masked. */
12577 : 173 : utype = unsigned_type_for (type);
12578 : 173 : newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
12579 : : fold_convert (utype, from), frompos);
12580 : 173 : newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type,
12581 : : fold_convert (type, newbits), lenmask);
12582 : 173 : newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
12583 : : newbits, topos);
12584 : :
12585 : : /* oldbits = TO & (~(lenmask << TOPOS)). */
12586 : 173 : oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type,
12587 : : lenmask, topos);
12588 : 173 : oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits);
12589 : 173 : oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to);
12590 : :
12591 : : /* TO = newbits | oldbits. */
12592 : 173 : se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
12593 : : oldbits, newbits);
12594 : :
12595 : : /* Return the assignment. */
12596 : 173 : se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
12597 : : void_type_node, to, se->expr);
12598 : 173 : }
12599 : :
12600 : :
12601 : : static tree
12602 : 216 : conv_intrinsic_move_alloc (gfc_code *code)
12603 : : {
12604 : 216 : stmtblock_t block;
12605 : 216 : gfc_expr *from_expr, *to_expr;
12606 : 216 : gfc_expr *to_expr2, *from_expr2 = NULL;
12607 : 216 : gfc_se from_se, to_se;
12608 : 216 : tree tmp;
12609 : 216 : bool coarray;
12610 : :
12611 : 216 : gfc_start_block (&block);
12612 : :
12613 : 216 : from_expr = code->ext.actual->expr;
12614 : 216 : to_expr = code->ext.actual->next->expr;
12615 : :
12616 : 216 : gfc_init_se (&from_se, NULL);
12617 : 216 : gfc_init_se (&to_se, NULL);
12618 : :
12619 : 216 : gcc_assert (from_expr->ts.type != BT_CLASS
12620 : : || to_expr->ts.type == BT_CLASS);
12621 : 216 : coarray = gfc_get_corank (from_expr) != 0;
12622 : :
12623 : 216 : if (from_expr->rank == 0 && !coarray)
12624 : : {
12625 : 103 : if (from_expr->ts.type != BT_CLASS)
12626 : : from_expr2 = from_expr;
12627 : : else
12628 : : {
12629 : 22 : from_expr2 = gfc_copy_expr (from_expr);
12630 : 22 : gfc_add_data_component (from_expr2);
12631 : : }
12632 : :
12633 : 103 : if (to_expr->ts.type != BT_CLASS)
12634 : : to_expr2 = to_expr;
12635 : : else
12636 : : {
12637 : 46 : to_expr2 = gfc_copy_expr (to_expr);
12638 : 46 : gfc_add_data_component (to_expr2);
12639 : : }
12640 : :
12641 : 103 : from_se.want_pointer = 1;
12642 : 103 : to_se.want_pointer = 1;
12643 : 103 : gfc_conv_expr (&from_se, from_expr2);
12644 : 103 : gfc_conv_expr (&to_se, to_expr2);
12645 : 103 : gfc_add_block_to_block (&block, &from_se.pre);
12646 : 103 : gfc_add_block_to_block (&block, &to_se.pre);
12647 : :
12648 : : /* Deallocate "to". */
12649 : 103 : tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
12650 : : true, to_expr, to_expr->ts);
12651 : 103 : gfc_add_expr_to_block (&block, tmp);
12652 : :
12653 : : /* Assign (_data) pointers. */
12654 : 103 : gfc_add_modify_loc (input_location, &block, to_se.expr,
12655 : 103 : fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
12656 : :
12657 : : /* Set "from" to NULL. */
12658 : 103 : gfc_add_modify_loc (input_location, &block, from_se.expr,
12659 : 103 : fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
12660 : :
12661 : 103 : gfc_add_block_to_block (&block, &from_se.post);
12662 : 103 : gfc_add_block_to_block (&block, &to_se.post);
12663 : :
12664 : : /* Set _vptr. */
12665 : 103 : if (to_expr->ts.type == BT_CLASS)
12666 : : {
12667 : 46 : gfc_symbol *vtab;
12668 : :
12669 : 46 : gfc_free_expr (to_expr2);
12670 : 46 : gfc_init_se (&to_se, NULL);
12671 : 46 : to_se.want_pointer = 1;
12672 : 46 : gfc_add_vptr_component (to_expr);
12673 : 46 : gfc_conv_expr (&to_se, to_expr);
12674 : :
12675 : 46 : if (from_expr->ts.type == BT_CLASS)
12676 : : {
12677 : 22 : if (UNLIMITED_POLY (from_expr))
12678 : : vtab = NULL;
12679 : : else
12680 : : {
12681 : 20 : vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
12682 : 20 : gcc_assert (vtab);
12683 : : }
12684 : :
12685 : 22 : gfc_free_expr (from_expr2);
12686 : 22 : gfc_init_se (&from_se, NULL);
12687 : 22 : from_se.want_pointer = 1;
12688 : 22 : gfc_add_vptr_component (from_expr);
12689 : 22 : gfc_conv_expr (&from_se, from_expr);
12690 : 22 : gfc_add_modify_loc (input_location, &block, to_se.expr,
12691 : 22 : fold_convert (TREE_TYPE (to_se.expr),
12692 : : from_se.expr));
12693 : :
12694 : : /* Reset _vptr component to declared type. */
12695 : 22 : if (vtab == NULL)
12696 : : /* Unlimited polymorphic. */
12697 : 2 : gfc_add_modify_loc (input_location, &block, from_se.expr,
12698 : 2 : fold_convert (TREE_TYPE (from_se.expr),
12699 : : null_pointer_node));
12700 : : else
12701 : : {
12702 : 20 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12703 : 20 : gfc_add_modify_loc (input_location, &block, from_se.expr,
12704 : 20 : fold_convert (TREE_TYPE (from_se.expr), tmp));
12705 : : }
12706 : : }
12707 : : else
12708 : : {
12709 : 24 : vtab = gfc_find_vtab (&from_expr->ts);
12710 : 24 : gcc_assert (vtab);
12711 : 24 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12712 : 24 : gfc_add_modify_loc (input_location, &block, to_se.expr,
12713 : 24 : fold_convert (TREE_TYPE (to_se.expr), tmp));
12714 : : }
12715 : : }
12716 : :
12717 : 103 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
12718 : : {
12719 : 6 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
12720 : 6 : fold_convert (TREE_TYPE (to_se.string_length),
12721 : : from_se.string_length));
12722 : 6 : if (from_expr->ts.deferred)
12723 : 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
12724 : 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
12725 : : }
12726 : :
12727 : 103 : return gfc_finish_block (&block);
12728 : : }
12729 : :
12730 : : /* Update _vptr component. */
12731 : 113 : if (to_expr->ts.type == BT_CLASS)
12732 : : {
12733 : 48 : gfc_symbol *vtab;
12734 : :
12735 : 48 : to_se.want_pointer = 1;
12736 : 48 : to_expr2 = gfc_copy_expr (to_expr);
12737 : 48 : gfc_add_vptr_component (to_expr2);
12738 : 48 : gfc_conv_expr (&to_se, to_expr2);
12739 : :
12740 : 48 : if (from_expr->ts.type == BT_CLASS)
12741 : : {
12742 : 42 : if (UNLIMITED_POLY (from_expr))
12743 : : vtab = NULL;
12744 : : else
12745 : : {
12746 : 36 : vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
12747 : 36 : gcc_assert (vtab);
12748 : : }
12749 : :
12750 : 42 : from_se.want_pointer = 1;
12751 : 42 : from_expr2 = gfc_copy_expr (from_expr);
12752 : 42 : gfc_add_vptr_component (from_expr2);
12753 : 42 : gfc_conv_expr (&from_se, from_expr2);
12754 : 42 : gfc_add_modify_loc (input_location, &block, to_se.expr,
12755 : 42 : fold_convert (TREE_TYPE (to_se.expr),
12756 : : from_se.expr));
12757 : :
12758 : : /* Reset _vptr component to declared type. */
12759 : 42 : if (vtab == NULL)
12760 : : /* Unlimited polymorphic. */
12761 : 6 : gfc_add_modify_loc (input_location, &block, from_se.expr,
12762 : 6 : fold_convert (TREE_TYPE (from_se.expr),
12763 : : null_pointer_node));
12764 : : else
12765 : : {
12766 : 36 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12767 : 36 : gfc_add_modify_loc (input_location, &block, from_se.expr,
12768 : 36 : fold_convert (TREE_TYPE (from_se.expr), tmp));
12769 : : }
12770 : : }
12771 : : else
12772 : : {
12773 : 6 : vtab = gfc_find_vtab (&from_expr->ts);
12774 : 6 : gcc_assert (vtab);
12775 : 6 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
12776 : 6 : gfc_add_modify_loc (input_location, &block, to_se.expr,
12777 : 6 : fold_convert (TREE_TYPE (to_se.expr), tmp));
12778 : : }
12779 : :
12780 : 48 : gfc_free_expr (to_expr2);
12781 : 48 : gfc_init_se (&to_se, NULL);
12782 : :
12783 : 48 : if (from_expr->ts.type == BT_CLASS)
12784 : : {
12785 : 42 : gfc_free_expr (from_expr2);
12786 : 42 : gfc_init_se (&from_se, NULL);
12787 : : }
12788 : : }
12789 : :
12790 : :
12791 : : /* Deallocate "to". */
12792 : 113 : if (from_expr->rank == 0)
12793 : : {
12794 : 3 : to_se.want_coarray = 1;
12795 : 3 : from_se.want_coarray = 1;
12796 : : }
12797 : 113 : gfc_conv_expr_descriptor (&to_se, to_expr);
12798 : 113 : gfc_conv_expr_descriptor (&from_se, from_expr);
12799 : :
12800 : : /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
12801 : : is an image control "statement", cf. IR F08/0040 in 12-006A. */
12802 : 113 : if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
12803 : : {
12804 : 4 : tree cond;
12805 : :
12806 : 4 : tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
12807 : : NULL_TREE, NULL_TREE, true, to_expr,
12808 : : GFC_CAF_COARRAY_DEALLOCATE_ONLY);
12809 : 4 : gfc_add_expr_to_block (&block, tmp);
12810 : :
12811 : 4 : tmp = gfc_conv_descriptor_data_get (to_se.expr);
12812 : 4 : cond = fold_build2_loc (input_location, EQ_EXPR,
12813 : : logical_type_node, tmp,
12814 : 4 : fold_convert (TREE_TYPE (tmp),
12815 : : null_pointer_node));
12816 : 4 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
12817 : : 3, null_pointer_node, null_pointer_node,
12818 : : integer_zero_node);
12819 : :
12820 : 4 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
12821 : : tmp, build_empty_stmt (input_location));
12822 : 4 : gfc_add_expr_to_block (&block, tmp);
12823 : 4 : }
12824 : : else
12825 : : {
12826 : 109 : if (to_expr->ts.type == BT_DERIVED
12827 : 19 : && to_expr->ts.u.derived->attr.alloc_comp)
12828 : : {
12829 : 19 : tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
12830 : : to_se.expr, to_expr->rank);
12831 : 19 : gfc_add_expr_to_block (&block, tmp);
12832 : : }
12833 : :
12834 : 109 : tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
12835 : : NULL_TREE, NULL_TREE, true, to_expr,
12836 : : GFC_CAF_COARRAY_NOCOARRAY);
12837 : 109 : gfc_add_expr_to_block (&block, tmp);
12838 : : }
12839 : :
12840 : : /* Move the pointer and update the array descriptor data. */
12841 : 113 : gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
12842 : :
12843 : : /* Set "from" to NULL. */
12844 : 113 : tmp = gfc_conv_descriptor_data_get (from_se.expr);
12845 : 113 : gfc_add_modify_loc (input_location, &block, tmp,
12846 : 113 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
12847 : :
12848 : :
12849 : 113 : if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
12850 : : {
12851 : 7 : gfc_add_modify_loc (input_location, &block, to_se.string_length,
12852 : 7 : fold_convert (TREE_TYPE (to_se.string_length),
12853 : : from_se.string_length));
12854 : 7 : if (from_expr->ts.deferred)
12855 : 6 : gfc_add_modify_loc (input_location, &block, from_se.string_length,
12856 : 6 : build_int_cst (TREE_TYPE (from_se.string_length), 0));
12857 : : }
12858 : :
12859 : 113 : return gfc_finish_block (&block);
12860 : : }
12861 : :
12862 : :
12863 : : tree
12864 : 5673 : gfc_conv_intrinsic_subroutine (gfc_code *code)
12865 : : {
12866 : 5673 : tree res;
12867 : :
12868 : 5673 : gcc_assert (code->resolved_isym);
12869 : :
12870 : 5673 : switch (code->resolved_isym->id)
12871 : : {
12872 : 216 : case GFC_ISYM_MOVE_ALLOC:
12873 : 216 : res = conv_intrinsic_move_alloc (code);
12874 : 216 : break;
12875 : :
12876 : 10 : case GFC_ISYM_ATOMIC_CAS:
12877 : 10 : res = conv_intrinsic_atomic_cas (code);
12878 : 10 : break;
12879 : :
12880 : 68 : case GFC_ISYM_ATOMIC_ADD:
12881 : 68 : case GFC_ISYM_ATOMIC_AND:
12882 : 68 : case GFC_ISYM_ATOMIC_DEF:
12883 : 68 : case GFC_ISYM_ATOMIC_OR:
12884 : 68 : case GFC_ISYM_ATOMIC_XOR:
12885 : 68 : case GFC_ISYM_ATOMIC_FETCH_ADD:
12886 : 68 : case GFC_ISYM_ATOMIC_FETCH_AND:
12887 : 68 : case GFC_ISYM_ATOMIC_FETCH_OR:
12888 : 68 : case GFC_ISYM_ATOMIC_FETCH_XOR:
12889 : 68 : res = conv_intrinsic_atomic_op (code);
12890 : 68 : break;
12891 : :
12892 : 119 : case GFC_ISYM_ATOMIC_REF:
12893 : 119 : res = conv_intrinsic_atomic_ref (code);
12894 : 119 : break;
12895 : :
12896 : 70 : case GFC_ISYM_EVENT_QUERY:
12897 : 70 : res = conv_intrinsic_event_query (code);
12898 : 70 : break;
12899 : :
12900 : 2542 : case GFC_ISYM_C_F_POINTER:
12901 : 2542 : case GFC_ISYM_C_F_PROCPOINTER:
12902 : 2542 : res = conv_isocbinding_subroutine (code);
12903 : 2542 : break;
12904 : :
12905 : 528 : case GFC_ISYM_CAF_SEND:
12906 : 528 : res = conv_caf_send (code);
12907 : 528 : break;
12908 : :
12909 : 63 : case GFC_ISYM_CO_BROADCAST:
12910 : 63 : case GFC_ISYM_CO_MIN:
12911 : 63 : case GFC_ISYM_CO_MAX:
12912 : 63 : case GFC_ISYM_CO_REDUCE:
12913 : 63 : case GFC_ISYM_CO_SUM:
12914 : 63 : res = conv_co_collective (code);
12915 : 63 : break;
12916 : :
12917 : 10 : case GFC_ISYM_FREE:
12918 : 10 : res = conv_intrinsic_free (code);
12919 : 10 : break;
12920 : :
12921 : 90 : case GFC_ISYM_RANDOM_INIT:
12922 : 90 : res = conv_intrinsic_random_init (code);
12923 : 90 : break;
12924 : :
12925 : 15 : case GFC_ISYM_KILL:
12926 : 15 : res = conv_intrinsic_kill_sub (code);
12927 : 15 : break;
12928 : :
12929 : : case GFC_ISYM_MVBITS:
12930 : : res = NULL_TREE;
12931 : : break;
12932 : :
12933 : 194 : case GFC_ISYM_SYSTEM_CLOCK:
12934 : 194 : res = conv_intrinsic_system_clock (code);
12935 : 194 : break;
12936 : :
12937 : : default:
12938 : : res = NULL_TREE;
12939 : : break;
12940 : : }
12941 : :
12942 : 5673 : return res;
12943 : : }
12944 : :
12945 : : #include "gt-fortran-trans-intrinsic.h"
|
