1 /* Intrinsic translation
2 Copyright (C) 2002-2019 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.c-- 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 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44
45 /* This maps Fortran intrinsic math functions to external library or GCC
46 builtin functions. */
47 typedef struct GTY(()) gfc_intrinsic_map_t {
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
50 enum gfc_isym_id id;
51
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in;
55 enum built_in_function double_built_in;
56 enum built_in_function long_double_built_in;
57 enum built_in_function complex_float_built_in;
58 enum built_in_function complex_double_built_in;
59 enum built_in_function complex_long_double_built_in;
60
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
64 bool libm_name;
65
66 /* True if a complex version of the function exists. */
67 bool complex_available;
68
69 /* True if the function should be marked const. */
70 bool is_constant;
71
72 /* The base library name of this function. */
73 const char *name;
74
75 /* Cache decls created for the various operand types. */
76 tree real4_decl;
77 tree real8_decl;
78 tree real10_decl;
79 tree real16_decl;
80 tree complex4_decl;
81 tree complex8_decl;
82 tree complex10_decl;
83 tree complex16_decl;
84 }
85 gfc_intrinsic_map_t;
86
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
89 except for atan2. */
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
95
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
101
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
107
108 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
113
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
115 {
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
120
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
123
124 /* End the list. */
125 LIB_FUNCTION (NONE, NULL, false)
126
127 };
128 #undef OTHER_BUILTIN
129 #undef LIB_FUNCTION
130 #undef DEFINE_MATH_BUILTIN
131 #undef DEFINE_MATH_BUILTIN_C
132
133
134 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
135
136
137 /* Find the correct variant of a given builtin from its argument. */
138 static tree
builtin_decl_for_precision(enum built_in_function base_built_in,int precision)139 builtin_decl_for_precision (enum built_in_function base_built_in,
140 int precision)
141 {
142 enum built_in_function i = END_BUILTINS;
143
144 gfc_intrinsic_map_t *m;
145 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
146 ;
147
148 if (precision == TYPE_PRECISION (float_type_node))
149 i = m->float_built_in;
150 else if (precision == TYPE_PRECISION (double_type_node))
151 i = m->double_built_in;
152 else if (precision == TYPE_PRECISION (long_double_type_node))
153 i = m->long_double_built_in;
154 else if (precision == TYPE_PRECISION (gfc_float128_type_node))
155 {
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m->real16_decl;
159 }
160
161 return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
162 }
163
164
165 tree
gfc_builtin_decl_for_float_kind(enum built_in_function double_built_in,int kind)166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
167 int kind)
168 {
169 int i = gfc_validate_kind (BT_REAL, kind, false);
170
171 if (gfc_real_kinds[i].c_float128)
172 {
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t *m;
176 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
177 ;
178
179 return m->real16_decl;
180 }
181
182 return builtin_decl_for_precision (double_built_in,
183 gfc_real_kinds[i].mode_precision);
184 }
185
186
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
191
192 static void
gfc_conv_intrinsic_function_args(gfc_se * se,gfc_expr * expr,tree * argarray,int nargs)193 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
194 tree *argarray, int nargs)
195 {
196 gfc_actual_arglist *actual;
197 gfc_expr *e;
198 gfc_intrinsic_arg *formal;
199 gfc_se argse;
200 int curr_arg;
201
202 formal = expr->value.function.isym->formal;
203 actual = expr->value.function.actual;
204
205 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
206 actual = actual->next,
207 formal = formal ? formal->next : NULL)
208 {
209 gcc_assert (actual);
210 e = actual->expr;
211 /* Skip omitted optional arguments. */
212 if (!e)
213 {
214 --curr_arg;
215 continue;
216 }
217
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse, se);
221
222 if (e->ts.type == BT_CHARACTER)
223 {
224 gfc_conv_expr (&argse, e);
225 gfc_conv_string_parameter (&argse);
226 argarray[curr_arg++] = argse.string_length;
227 gcc_assert (curr_arg < nargs);
228 }
229 else
230 gfc_conv_expr_val (&argse, e);
231
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e->expr_type == EXPR_VARIABLE
235 && e->symtree->n.sym->attr.optional
236 && formal
237 && formal->optional)
238 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
239
240 gfc_add_block_to_block (&se->pre, &argse.pre);
241 gfc_add_block_to_block (&se->post, &argse.post);
242 argarray[curr_arg] = argse.expr;
243 }
244 }
245
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
248
249 static unsigned int
gfc_intrinsic_argument_list_length(gfc_expr * expr)250 gfc_intrinsic_argument_list_length (gfc_expr *expr)
251 {
252 int n = 0;
253 gfc_actual_arglist *actual;
254
255 for (actual = expr->value.function.actual; actual; actual = actual->next)
256 {
257 if (!actual->expr)
258 continue;
259
260 if (actual->expr->ts.type == BT_CHARACTER)
261 n += 2;
262 else
263 n++;
264 }
265
266 return n;
267 }
268
269
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
272
273 static void
gfc_conv_intrinsic_conversion(gfc_se * se,gfc_expr * expr)274 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
275 {
276 tree type;
277 tree *args;
278 int nargs;
279
280 nargs = gfc_intrinsic_argument_list_length (expr);
281 args = XALLOCAVEC (tree, nargs);
282
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type = gfc_typenode_for_spec (&expr->ts);
287 gcc_assert (expr->value.function.actual->expr);
288 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
289
290 /* Conversion between character kinds involves a call to a library
291 function. */
292 if (expr->ts.type == BT_CHARACTER)
293 {
294 tree fndecl, var, addr, tmp;
295
296 if (expr->ts.kind == 1
297 && expr->value.function.actual->expr->ts.kind == 4)
298 fndecl = gfor_fndecl_convert_char4_to_char1;
299 else if (expr->ts.kind == 4
300 && expr->value.function.actual->expr->ts.kind == 1)
301 fndecl = gfor_fndecl_convert_char1_to_char4;
302 else
303 gcc_unreachable ();
304
305 /* Create the variable storing the converted value. */
306 type = gfc_get_pchar_type (expr->ts.kind);
307 var = gfc_create_var (type, "str");
308 addr = gfc_build_addr_expr (build_pointer_type (type), var);
309
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs >= 2);
312 tmp = build_call_expr_loc (input_location,
313 fndecl, 3, addr, args[0], args[1]);
314 gfc_add_expr_to_block (&se->pre, tmp);
315
316 /* Free the temporary afterwards. */
317 tmp = gfc_call_free (var);
318 gfc_add_expr_to_block (&se->post, tmp);
319
320 se->expr = var;
321 se->string_length = args[0];
322
323 return;
324 }
325
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
329 && expr->ts.type != BT_COMPLEX)
330 {
331 tree artype;
332
333 artype = TREE_TYPE (TREE_TYPE (args[0]));
334 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
335 args[0]);
336 }
337
338 se->expr = convert (type, args[0]);
339 }
340
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
345
346 static tree
build_fixbound_expr(stmtblock_t * pblock,tree arg,tree type,int up)347 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
348 {
349 tree tmp;
350 tree cond;
351 tree argtype;
352 tree intval;
353
354 argtype = TREE_TYPE (arg);
355 arg = gfc_evaluate_now (arg, pblock);
356
357 intval = convert (type, arg);
358 intval = gfc_evaluate_now (intval, pblock);
359
360 tmp = convert (argtype, intval);
361 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
362 logical_type_node, tmp, arg);
363
364 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
365 intval, build_int_cst (type, 1));
366 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
367 return tmp;
368 }
369
370
371 /* Round to nearest integer, away from zero. */
372
373 static tree
build_round_expr(tree arg,tree restype)374 build_round_expr (tree arg, tree restype)
375 {
376 tree argtype;
377 tree fn;
378 int argprec, resprec;
379
380 argtype = TREE_TYPE (arg);
381 argprec = TYPE_PRECISION (argtype);
382 resprec = TYPE_PRECISION (restype);
383
384 /* Depending on the type of the result, choose the int intrinsic
385 (iround, available only as a builtin, therefore cannot use it for
386 __float128), long int intrinsic (lround family) or long long
387 intrinsic (llround). We might also need to convert the result
388 afterwards. */
389 if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
390 fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
391 else if (resprec <= LONG_TYPE_SIZE)
392 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
393 else if (resprec <= LONG_LONG_TYPE_SIZE)
394 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
395 else
396 gcc_unreachable ();
397
398 return fold_convert (restype, build_call_expr_loc (input_location,
399 fn, 1, arg));
400 }
401
402
403 /* Convert a real to an integer using a specific rounding mode.
404 Ideally we would just build the corresponding GENERIC node,
405 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
406
407 static tree
build_fix_expr(stmtblock_t * pblock,tree arg,tree type,enum rounding_mode op)408 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
409 enum rounding_mode op)
410 {
411 switch (op)
412 {
413 case RND_FLOOR:
414 return build_fixbound_expr (pblock, arg, type, 0);
415
416 case RND_CEIL:
417 return build_fixbound_expr (pblock, arg, type, 1);
418
419 case RND_ROUND:
420 return build_round_expr (arg, type);
421
422 case RND_TRUNC:
423 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
424
425 default:
426 gcc_unreachable ();
427 }
428 }
429
430
431 /* Round a real value using the specified rounding mode.
432 We use a temporary integer of that same kind size as the result.
433 Values larger than those that can be represented by this kind are
434 unchanged, as they will not be accurate enough to represent the
435 rounding.
436 huge = HUGE (KIND (a))
437 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
438 */
439
440 static void
gfc_conv_intrinsic_aint(gfc_se * se,gfc_expr * expr,enum rounding_mode op)441 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
442 {
443 tree type;
444 tree itype;
445 tree arg[2];
446 tree tmp;
447 tree cond;
448 tree decl;
449 mpfr_t huge;
450 int n, nargs;
451 int kind;
452
453 kind = expr->ts.kind;
454 nargs = gfc_intrinsic_argument_list_length (expr);
455
456 decl = NULL_TREE;
457 /* We have builtin functions for some cases. */
458 switch (op)
459 {
460 case RND_ROUND:
461 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
462 break;
463
464 case RND_TRUNC:
465 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
466 break;
467
468 default:
469 gcc_unreachable ();
470 }
471
472 /* Evaluate the argument. */
473 gcc_assert (expr->value.function.actual->expr);
474 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
475
476 /* Use a builtin function if one exists. */
477 if (decl != NULL_TREE)
478 {
479 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
480 return;
481 }
482
483 /* This code is probably redundant, but we'll keep it lying around just
484 in case. */
485 type = gfc_typenode_for_spec (&expr->ts);
486 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
487
488 /* Test if the value is too large to handle sensibly. */
489 gfc_set_model_kind (kind);
490 mpfr_init (huge);
491 n = gfc_validate_kind (BT_INTEGER, kind, false);
492 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
493 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
494 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
495 tmp);
496
497 mpfr_neg (huge, huge, GFC_RND_MODE);
498 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
499 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
500 tmp);
501 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
502 cond, tmp);
503 itype = gfc_get_int_type (kind);
504
505 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
506 tmp = convert (type, tmp);
507 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
508 arg[0]);
509 mpfr_clear (huge);
510 }
511
512
513 /* Convert to an integer using the specified rounding mode. */
514
515 static void
gfc_conv_intrinsic_int(gfc_se * se,gfc_expr * expr,enum rounding_mode op)516 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
517 {
518 tree type;
519 tree *args;
520 int nargs;
521
522 nargs = gfc_intrinsic_argument_list_length (expr);
523 args = XALLOCAVEC (tree, nargs);
524
525 /* Evaluate the argument, we process all arguments even though we only
526 use the first one for code generation purposes. */
527 type = gfc_typenode_for_spec (&expr->ts);
528 gcc_assert (expr->value.function.actual->expr);
529 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
530
531 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
532 {
533 /* Conversion to a different integer kind. */
534 se->expr = convert (type, args[0]);
535 }
536 else
537 {
538 /* Conversion from complex to non-complex involves taking the real
539 component of the value. */
540 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
541 && expr->ts.type != BT_COMPLEX)
542 {
543 tree artype;
544
545 artype = TREE_TYPE (TREE_TYPE (args[0]));
546 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
547 args[0]);
548 }
549
550 se->expr = build_fix_expr (&se->pre, args[0], type, op);
551 }
552 }
553
554
555 /* Get the imaginary component of a value. */
556
557 static void
gfc_conv_intrinsic_imagpart(gfc_se * se,gfc_expr * expr)558 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
559 {
560 tree arg;
561
562 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
563 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
564 TREE_TYPE (TREE_TYPE (arg)), arg);
565 }
566
567
568 /* Get the complex conjugate of a value. */
569
570 static void
gfc_conv_intrinsic_conjg(gfc_se * se,gfc_expr * expr)571 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
572 {
573 tree arg;
574
575 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
576 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
577 }
578
579
580
581 static tree
define_quad_builtin(const char * name,tree type,bool is_const)582 define_quad_builtin (const char *name, tree type, bool is_const)
583 {
584 tree fndecl;
585 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
586 type);
587
588 /* Mark the decl as external. */
589 DECL_EXTERNAL (fndecl) = 1;
590 TREE_PUBLIC (fndecl) = 1;
591
592 /* Mark it __attribute__((const)). */
593 TREE_READONLY (fndecl) = is_const;
594
595 rest_of_decl_compilation (fndecl, 1, 0);
596
597 return fndecl;
598 }
599
600 /* Add SIMD attribute for FNDECL built-in if the built-in
601 name is in VECTORIZED_BUILTINS. */
602
603 static void
add_simd_flag_for_built_in(tree fndecl)604 add_simd_flag_for_built_in (tree fndecl)
605 {
606 if (gfc_vectorized_builtins == NULL
607 || fndecl == NULL_TREE)
608 return;
609
610 const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
611 int *clauses = gfc_vectorized_builtins->get (name);
612 if (clauses)
613 {
614 for (unsigned i = 0; i < 3; i++)
615 if (*clauses & (1 << i))
616 {
617 gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
618 tree omp_clause = NULL_TREE;
619 if (simd_type == SIMD_NONE)
620 ; /* No SIMD clause. */
621 else
622 {
623 omp_clause_code code
624 = (simd_type == SIMD_INBRANCH
625 ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
626 omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
627 omp_clause = build_tree_list (NULL_TREE, omp_clause);
628 }
629
630 DECL_ATTRIBUTES (fndecl)
631 = tree_cons (get_identifier ("omp declare simd"), omp_clause,
632 DECL_ATTRIBUTES (fndecl));
633 }
634 }
635 }
636
637 /* Set SIMD attribute to all built-in functions that are mentioned
638 in gfc_vectorized_builtins vector. */
639
640 void
gfc_adjust_builtins(void)641 gfc_adjust_builtins (void)
642 {
643 gfc_intrinsic_map_t *m;
644 for (m = gfc_intrinsic_map;
645 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
646 {
647 add_simd_flag_for_built_in (m->real4_decl);
648 add_simd_flag_for_built_in (m->complex4_decl);
649 add_simd_flag_for_built_in (m->real8_decl);
650 add_simd_flag_for_built_in (m->complex8_decl);
651 add_simd_flag_for_built_in (m->real10_decl);
652 add_simd_flag_for_built_in (m->complex10_decl);
653 add_simd_flag_for_built_in (m->real16_decl);
654 add_simd_flag_for_built_in (m->complex16_decl);
655 add_simd_flag_for_built_in (m->real16_decl);
656 add_simd_flag_for_built_in (m->complex16_decl);
657 }
658
659 /* Release all strings. */
660 if (gfc_vectorized_builtins != NULL)
661 {
662 for (hash_map<nofree_string_hash, int>::iterator it
663 = gfc_vectorized_builtins->begin ();
664 it != gfc_vectorized_builtins->end (); ++it)
665 free (CONST_CAST (char *, (*it).first));
666
667 delete gfc_vectorized_builtins;
668 gfc_vectorized_builtins = NULL;
669 }
670 }
671
672 /* Initialize function decls for library functions. The external functions
673 are created as required. Builtin functions are added here. */
674
675 void
gfc_build_intrinsic_lib_fndecls(void)676 gfc_build_intrinsic_lib_fndecls (void)
677 {
678 gfc_intrinsic_map_t *m;
679 tree quad_decls[END_BUILTINS + 1];
680
681 if (gfc_real16_is_float128)
682 {
683 /* If we have soft-float types, we create the decls for their
684 C99-like library functions. For now, we only handle __float128
685 q-suffixed functions. */
686
687 tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
688 tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
689
690 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
691
692 type = gfc_float128_type_node;
693 complex_type = gfc_complex_float128_type_node;
694 /* type (*) (type) */
695 func_1 = build_function_type_list (type, type, NULL_TREE);
696 /* int (*) (type) */
697 func_iround = build_function_type_list (integer_type_node,
698 type, NULL_TREE);
699 /* long (*) (type) */
700 func_lround = build_function_type_list (long_integer_type_node,
701 type, NULL_TREE);
702 /* long long (*) (type) */
703 func_llround = build_function_type_list (long_long_integer_type_node,
704 type, NULL_TREE);
705 /* type (*) (type, type) */
706 func_2 = build_function_type_list (type, type, type, NULL_TREE);
707 /* type (*) (type, &int) */
708 func_frexp
709 = build_function_type_list (type,
710 type,
711 build_pointer_type (integer_type_node),
712 NULL_TREE);
713 /* type (*) (type, int) */
714 func_scalbn = build_function_type_list (type,
715 type, integer_type_node, NULL_TREE);
716 /* type (*) (complex type) */
717 func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
718 /* complex type (*) (complex type, complex type) */
719 func_cpow
720 = build_function_type_list (complex_type,
721 complex_type, complex_type, NULL_TREE);
722
723 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
724 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
725 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
726
727 /* Only these built-ins are actually needed here. These are used directly
728 from the code, when calling builtin_decl_for_precision() or
729 builtin_decl_for_float_type(). The others are all constructed by
730 gfc_get_intrinsic_lib_fndecl(). */
731 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
732 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
733
734 #include "mathbuiltins.def"
735
736 #undef OTHER_BUILTIN
737 #undef LIB_FUNCTION
738 #undef DEFINE_MATH_BUILTIN
739 #undef DEFINE_MATH_BUILTIN_C
740
741 /* There is one built-in we defined manually, because it gets called
742 with builtin_decl_for_precision() or builtin_decl_for_float_type()
743 even though it is not an OTHER_BUILTIN: it is SQRT. */
744 quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true);
745
746 }
747
748 /* Add GCC builtin functions. */
749 for (m = gfc_intrinsic_map;
750 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
751 {
752 if (m->float_built_in != END_BUILTINS)
753 m->real4_decl = builtin_decl_explicit (m->float_built_in);
754 if (m->complex_float_built_in != END_BUILTINS)
755 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
756 if (m->double_built_in != END_BUILTINS)
757 m->real8_decl = builtin_decl_explicit (m->double_built_in);
758 if (m->complex_double_built_in != END_BUILTINS)
759 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
760
761 /* If real(kind=10) exists, it is always long double. */
762 if (m->long_double_built_in != END_BUILTINS)
763 m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
764 if (m->complex_long_double_built_in != END_BUILTINS)
765 m->complex10_decl
766 = builtin_decl_explicit (m->complex_long_double_built_in);
767
768 if (!gfc_real16_is_float128)
769 {
770 if (m->long_double_built_in != END_BUILTINS)
771 m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
772 if (m->complex_long_double_built_in != END_BUILTINS)
773 m->complex16_decl
774 = builtin_decl_explicit (m->complex_long_double_built_in);
775 }
776 else if (quad_decls[m->double_built_in] != NULL_TREE)
777 {
778 /* Quad-precision function calls are constructed when first
779 needed by builtin_decl_for_precision(), except for those
780 that will be used directly (define by OTHER_BUILTIN). */
781 m->real16_decl = quad_decls[m->double_built_in];
782 }
783 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
784 {
785 /* Same thing for the complex ones. */
786 m->complex16_decl = quad_decls[m->double_built_in];
787 }
788 }
789 }
790
791
792 /* Create a fndecl for a simple intrinsic library function. */
793
794 static tree
gfc_get_intrinsic_lib_fndecl(gfc_intrinsic_map_t * m,gfc_expr * expr)795 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
796 {
797 tree type;
798 vec<tree, va_gc> *argtypes;
799 tree fndecl;
800 gfc_actual_arglist *actual;
801 tree *pdecl;
802 gfc_typespec *ts;
803 char name[GFC_MAX_SYMBOL_LEN + 3];
804
805 ts = &expr->ts;
806 if (ts->type == BT_REAL)
807 {
808 switch (ts->kind)
809 {
810 case 4:
811 pdecl = &m->real4_decl;
812 break;
813 case 8:
814 pdecl = &m->real8_decl;
815 break;
816 case 10:
817 pdecl = &m->real10_decl;
818 break;
819 case 16:
820 pdecl = &m->real16_decl;
821 break;
822 default:
823 gcc_unreachable ();
824 }
825 }
826 else if (ts->type == BT_COMPLEX)
827 {
828 gcc_assert (m->complex_available);
829
830 switch (ts->kind)
831 {
832 case 4:
833 pdecl = &m->complex4_decl;
834 break;
835 case 8:
836 pdecl = &m->complex8_decl;
837 break;
838 case 10:
839 pdecl = &m->complex10_decl;
840 break;
841 case 16:
842 pdecl = &m->complex16_decl;
843 break;
844 default:
845 gcc_unreachable ();
846 }
847 }
848 else
849 gcc_unreachable ();
850
851 if (*pdecl)
852 return *pdecl;
853
854 if (m->libm_name)
855 {
856 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
857 if (gfc_real_kinds[n].c_float)
858 snprintf (name, sizeof (name), "%s%s%s",
859 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
860 else if (gfc_real_kinds[n].c_double)
861 snprintf (name, sizeof (name), "%s%s",
862 ts->type == BT_COMPLEX ? "c" : "", m->name);
863 else if (gfc_real_kinds[n].c_long_double)
864 snprintf (name, sizeof (name), "%s%s%s",
865 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
866 else if (gfc_real_kinds[n].c_float128)
867 snprintf (name, sizeof (name), "%s%s%s",
868 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
869 else
870 gcc_unreachable ();
871 }
872 else
873 {
874 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
875 ts->type == BT_COMPLEX ? 'c' : 'r',
876 ts->kind);
877 }
878
879 argtypes = NULL;
880 for (actual = expr->value.function.actual; actual; actual = actual->next)
881 {
882 type = gfc_typenode_for_spec (&actual->expr->ts);
883 vec_safe_push (argtypes, type);
884 }
885 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
886 fndecl = build_decl (input_location,
887 FUNCTION_DECL, get_identifier (name), type);
888
889 /* Mark the decl as external. */
890 DECL_EXTERNAL (fndecl) = 1;
891 TREE_PUBLIC (fndecl) = 1;
892
893 /* Mark it __attribute__((const)), if possible. */
894 TREE_READONLY (fndecl) = m->is_constant;
895
896 rest_of_decl_compilation (fndecl, 1, 0);
897
898 (*pdecl) = fndecl;
899 return fndecl;
900 }
901
902
903 /* Convert an intrinsic function into an external or builtin call. */
904
905 static void
gfc_conv_intrinsic_lib_function(gfc_se * se,gfc_expr * expr)906 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
907 {
908 gfc_intrinsic_map_t *m;
909 tree fndecl;
910 tree rettype;
911 tree *args;
912 unsigned int num_args;
913 gfc_isym_id id;
914
915 id = expr->value.function.isym->id;
916 /* Find the entry for this function. */
917 for (m = gfc_intrinsic_map;
918 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
919 {
920 if (id == m->id)
921 break;
922 }
923
924 if (m->id == GFC_ISYM_NONE)
925 {
926 gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
927 expr->value.function.name, id);
928 }
929
930 /* Get the decl and generate the call. */
931 num_args = gfc_intrinsic_argument_list_length (expr);
932 args = XALLOCAVEC (tree, num_args);
933
934 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
935 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
936 rettype = TREE_TYPE (TREE_TYPE (fndecl));
937
938 fndecl = build_addr (fndecl);
939 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
940 }
941
942
943 /* If bounds-checking is enabled, create code to verify at runtime that the
944 string lengths for both expressions are the same (needed for e.g. MERGE).
945 If bounds-checking is not enabled, does nothing. */
946
947 void
gfc_trans_same_strlen_check(const char * intr_name,locus * where,tree a,tree b,stmtblock_t * target)948 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
949 tree a, tree b, stmtblock_t* target)
950 {
951 tree cond;
952 tree name;
953
954 /* If bounds-checking is disabled, do nothing. */
955 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
956 return;
957
958 /* Compare the two string lengths. */
959 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
960
961 /* Output the runtime-check. */
962 name = gfc_build_cstring_const (intr_name);
963 name = gfc_build_addr_expr (pchar_type_node, name);
964 gfc_trans_runtime_check (true, false, cond, target, where,
965 "Unequal character lengths (%ld/%ld) in %s",
966 fold_convert (long_integer_type_node, a),
967 fold_convert (long_integer_type_node, b), name);
968 }
969
970
971 /* The EXPONENT(X) intrinsic function is translated into
972 int ret;
973 return isfinite(X) ? (frexp (X, &ret) , ret) : huge
974 so that if X is a NaN or infinity, the result is HUGE(0).
975 */
976
977 static void
gfc_conv_intrinsic_exponent(gfc_se * se,gfc_expr * expr)978 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
979 {
980 tree arg, type, res, tmp, frexp, cond, huge;
981 int i;
982
983 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
984 expr->value.function.actual->expr->ts.kind);
985
986 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
987 arg = gfc_evaluate_now (arg, &se->pre);
988
989 i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
990 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
991 cond = build_call_expr_loc (input_location,
992 builtin_decl_explicit (BUILT_IN_ISFINITE),
993 1, arg);
994
995 res = gfc_create_var (integer_type_node, NULL);
996 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
997 gfc_build_addr_expr (NULL_TREE, res));
998 tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
999 tmp, res);
1000 se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
1001 cond, tmp, huge);
1002
1003 type = gfc_typenode_for_spec (&expr->ts);
1004 se->expr = fold_convert (type, se->expr);
1005 }
1006
1007
1008 /* Fill in the following structure
1009 struct caf_vector_t {
1010 size_t nvec; // size of the vector
1011 union {
1012 struct {
1013 void *vector;
1014 int kind;
1015 } v;
1016 struct {
1017 ptrdiff_t lower_bound;
1018 ptrdiff_t upper_bound;
1019 ptrdiff_t stride;
1020 } triplet;
1021 } u;
1022 } */
1023
1024 static void
conv_caf_vector_subscript_elem(stmtblock_t * block,int i,tree desc,tree lower,tree upper,tree stride,tree vector,int kind,tree nvec)1025 conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
1026 tree lower, tree upper, tree stride,
1027 tree vector, int kind, tree nvec)
1028 {
1029 tree field, type, tmp;
1030
1031 desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
1032 type = TREE_TYPE (desc);
1033
1034 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1035 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1036 desc, field, NULL_TREE);
1037 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
1038
1039 /* Access union. */
1040 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1041 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1042 desc, field, NULL_TREE);
1043 type = TREE_TYPE (desc);
1044
1045 /* Access the inner struct. */
1046 field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
1047 desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1048 desc, field, NULL_TREE);
1049 type = TREE_TYPE (desc);
1050
1051 if (vector != NULL_TREE)
1052 {
1053 /* Set vector and kind. */
1054 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1055 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1056 desc, field, NULL_TREE);
1057 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
1058 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1059 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1060 desc, field, NULL_TREE);
1061 gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
1062 }
1063 else
1064 {
1065 /* Set dim.lower/upper/stride. */
1066 field = gfc_advance_chain (TYPE_FIELDS (type), 0);
1067 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1068 desc, field, NULL_TREE);
1069 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
1070
1071 field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1072 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1073 desc, field, NULL_TREE);
1074 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
1075
1076 field = gfc_advance_chain (TYPE_FIELDS (type), 2);
1077 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1078 desc, field, NULL_TREE);
1079 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
1080 }
1081 }
1082
1083
1084 static tree
conv_caf_vector_subscript(stmtblock_t * block,tree desc,gfc_array_ref * ar)1085 conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
1086 {
1087 gfc_se argse;
1088 tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
1089 tree lbound, ubound, tmp;
1090 int i;
1091
1092 var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
1093
1094 for (i = 0; i < ar->dimen; i++)
1095 switch (ar->dimen_type[i])
1096 {
1097 case DIMEN_RANGE:
1098 if (ar->end[i])
1099 {
1100 gfc_init_se (&argse, NULL);
1101 gfc_conv_expr (&argse, ar->end[i]);
1102 gfc_add_block_to_block (block, &argse.pre);
1103 upper = gfc_evaluate_now (argse.expr, block);
1104 }
1105 else
1106 upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1107 if (ar->stride[i])
1108 {
1109 gfc_init_se (&argse, NULL);
1110 gfc_conv_expr (&argse, ar->stride[i]);
1111 gfc_add_block_to_block (block, &argse.pre);
1112 stride = gfc_evaluate_now (argse.expr, block);
1113 }
1114 else
1115 stride = gfc_index_one_node;
1116
1117 /* Fall through. */
1118 case DIMEN_ELEMENT:
1119 if (ar->start[i])
1120 {
1121 gfc_init_se (&argse, NULL);
1122 gfc_conv_expr (&argse, ar->start[i]);
1123 gfc_add_block_to_block (block, &argse.pre);
1124 lower = gfc_evaluate_now (argse.expr, block);
1125 }
1126 else
1127 lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1128 if (ar->dimen_type[i] == DIMEN_ELEMENT)
1129 {
1130 upper = lower;
1131 stride = gfc_index_one_node;
1132 }
1133 vector = NULL_TREE;
1134 nvec = size_zero_node;
1135 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1136 vector, 0, nvec);
1137 break;
1138
1139 case DIMEN_VECTOR:
1140 gfc_init_se (&argse, NULL);
1141 argse.descriptor_only = 1;
1142 gfc_conv_expr_descriptor (&argse, ar->start[i]);
1143 gfc_add_block_to_block (block, &argse.pre);
1144 vector = argse.expr;
1145 lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
1146 ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
1147 nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1148 tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
1149 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1150 TREE_TYPE (nvec), nvec, tmp);
1151 lower = gfc_index_zero_node;
1152 upper = gfc_index_zero_node;
1153 stride = gfc_index_zero_node;
1154 vector = gfc_conv_descriptor_data_get (vector);
1155 conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1156 vector, ar->start[i]->ts.kind, nvec);
1157 break;
1158 default:
1159 gcc_unreachable();
1160 }
1161 return gfc_build_addr_expr (NULL_TREE, var);
1162 }
1163
1164
1165 static tree
compute_component_offset(tree field,tree type)1166 compute_component_offset (tree field, tree type)
1167 {
1168 tree tmp;
1169 if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
1170 && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
1171 {
1172 tmp = fold_build2 (TRUNC_DIV_EXPR, type,
1173 DECL_FIELD_BIT_OFFSET (field),
1174 bitsize_unit_node);
1175 return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
1176 }
1177 else
1178 return DECL_FIELD_OFFSET (field);
1179 }
1180
1181
1182 static tree
conv_expr_ref_to_caf_ref(stmtblock_t * block,gfc_expr * expr)1183 conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
1184 {
1185 gfc_ref *ref = expr->ref, *last_comp_ref;
1186 tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
1187 field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
1188 start, end, stride, vector, nvec;
1189 gfc_se se;
1190 bool ref_static_array = false;
1191 tree last_component_ref_tree = NULL_TREE;
1192 int i, last_type_n;
1193
1194 if (expr->symtree)
1195 {
1196 last_component_ref_tree = expr->symtree->n.sym->backend_decl;
1197 ref_static_array = !expr->symtree->n.sym->attr.allocatable
1198 && !expr->symtree->n.sym->attr.pointer;
1199 }
1200
1201 /* Prevent uninit-warning. */
1202 reference_type = NULL_TREE;
1203
1204 /* Skip refs upto the first coarray-ref. */
1205 last_comp_ref = NULL;
1206 while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
1207 {
1208 /* Remember the type of components skipped. */
1209 if (ref->type == REF_COMPONENT)
1210 last_comp_ref = ref;
1211 ref = ref->next;
1212 }
1213 /* When a component was skipped, get the type information of the last
1214 component ref, else get the type from the symbol. */
1215 if (last_comp_ref)
1216 {
1217 last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
1218 last_type_n = last_comp_ref->u.c.component->ts.type;
1219 }
1220 else
1221 {
1222 last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
1223 last_type_n = expr->symtree->n.sym->ts.type;
1224 }
1225
1226 while (ref)
1227 {
1228 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
1229 && ref->u.ar.dimen == 0)
1230 {
1231 /* Skip pure coindexes. */
1232 ref = ref->next;
1233 continue;
1234 }
1235 tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1236 reference_type = TREE_TYPE (tmp);
1237
1238 if (caf_ref == NULL_TREE)
1239 caf_ref = tmp;
1240
1241 /* Construct the chain of refs. */
1242 if (prev_caf_ref != NULL_TREE)
1243 {
1244 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1245 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1246 TREE_TYPE (field), prev_caf_ref, field,
1247 NULL_TREE);
1248 gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
1249 tmp));
1250 }
1251 prev_caf_ref = tmp;
1252
1253 switch (ref->type)
1254 {
1255 case REF_COMPONENT:
1256 last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
1257 last_type_n = ref->u.c.component->ts.type;
1258 /* Set the type of the ref. */
1259 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1260 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1261 TREE_TYPE (field), prev_caf_ref, field,
1262 NULL_TREE);
1263 gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1264 GFC_CAF_REF_COMPONENT));
1265
1266 /* Ref the c in union u. */
1267 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1268 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1269 TREE_TYPE (field), prev_caf_ref, field,
1270 NULL_TREE);
1271 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
1272 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1273 TREE_TYPE (field), tmp, field,
1274 NULL_TREE);
1275
1276 /* Set the offset. */
1277 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1278 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1279 TREE_TYPE (field), inner_struct, field,
1280 NULL_TREE);
1281 /* Computing the offset is somewhat harder. The bit_offset has to be
1282 taken into account. When the bit_offset in the field_decl is non-
1283 null, divide it by the bitsize_unit and add it to the regular
1284 offset. */
1285 tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
1286 TREE_TYPE (tmp));
1287 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1288
1289 /* Set caf_token_offset. */
1290 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
1291 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1292 TREE_TYPE (field), inner_struct, field,
1293 NULL_TREE);
1294 if ((ref->u.c.component->attr.allocatable
1295 || ref->u.c.component->attr.pointer)
1296 && ref->u.c.component->attr.dimension)
1297 {
1298 tree arr_desc_token_offset;
1299 /* Get the token field from the descriptor. */
1300 arr_desc_token_offset = TREE_OPERAND (
1301 gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1);
1302 arr_desc_token_offset
1303 = compute_component_offset (arr_desc_token_offset,
1304 TREE_TYPE (tmp));
1305 tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
1306 TREE_TYPE (tmp2), tmp2,
1307 arr_desc_token_offset);
1308 }
1309 else if (ref->u.c.component->caf_token)
1310 tmp2 = compute_component_offset (ref->u.c.component->caf_token,
1311 TREE_TYPE (tmp));
1312 else
1313 tmp2 = integer_zero_node;
1314 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1315
1316 /* Remember whether this ref was to a non-allocatable/non-pointer
1317 component so the next array ref can be tailored correctly. */
1318 ref_static_array = !ref->u.c.component->attr.allocatable
1319 && !ref->u.c.component->attr.pointer;
1320 last_component_ref_tree = ref_static_array
1321 ? ref->u.c.component->backend_decl : NULL_TREE;
1322 break;
1323 case REF_ARRAY:
1324 if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
1325 ref_static_array = false;
1326 /* Set the type of the ref. */
1327 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1328 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1329 TREE_TYPE (field), prev_caf_ref, field,
1330 NULL_TREE);
1331 gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1332 ref_static_array
1333 ? GFC_CAF_REF_STATIC_ARRAY
1334 : GFC_CAF_REF_ARRAY));
1335
1336 /* Ref the a in union u. */
1337 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1338 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1339 TREE_TYPE (field), prev_caf_ref, field,
1340 NULL_TREE);
1341 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
1342 inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1343 TREE_TYPE (field), tmp, field,
1344 NULL_TREE);
1345
1346 /* Set the static_array_type in a for static arrays. */
1347 if (ref_static_array)
1348 {
1349 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
1350 1);
1351 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1352 TREE_TYPE (field), inner_struct, field,
1353 NULL_TREE);
1354 gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
1355 last_type_n));
1356 }
1357 /* Ref the mode in the inner_struct. */
1358 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1359 mode = fold_build3_loc (input_location, COMPONENT_REF,
1360 TREE_TYPE (field), inner_struct, field,
1361 NULL_TREE);
1362 /* Ref the dim in the inner_struct. */
1363 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
1364 dim_array = fold_build3_loc (input_location, COMPONENT_REF,
1365 TREE_TYPE (field), inner_struct, field,
1366 NULL_TREE);
1367 for (i = 0; i < ref->u.ar.dimen; ++i)
1368 {
1369 /* Ref dim i. */
1370 dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
1371 dim_type = TREE_TYPE (dim);
1372 mode_rhs = start = end = stride = NULL_TREE;
1373 switch (ref->u.ar.dimen_type[i])
1374 {
1375 case DIMEN_RANGE:
1376 if (ref->u.ar.end[i])
1377 {
1378 gfc_init_se (&se, NULL);
1379 gfc_conv_expr (&se, ref->u.ar.end[i]);
1380 gfc_add_block_to_block (block, &se.pre);
1381 if (ref_static_array)
1382 {
1383 /* Make the index zero-based, when reffing a static
1384 array. */
1385 end = se.expr;
1386 gfc_init_se (&se, NULL);
1387 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1388 gfc_add_block_to_block (block, &se.pre);
1389 se.expr = fold_build2 (MINUS_EXPR,
1390 gfc_array_index_type,
1391 end, fold_convert (
1392 gfc_array_index_type,
1393 se.expr));
1394 }
1395 end = gfc_evaluate_now (fold_convert (
1396 gfc_array_index_type,
1397 se.expr),
1398 block);
1399 }
1400 else if (ref_static_array)
1401 end = fold_build2 (MINUS_EXPR,
1402 gfc_array_index_type,
1403 gfc_conv_array_ubound (
1404 last_component_ref_tree, i),
1405 gfc_conv_array_lbound (
1406 last_component_ref_tree, i));
1407 else
1408 {
1409 end = NULL_TREE;
1410 mode_rhs = build_int_cst (unsigned_char_type_node,
1411 GFC_CAF_ARR_REF_OPEN_END);
1412 }
1413 if (ref->u.ar.stride[i])
1414 {
1415 gfc_init_se (&se, NULL);
1416 gfc_conv_expr (&se, ref->u.ar.stride[i]);
1417 gfc_add_block_to_block (block, &se.pre);
1418 stride = gfc_evaluate_now (fold_convert (
1419 gfc_array_index_type,
1420 se.expr),
1421 block);
1422 if (ref_static_array)
1423 {
1424 /* Make the index zero-based, when reffing a static
1425 array. */
1426 stride = fold_build2 (MULT_EXPR,
1427 gfc_array_index_type,
1428 gfc_conv_array_stride (
1429 last_component_ref_tree,
1430 i),
1431 stride);
1432 gcc_assert (end != NULL_TREE);
1433 /* Multiply with the product of array's stride and
1434 the step of the ref to a virtual upper bound.
1435 We cannot compute the actual upper bound here or
1436 the caflib would compute the extend
1437 incorrectly. */
1438 end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1439 end, gfc_conv_array_stride (
1440 last_component_ref_tree,
1441 i));
1442 end = gfc_evaluate_now (end, block);
1443 stride = gfc_evaluate_now (stride, block);
1444 }
1445 }
1446 else if (ref_static_array)
1447 {
1448 stride = gfc_conv_array_stride (last_component_ref_tree,
1449 i);
1450 end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1451 end, stride);
1452 end = gfc_evaluate_now (end, block);
1453 }
1454 else
1455 /* Always set a ref stride of one to make caflib's
1456 handling easier. */
1457 stride = gfc_index_one_node;
1458
1459 /* Fall through. */
1460 case DIMEN_ELEMENT:
1461 if (ref->u.ar.start[i])
1462 {
1463 gfc_init_se (&se, NULL);
1464 gfc_conv_expr (&se, ref->u.ar.start[i]);
1465 gfc_add_block_to_block (block, &se.pre);
1466 if (ref_static_array)
1467 {
1468 /* Make the index zero-based, when reffing a static
1469 array. */
1470 start = fold_convert (gfc_array_index_type, se.expr);
1471 gfc_init_se (&se, NULL);
1472 gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1473 gfc_add_block_to_block (block, &se.pre);
1474 se.expr = fold_build2 (MINUS_EXPR,
1475 gfc_array_index_type,
1476 start, fold_convert (
1477 gfc_array_index_type,
1478 se.expr));
1479 /* Multiply with the stride. */
1480 se.expr = fold_build2 (MULT_EXPR,
1481 gfc_array_index_type,
1482 se.expr,
1483 gfc_conv_array_stride (
1484 last_component_ref_tree,
1485 i));
1486 }
1487 start = gfc_evaluate_now (fold_convert (
1488 gfc_array_index_type,
1489 se.expr),
1490 block);
1491 if (mode_rhs == NULL_TREE)
1492 mode_rhs = build_int_cst (unsigned_char_type_node,
1493 ref->u.ar.dimen_type[i]
1494 == DIMEN_ELEMENT
1495 ? GFC_CAF_ARR_REF_SINGLE
1496 : GFC_CAF_ARR_REF_RANGE);
1497 }
1498 else if (ref_static_array)
1499 {
1500 start = integer_zero_node;
1501 mode_rhs = build_int_cst (unsigned_char_type_node,
1502 ref->u.ar.start[i] == NULL
1503 ? GFC_CAF_ARR_REF_FULL
1504 : GFC_CAF_ARR_REF_RANGE);
1505 }
1506 else if (end == NULL_TREE)
1507 mode_rhs = build_int_cst (unsigned_char_type_node,
1508 GFC_CAF_ARR_REF_FULL);
1509 else
1510 mode_rhs = build_int_cst (unsigned_char_type_node,
1511 GFC_CAF_ARR_REF_OPEN_START);
1512
1513 /* Ref the s in dim. */
1514 field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
1515 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1516 TREE_TYPE (field), dim, field,
1517 NULL_TREE);
1518
1519 /* Set start in s. */
1520 if (start != NULL_TREE)
1521 {
1522 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1523 0);
1524 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1525 TREE_TYPE (field), tmp, field,
1526 NULL_TREE);
1527 gfc_add_modify (block, tmp2,
1528 fold_convert (TREE_TYPE (tmp2), start));
1529 }
1530
1531 /* Set end in s. */
1532 if (end != NULL_TREE)
1533 {
1534 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1535 1);
1536 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1537 TREE_TYPE (field), tmp, field,
1538 NULL_TREE);
1539 gfc_add_modify (block, tmp2,
1540 fold_convert (TREE_TYPE (tmp2), end));
1541 }
1542
1543 /* Set end in s. */
1544 if (stride != NULL_TREE)
1545 {
1546 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1547 2);
1548 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1549 TREE_TYPE (field), tmp, field,
1550 NULL_TREE);
1551 gfc_add_modify (block, tmp2,
1552 fold_convert (TREE_TYPE (tmp2), stride));
1553 }
1554 break;
1555 case DIMEN_VECTOR:
1556 /* TODO: In case of static array. */
1557 gcc_assert (!ref_static_array);
1558 mode_rhs = build_int_cst (unsigned_char_type_node,
1559 GFC_CAF_ARR_REF_VECTOR);
1560 gfc_init_se (&se, NULL);
1561 se.descriptor_only = 1;
1562 gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
1563 gfc_add_block_to_block (block, &se.pre);
1564 vector = se.expr;
1565 tmp = gfc_conv_descriptor_lbound_get (vector,
1566 gfc_rank_cst[0]);
1567 tmp2 = gfc_conv_descriptor_ubound_get (vector,
1568 gfc_rank_cst[0]);
1569 nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL);
1570 tmp = gfc_conv_descriptor_stride_get (vector,
1571 gfc_rank_cst[0]);
1572 nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1573 TREE_TYPE (nvec), nvec, tmp);
1574 vector = gfc_conv_descriptor_data_get (vector);
1575
1576 /* Ref the v in dim. */
1577 field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
1578 tmp = fold_build3_loc (input_location, COMPONENT_REF,
1579 TREE_TYPE (field), dim, field,
1580 NULL_TREE);
1581
1582 /* Set vector in v. */
1583 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
1584 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1585 TREE_TYPE (field), tmp, field,
1586 NULL_TREE);
1587 gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1588 vector));
1589
1590 /* Set nvec in v. */
1591 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
1592 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1593 TREE_TYPE (field), tmp, field,
1594 NULL_TREE);
1595 gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1596 nvec));
1597
1598 /* Set kind in v. */
1599 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
1600 tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1601 TREE_TYPE (field), tmp, field,
1602 NULL_TREE);
1603 gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
1604 ref->u.ar.start[i]->ts.kind));
1605 break;
1606 default:
1607 gcc_unreachable ();
1608 }
1609 /* Set the mode for dim i. */
1610 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1611 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
1612 mode_rhs));
1613 }
1614
1615 /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
1616 if (i < GFC_MAX_DIMENSIONS)
1617 {
1618 tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1619 gfc_add_modify (block, tmp,
1620 build_int_cst (unsigned_char_type_node,
1621 GFC_CAF_ARR_REF_NONE));
1622 }
1623 break;
1624 default:
1625 gcc_unreachable ();
1626 }
1627
1628 /* Set the size of the current type. */
1629 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
1630 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1631 prev_caf_ref, field, NULL_TREE);
1632 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1633 TYPE_SIZE_UNIT (last_type)));
1634
1635 ref = ref->next;
1636 }
1637
1638 if (prev_caf_ref != NULL_TREE)
1639 {
1640 field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1641 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1642 prev_caf_ref, field, NULL_TREE);
1643 gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1644 null_pointer_node));
1645 }
1646 return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
1647 : NULL_TREE;
1648 }
1649
1650 /* Get data from a remote coarray. */
1651
1652 static void
gfc_conv_intrinsic_caf_get(gfc_se * se,gfc_expr * expr,tree lhs,tree lhs_kind,tree may_require_tmp,bool may_realloc,symbol_attribute * caf_attr)1653 gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
1654 tree may_require_tmp, bool may_realloc,
1655 symbol_attribute *caf_attr)
1656 {
1657 gfc_expr *array_expr, *tmp_stat;
1658 gfc_se argse;
1659 tree caf_decl, token, offset, image_index, tmp;
1660 tree res_var, dst_var, type, kind, vec, stat;
1661 tree caf_reference;
1662 symbol_attribute caf_attr_store;
1663
1664 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1665
1666 if (se->ss && se->ss->info->useflags)
1667 {
1668 /* Access the previously obtained result. */
1669 gfc_conv_tmp_array_ref (se);
1670 return;
1671 }
1672
1673 /* If lhs is set, the CAF_GET intrinsic has already been stripped. */
1674 array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
1675 type = gfc_typenode_for_spec (&array_expr->ts);
1676
1677 if (caf_attr == NULL)
1678 {
1679 caf_attr_store = gfc_caf_attr (array_expr);
1680 caf_attr = &caf_attr_store;
1681 }
1682
1683 res_var = lhs;
1684 dst_var = lhs;
1685
1686 vec = null_pointer_node;
1687 tmp_stat = gfc_find_stat_co (expr);
1688
1689 if (tmp_stat)
1690 {
1691 gfc_se stat_se;
1692 gfc_init_se (&stat_se, NULL);
1693 gfc_conv_expr_reference (&stat_se, tmp_stat);
1694 stat = stat_se.expr;
1695 gfc_add_block_to_block (&se->pre, &stat_se.pre);
1696 gfc_add_block_to_block (&se->post, &stat_se.post);
1697 }
1698 else
1699 stat = null_pointer_node;
1700
1701 /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs
1702 is reallocatable or the right-hand side has allocatable components. */
1703 if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
1704 {
1705 /* Get using caf_get_by_ref. */
1706 caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
1707
1708 if (caf_reference != NULL_TREE)
1709 {
1710 if (lhs == NULL_TREE)
1711 {
1712 if (array_expr->ts.type == BT_CHARACTER)
1713 gfc_init_se (&argse, NULL);
1714 if (array_expr->rank == 0)
1715 {
1716 symbol_attribute attr;
1717 gfc_clear_attr (&attr);
1718 if (array_expr->ts.type == BT_CHARACTER)
1719 {
1720 res_var = gfc_conv_string_tmp (se,
1721 build_pointer_type (type),
1722 array_expr->ts.u.cl->backend_decl);
1723 argse.string_length = array_expr->ts.u.cl->backend_decl;
1724 }
1725 else
1726 res_var = gfc_create_var (type, "caf_res");
1727 dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
1728 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1729 }
1730 else
1731 {
1732 /* Create temporary. */
1733 if (array_expr->ts.type == BT_CHARACTER)
1734 gfc_conv_expr_descriptor (&argse, array_expr);
1735 may_realloc = gfc_trans_create_temp_array (&se->pre,
1736 &se->post,
1737 se->ss, type,
1738 NULL_TREE, false,
1739 false, false,
1740 &array_expr->where)
1741 == NULL_TREE;
1742 res_var = se->ss->info->data.array.descriptor;
1743 dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1744 if (may_realloc)
1745 {
1746 tmp = gfc_conv_descriptor_data_get (res_var);
1747 tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
1748 NULL_TREE, NULL_TREE,
1749 NULL_TREE, true,
1750 NULL,
1751 GFC_CAF_COARRAY_NOCOARRAY);
1752 gfc_add_expr_to_block (&se->post, tmp);
1753 }
1754 }
1755 }
1756
1757 kind = build_int_cst (integer_type_node, expr->ts.kind);
1758 if (lhs_kind == NULL_TREE)
1759 lhs_kind = kind;
1760
1761 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1762 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1763 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1764 image_index = gfc_caf_get_image_index (&se->pre, array_expr,
1765 caf_decl);
1766 gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
1767 array_expr);
1768
1769 /* No overlap possible as we have generated a temporary. */
1770 if (lhs == NULL_TREE)
1771 may_require_tmp = boolean_false_node;
1772
1773 /* It guarantees memory consistency within the same segment. */
1774 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1775 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1776 gfc_build_string_const (1, ""), NULL_TREE,
1777 NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE),
1778 NULL_TREE);
1779 ASM_VOLATILE_P (tmp) = 1;
1780 gfc_add_expr_to_block (&se->pre, tmp);
1781
1782 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
1783 10, token, image_index, dst_var,
1784 caf_reference, lhs_kind, kind,
1785 may_require_tmp,
1786 may_realloc ? boolean_true_node :
1787 boolean_false_node,
1788 stat, build_int_cst (integer_type_node,
1789 array_expr->ts.type));
1790
1791 gfc_add_expr_to_block (&se->pre, tmp);
1792
1793 if (se->ss)
1794 gfc_advance_se_ss_chain (se);
1795
1796 se->expr = res_var;
1797 if (array_expr->ts.type == BT_CHARACTER)
1798 se->string_length = argse.string_length;
1799
1800 return;
1801 }
1802 }
1803
1804 gfc_init_se (&argse, NULL);
1805 if (array_expr->rank == 0)
1806 {
1807 symbol_attribute attr;
1808
1809 gfc_clear_attr (&attr);
1810 gfc_conv_expr (&argse, array_expr);
1811
1812 if (lhs == NULL_TREE)
1813 {
1814 gfc_clear_attr (&attr);
1815 if (array_expr->ts.type == BT_CHARACTER)
1816 res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
1817 argse.string_length);
1818 else
1819 res_var = gfc_create_var (type, "caf_res");
1820 dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
1821 dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1822 }
1823 argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
1824 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1825 }
1826 else
1827 {
1828 /* If has_vector, pass descriptor for whole array and the
1829 vector bounds separately. */
1830 gfc_array_ref *ar, ar2;
1831 bool has_vector = false;
1832
1833 if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
1834 {
1835 has_vector = true;
1836 ar = gfc_find_array_ref (expr);
1837 ar2 = *ar;
1838 memset (ar, '\0', sizeof (*ar));
1839 ar->as = ar2.as;
1840 ar->type = AR_FULL;
1841 }
1842 // TODO: Check whether argse.want_coarray = 1 can help with the below.
1843 gfc_conv_expr_descriptor (&argse, array_expr);
1844 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1845 has the wrong type if component references are done. */
1846 gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
1847 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1848 : array_expr->rank,
1849 type));
1850 if (has_vector)
1851 {
1852 vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
1853 *ar = ar2;
1854 }
1855
1856 if (lhs == NULL_TREE)
1857 {
1858 /* Create temporary. */
1859 for (int n = 0; n < se->ss->loop->dimen; n++)
1860 if (se->loop->to[n] == NULL_TREE)
1861 {
1862 se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
1863 gfc_rank_cst[n]);
1864 se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
1865 gfc_rank_cst[n]);
1866 }
1867 gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
1868 NULL_TREE, false, true, false,
1869 &array_expr->where);
1870 res_var = se->ss->info->data.array.descriptor;
1871 dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1872 }
1873 argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1874 }
1875
1876 kind = build_int_cst (integer_type_node, expr->ts.kind);
1877 if (lhs_kind == NULL_TREE)
1878 lhs_kind = kind;
1879
1880 gfc_add_block_to_block (&se->pre, &argse.pre);
1881 gfc_add_block_to_block (&se->post, &argse.post);
1882
1883 caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1884 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1885 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1886 image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1887 gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
1888 array_expr);
1889
1890 /* No overlap possible as we have generated a temporary. */
1891 if (lhs == NULL_TREE)
1892 may_require_tmp = boolean_false_node;
1893
1894 /* It guarantees memory consistency within the same segment. */
1895 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1896 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1897 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1898 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1899 ASM_VOLATILE_P (tmp) = 1;
1900 gfc_add_expr_to_block (&se->pre, tmp);
1901
1902 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
1903 token, offset, image_index, argse.expr, vec,
1904 dst_var, kind, lhs_kind, may_require_tmp, stat);
1905
1906 gfc_add_expr_to_block (&se->pre, tmp);
1907
1908 if (se->ss)
1909 gfc_advance_se_ss_chain (se);
1910
1911 se->expr = res_var;
1912 if (array_expr->ts.type == BT_CHARACTER)
1913 se->string_length = argse.string_length;
1914 }
1915
1916
1917 /* Send data to a remote coarray. */
1918
1919 static tree
conv_caf_send(gfc_code * code)1920 conv_caf_send (gfc_code *code) {
1921 gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
1922 gfc_se lhs_se, rhs_se;
1923 stmtblock_t block;
1924 tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
1925 tree may_require_tmp, src_stat, dst_stat, dst_team;
1926 tree lhs_type = NULL_TREE;
1927 tree vec = null_pointer_node, rhs_vec = null_pointer_node;
1928 symbol_attribute lhs_caf_attr, rhs_caf_attr;
1929
1930 gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1931
1932 lhs_expr = code->ext.actual->expr;
1933 rhs_expr = code->ext.actual->next->expr;
1934 may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
1935 ? boolean_false_node : boolean_true_node;
1936 gfc_init_block (&block);
1937
1938 lhs_caf_attr = gfc_caf_attr (lhs_expr);
1939 rhs_caf_attr = gfc_caf_attr (rhs_expr);
1940 src_stat = dst_stat = null_pointer_node;
1941 dst_team = null_pointer_node;
1942
1943 /* LHS. */
1944 gfc_init_se (&lhs_se, NULL);
1945 if (lhs_expr->rank == 0)
1946 {
1947 if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
1948 {
1949 lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
1950 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1951 }
1952 else
1953 {
1954 symbol_attribute attr;
1955 gfc_clear_attr (&attr);
1956 gfc_conv_expr (&lhs_se, lhs_expr);
1957 lhs_type = TREE_TYPE (lhs_se.expr);
1958 lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
1959 attr);
1960 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1961 }
1962 }
1963 else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
1964 && lhs_caf_attr.codimension)
1965 {
1966 lhs_se.want_pointer = 1;
1967 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1968 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1969 has the wrong type if component references are done. */
1970 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1971 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1972 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1973 gfc_get_dtype_rank_type (
1974 gfc_has_vector_subscript (lhs_expr)
1975 ? gfc_find_array_ref (lhs_expr)->dimen
1976 : lhs_expr->rank,
1977 lhs_type));
1978 }
1979 else
1980 {
1981 bool has_vector = gfc_has_vector_subscript (lhs_expr);
1982
1983 if (gfc_is_coindexed (lhs_expr) || !has_vector)
1984 {
1985 /* If has_vector, pass descriptor for whole array and the
1986 vector bounds separately. */
1987 gfc_array_ref *ar, ar2;
1988 bool has_tmp_lhs_array = false;
1989 if (has_vector)
1990 {
1991 has_tmp_lhs_array = true;
1992 ar = gfc_find_array_ref (lhs_expr);
1993 ar2 = *ar;
1994 memset (ar, '\0', sizeof (*ar));
1995 ar->as = ar2.as;
1996 ar->type = AR_FULL;
1997 }
1998 lhs_se.want_pointer = 1;
1999 gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
2000 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
2001 that has the wrong type if component references are done. */
2002 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2003 tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
2004 gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2005 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2006 : lhs_expr->rank,
2007 lhs_type));
2008 if (has_tmp_lhs_array)
2009 {
2010 vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
2011 *ar = ar2;
2012 }
2013 }
2014 else
2015 {
2016 /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
2017 indexed array expression. This is rewritten to:
2018
2019 tmp_array = arr2[...]
2020 arr1 ([...]) = tmp_array
2021
2022 because using the standard gfc_conv_expr (lhs_expr) did the
2023 assignment with lhs and rhs exchanged. */
2024
2025 gfc_ss *lss_for_tmparray, *lss_real;
2026 gfc_loopinfo loop;
2027 gfc_se se;
2028 stmtblock_t body;
2029 tree tmparr_desc, src;
2030 tree index = gfc_index_zero_node;
2031 tree stride = gfc_index_zero_node;
2032 int n;
2033
2034 /* Walk both sides of the assignment, once to get the shape of the
2035 temporary array to create right. */
2036 lss_for_tmparray = gfc_walk_expr (lhs_expr);
2037 /* And a second time to be able to create an assignment of the
2038 temporary to the lhs_expr. gfc_trans_create_temp_array replaces
2039 the tree in the descriptor with the one for the temporary
2040 array. */
2041 lss_real = gfc_walk_expr (lhs_expr);
2042 gfc_init_loopinfo (&loop);
2043 gfc_add_ss_to_loop (&loop, lss_for_tmparray);
2044 gfc_add_ss_to_loop (&loop, lss_real);
2045 gfc_conv_ss_startstride (&loop);
2046 gfc_conv_loop_setup (&loop, &lhs_expr->where);
2047 lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
2048 gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
2049 lss_for_tmparray, lhs_type, NULL_TREE,
2050 false, true, false,
2051 &lhs_expr->where);
2052 tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
2053 gfc_start_scalarized_body (&loop, &body);
2054 gfc_init_se (&se, NULL);
2055 gfc_copy_loopinfo_to_se (&se, &loop);
2056 se.ss = lss_real;
2057 gfc_conv_expr (&se, lhs_expr);
2058 gfc_add_block_to_block (&body, &se.pre);
2059
2060 /* Walk over all indexes of the loop. */
2061 for (n = loop.dimen - 1; n > 0; --n)
2062 {
2063 tmp = loop.loopvar[n];
2064 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2065 gfc_array_index_type, tmp, loop.from[n]);
2066 tmp = fold_build2_loc (input_location, PLUS_EXPR,
2067 gfc_array_index_type, tmp, index);
2068
2069 stride = fold_build2_loc (input_location, MINUS_EXPR,
2070 gfc_array_index_type,
2071 loop.to[n - 1], loop.from[n - 1]);
2072 stride = fold_build2_loc (input_location, PLUS_EXPR,
2073 gfc_array_index_type,
2074 stride, gfc_index_one_node);
2075
2076 index = fold_build2_loc (input_location, MULT_EXPR,
2077 gfc_array_index_type, tmp, stride);
2078 }
2079
2080 index = fold_build2_loc (input_location, MINUS_EXPR,
2081 gfc_array_index_type,
2082 index, loop.from[0]);
2083
2084 index = fold_build2_loc (input_location, PLUS_EXPR,
2085 gfc_array_index_type,
2086 loop.loopvar[0], index);
2087
2088 src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
2089 src = gfc_build_array_ref (src, index, NULL);
2090 /* Now create the assignment of lhs_expr = tmp_array. */
2091 gfc_add_modify (&body, se.expr, src);
2092 gfc_add_block_to_block (&body, &se.post);
2093 lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
2094 gfc_trans_scalarizing_loops (&loop, &body);
2095 gfc_add_block_to_block (&loop.pre, &loop.post);
2096 gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
2097 gfc_free_ss (lss_for_tmparray);
2098 gfc_free_ss (lss_real);
2099 }
2100 }
2101
2102 lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
2103
2104 /* Special case: RHS is a coarray but LHS is not; this code path avoids a
2105 temporary and a loop. */
2106 if (!gfc_is_coindexed (lhs_expr)
2107 && (!lhs_caf_attr.codimension
2108 || !(lhs_expr->rank > 0
2109 && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
2110 {
2111 bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
2112 gcc_assert (gfc_is_coindexed (rhs_expr));
2113 gfc_init_se (&rhs_se, NULL);
2114 if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
2115 {
2116 gfc_se scal_se;
2117 gfc_init_se (&scal_se, NULL);
2118 scal_se.want_pointer = 1;
2119 gfc_conv_expr (&scal_se, lhs_expr);
2120 /* Ensure scalar on lhs is allocated. */
2121 gfc_add_block_to_block (&block, &scal_se.pre);
2122
2123 gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
2124 TYPE_SIZE_UNIT (
2125 gfc_typenode_for_spec (&lhs_expr->ts)),
2126 NULL_TREE);
2127 tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,
2128 null_pointer_node);
2129 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2130 tmp, gfc_finish_block (&scal_se.pre),
2131 build_empty_stmt (input_location));
2132 gfc_add_expr_to_block (&block, tmp);
2133 }
2134 else
2135 lhs_may_realloc = lhs_may_realloc
2136 && gfc_full_array_ref_p (lhs_expr->ref, NULL);
2137 gfc_add_block_to_block (&block, &lhs_se.pre);
2138 gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
2139 may_require_tmp, lhs_may_realloc,
2140 &rhs_caf_attr);
2141 gfc_add_block_to_block (&block, &rhs_se.pre);
2142 gfc_add_block_to_block (&block, &rhs_se.post);
2143 gfc_add_block_to_block (&block, &lhs_se.post);
2144 return gfc_finish_block (&block);
2145 }
2146
2147 gfc_add_block_to_block (&block, &lhs_se.pre);
2148
2149 /* Obtain token, offset and image index for the LHS. */
2150 caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
2151 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2152 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2153 image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
2154 tmp = lhs_se.expr;
2155 if (lhs_caf_attr.alloc_comp)
2156 gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
2157 NULL);
2158 else
2159 gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
2160 lhs_expr);
2161 lhs_se.expr = tmp;
2162
2163 /* RHS. */
2164 gfc_init_se (&rhs_se, NULL);
2165 if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
2166 && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
2167 rhs_expr = rhs_expr->value.function.actual->expr;
2168 if (rhs_expr->rank == 0)
2169 {
2170 symbol_attribute attr;
2171 gfc_clear_attr (&attr);
2172 gfc_conv_expr (&rhs_se, rhs_expr);
2173 rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
2174 rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
2175 }
2176 else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2177 && rhs_caf_attr.codimension)
2178 {
2179 tree tmp2;
2180 rhs_se.want_pointer = 1;
2181 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2182 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2183 has the wrong type if component references are done. */
2184 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2185 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2186 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2187 gfc_get_dtype_rank_type (
2188 gfc_has_vector_subscript (rhs_expr)
2189 ? gfc_find_array_ref (rhs_expr)->dimen
2190 : rhs_expr->rank,
2191 tmp2));
2192 }
2193 else
2194 {
2195 /* If has_vector, pass descriptor for whole array and the
2196 vector bounds separately. */
2197 gfc_array_ref *ar, ar2;
2198 bool has_vector = false;
2199 tree tmp2;
2200
2201 if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
2202 {
2203 has_vector = true;
2204 ar = gfc_find_array_ref (rhs_expr);
2205 ar2 = *ar;
2206 memset (ar, '\0', sizeof (*ar));
2207 ar->as = ar2.as;
2208 ar->type = AR_FULL;
2209 }
2210 rhs_se.want_pointer = 1;
2211 gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2212 /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2213 has the wrong type if component references are done. */
2214 tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2215 tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2216 gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2217 gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2218 : rhs_expr->rank,
2219 tmp2));
2220 if (has_vector)
2221 {
2222 rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
2223 *ar = ar2;
2224 }
2225 }
2226
2227 gfc_add_block_to_block (&block, &rhs_se.pre);
2228
2229 rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
2230
2231 tmp_stat = gfc_find_stat_co (lhs_expr);
2232
2233 if (tmp_stat)
2234 {
2235 gfc_se stat_se;
2236 gfc_init_se (&stat_se, NULL);
2237 gfc_conv_expr_reference (&stat_se, tmp_stat);
2238 dst_stat = stat_se.expr;
2239 gfc_add_block_to_block (&block, &stat_se.pre);
2240 gfc_add_block_to_block (&block, &stat_se.post);
2241 }
2242
2243 tmp_team = gfc_find_team_co (lhs_expr);
2244
2245 if (tmp_team)
2246 {
2247 gfc_se team_se;
2248 gfc_init_se (&team_se, NULL);
2249 gfc_conv_expr_reference (&team_se, tmp_team);
2250 dst_team = team_se.expr;
2251 gfc_add_block_to_block (&block, &team_se.pre);
2252 gfc_add_block_to_block (&block, &team_se.post);
2253 }
2254
2255 if (!gfc_is_coindexed (rhs_expr))
2256 {
2257 if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
2258 {
2259 tree reference, dst_realloc;
2260 reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2261 dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node
2262 : boolean_false_node;
2263 tmp = build_call_expr_loc (input_location,
2264 gfor_fndecl_caf_send_by_ref,
2265 10, token, image_index, rhs_se.expr,
2266 reference, lhs_kind, rhs_kind,
2267 may_require_tmp, dst_realloc, src_stat,
2268 build_int_cst (integer_type_node,
2269 lhs_expr->ts.type));
2270 }
2271 else
2272 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
2273 token, offset, image_index, lhs_se.expr, vec,
2274 rhs_se.expr, lhs_kind, rhs_kind,
2275 may_require_tmp, src_stat, dst_team);
2276 }
2277 else
2278 {
2279 tree rhs_token, rhs_offset, rhs_image_index;
2280
2281 /* It guarantees memory consistency within the same segment. */
2282 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2283 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2284 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2285 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2286 ASM_VOLATILE_P (tmp) = 1;
2287 gfc_add_expr_to_block (&block, tmp);
2288
2289 caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
2290 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2291 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2292 rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
2293 tmp = rhs_se.expr;
2294 if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2295 {
2296 tmp_stat = gfc_find_stat_co (lhs_expr);
2297
2298 if (tmp_stat)
2299 {
2300 gfc_se stat_se;
2301 gfc_init_se (&stat_se, NULL);
2302 gfc_conv_expr_reference (&stat_se, tmp_stat);
2303 src_stat = stat_se.expr;
2304 gfc_add_block_to_block (&block, &stat_se.pre);
2305 gfc_add_block_to_block (&block, &stat_se.post);
2306 }
2307
2308 gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
2309 NULL_TREE, NULL);
2310 tree lhs_reference, rhs_reference;
2311 lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2312 rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
2313 tmp = build_call_expr_loc (input_location,
2314 gfor_fndecl_caf_sendget_by_ref, 13,
2315 token, image_index, lhs_reference,
2316 rhs_token, rhs_image_index, rhs_reference,
2317 lhs_kind, rhs_kind, may_require_tmp,
2318 dst_stat, src_stat,
2319 build_int_cst (integer_type_node,
2320 lhs_expr->ts.type),
2321 build_int_cst (integer_type_node,
2322 rhs_expr->ts.type));
2323 }
2324 else
2325 {
2326 gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
2327 tmp, rhs_expr);
2328 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
2329 14, token, offset, image_index,
2330 lhs_se.expr, vec, rhs_token, rhs_offset,
2331 rhs_image_index, tmp, rhs_vec, lhs_kind,
2332 rhs_kind, may_require_tmp, src_stat);
2333 }
2334 }
2335 gfc_add_expr_to_block (&block, tmp);
2336 gfc_add_block_to_block (&block, &lhs_se.post);
2337 gfc_add_block_to_block (&block, &rhs_se.post);
2338
2339 /* It guarantees memory consistency within the same segment. */
2340 tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2341 tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2342 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2343 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2344 ASM_VOLATILE_P (tmp) = 1;
2345 gfc_add_expr_to_block (&block, tmp);
2346
2347 return gfc_finish_block (&block);
2348 }
2349
2350
2351 static void
trans_this_image(gfc_se * se,gfc_expr * expr)2352 trans_this_image (gfc_se * se, gfc_expr *expr)
2353 {
2354 stmtblock_t loop;
2355 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
2356 lbound, ubound, extent, ml;
2357 gfc_se argse;
2358 int rank, corank;
2359 gfc_expr *distance = expr->value.function.actual->next->next->expr;
2360
2361 if (expr->value.function.actual->expr
2362 && !gfc_is_coarray (expr->value.function.actual->expr))
2363 distance = expr->value.function.actual->expr;
2364
2365 /* The case -fcoarray=single is handled elsewhere. */
2366 gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
2367
2368 /* Argument-free version: THIS_IMAGE(). */
2369 if (distance || expr->value.function.actual->expr == NULL)
2370 {
2371 if (distance)
2372 {
2373 gfc_init_se (&argse, NULL);
2374 gfc_conv_expr_val (&argse, distance);
2375 gfc_add_block_to_block (&se->pre, &argse.pre);
2376 gfc_add_block_to_block (&se->post, &argse.post);
2377 tmp = fold_convert (integer_type_node, argse.expr);
2378 }
2379 else
2380 tmp = integer_zero_node;
2381 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2382 tmp);
2383 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2384 tmp);
2385 return;
2386 }
2387
2388 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
2389
2390 type = gfc_get_int_type (gfc_default_integer_kind);
2391 corank = gfc_get_corank (expr->value.function.actual->expr);
2392 rank = expr->value.function.actual->expr->rank;
2393
2394 /* Obtain the descriptor of the COARRAY. */
2395 gfc_init_se (&argse, NULL);
2396 argse.want_coarray = 1;
2397 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2398 gfc_add_block_to_block (&se->pre, &argse.pre);
2399 gfc_add_block_to_block (&se->post, &argse.post);
2400 desc = argse.expr;
2401
2402 if (se->ss)
2403 {
2404 /* Create an implicit second parameter from the loop variable. */
2405 gcc_assert (!expr->value.function.actual->next->expr);
2406 gcc_assert (corank > 0);
2407 gcc_assert (se->loop->dimen == 1);
2408 gcc_assert (se->ss->info->expr == expr);
2409
2410 dim_arg = se->loop->loopvar[0];
2411 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
2412 gfc_array_index_type, dim_arg,
2413 build_int_cst (TREE_TYPE (dim_arg), 1));
2414 gfc_advance_se_ss_chain (se);
2415 }
2416 else
2417 {
2418 /* Use the passed DIM= argument. */
2419 gcc_assert (expr->value.function.actual->next->expr);
2420 gfc_init_se (&argse, NULL);
2421 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
2422 gfc_array_index_type);
2423 gfc_add_block_to_block (&se->pre, &argse.pre);
2424 dim_arg = argse.expr;
2425
2426 if (INTEGER_CST_P (dim_arg))
2427 {
2428 if (wi::ltu_p (wi::to_wide (dim_arg), 1)
2429 || wi::gtu_p (wi::to_wide (dim_arg),
2430 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2431 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2432 "dimension index", expr->value.function.isym->name,
2433 &expr->where);
2434 }
2435 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2436 {
2437 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
2438 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2439 dim_arg,
2440 build_int_cst (TREE_TYPE (dim_arg), 1));
2441 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2442 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2443 dim_arg, tmp);
2444 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2445 logical_type_node, cond, tmp);
2446 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2447 gfc_msg_fault);
2448 }
2449 }
2450
2451 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2452 one always has a dim_arg argument.
2453
2454 m = this_image() - 1
2455 if (corank == 1)
2456 {
2457 sub(1) = m + lcobound(corank)
2458 return;
2459 }
2460 i = rank
2461 min_var = min (rank + corank - 2, rank + dim_arg - 1)
2462 for (;;)
2463 {
2464 extent = gfc_extent(i)
2465 ml = m
2466 m = m/extent
2467 if (i >= min_var)
2468 goto exit_label
2469 i++
2470 }
2471 exit_label:
2472 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2473 : m + lcobound(corank)
2474 */
2475
2476 /* this_image () - 1. */
2477 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2478 integer_zero_node);
2479 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
2480 fold_convert (type, tmp), build_int_cst (type, 1));
2481 if (corank == 1)
2482 {
2483 /* sub(1) = m + lcobound(corank). */
2484 lbound = gfc_conv_descriptor_lbound_get (desc,
2485 build_int_cst (TREE_TYPE (gfc_array_index_type),
2486 corank+rank-1));
2487 lbound = fold_convert (type, lbound);
2488 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2489
2490 se->expr = tmp;
2491 return;
2492 }
2493
2494 m = gfc_create_var (type, NULL);
2495 ml = gfc_create_var (type, NULL);
2496 loop_var = gfc_create_var (integer_type_node, NULL);
2497 min_var = gfc_create_var (integer_type_node, NULL);
2498
2499 /* m = this_image () - 1. */
2500 gfc_add_modify (&se->pre, m, tmp);
2501
2502 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
2503 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2504 fold_convert (integer_type_node, dim_arg),
2505 build_int_cst (integer_type_node, rank - 1));
2506 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
2507 build_int_cst (integer_type_node, rank + corank - 2),
2508 tmp);
2509 gfc_add_modify (&se->pre, min_var, tmp);
2510
2511 /* i = rank. */
2512 tmp = build_int_cst (integer_type_node, rank);
2513 gfc_add_modify (&se->pre, loop_var, tmp);
2514
2515 exit_label = gfc_build_label_decl (NULL_TREE);
2516 TREE_USED (exit_label) = 1;
2517
2518 /* Loop body. */
2519 gfc_init_block (&loop);
2520
2521 /* ml = m. */
2522 gfc_add_modify (&loop, ml, m);
2523
2524 /* extent = ... */
2525 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
2526 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
2527 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2528 extent = fold_convert (type, extent);
2529
2530 /* m = m/extent. */
2531 gfc_add_modify (&loop, m,
2532 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2533 m, extent));
2534
2535 /* Exit condition: if (i >= min_var) goto exit_label. */
2536 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
2537 min_var);
2538 tmp = build1_v (GOTO_EXPR, exit_label);
2539 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2540 build_empty_stmt (input_location));
2541 gfc_add_expr_to_block (&loop, tmp);
2542
2543 /* Increment loop variable: i++. */
2544 gfc_add_modify (&loop, loop_var,
2545 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2546 loop_var,
2547 build_int_cst (integer_type_node, 1)));
2548
2549 /* Making the loop... actually loop! */
2550 tmp = gfc_finish_block (&loop);
2551 tmp = build1_v (LOOP_EXPR, tmp);
2552 gfc_add_expr_to_block (&se->pre, tmp);
2553
2554 /* The exit label. */
2555 tmp = build1_v (LABEL_EXPR, exit_label);
2556 gfc_add_expr_to_block (&se->pre, tmp);
2557
2558 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2559 : m + lcobound(corank) */
2560
2561 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
2562 build_int_cst (TREE_TYPE (dim_arg), corank));
2563
2564 lbound = gfc_conv_descriptor_lbound_get (desc,
2565 fold_build2_loc (input_location, PLUS_EXPR,
2566 gfc_array_index_type, dim_arg,
2567 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2568 lbound = fold_convert (type, lbound);
2569
2570 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2571 fold_build2_loc (input_location, MULT_EXPR, type,
2572 m, extent));
2573 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2574
2575 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2576 fold_build2_loc (input_location, PLUS_EXPR, type,
2577 m, lbound));
2578 }
2579
2580
2581 /* Convert a call to image_status. */
2582
2583 static void
conv_intrinsic_image_status(gfc_se * se,gfc_expr * expr)2584 conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
2585 {
2586 unsigned int num_args;
2587 tree *args, tmp;
2588
2589 num_args = gfc_intrinsic_argument_list_length (expr);
2590 args = XALLOCAVEC (tree, num_args);
2591 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2592 /* In args[0] the number of the image the status is desired for has to be
2593 given. */
2594
2595 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2596 {
2597 tree arg;
2598 arg = gfc_evaluate_now (args[0], &se->pre);
2599 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2600 fold_convert (integer_type_node, arg),
2601 integer_one_node);
2602 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2603 tmp, integer_zero_node,
2604 build_int_cst (integer_type_node,
2605 GFC_STAT_STOPPED_IMAGE));
2606 }
2607 else if (flag_coarray == GFC_FCOARRAY_LIB)
2608 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
2609 args[0], build_int_cst (integer_type_node, -1));
2610 else
2611 gcc_unreachable ();
2612
2613 se->expr = tmp;
2614 }
2615
2616 static void
conv_intrinsic_team_number(gfc_se * se,gfc_expr * expr)2617 conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
2618 {
2619 unsigned int num_args;
2620
2621 tree *args, tmp;
2622
2623 num_args = gfc_intrinsic_argument_list_length (expr);
2624 args = XALLOCAVEC (tree, num_args);
2625 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2626
2627 if (flag_coarray ==
2628 GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
2629 {
2630 tree arg;
2631
2632 arg = gfc_evaluate_now (args[0], &se->pre);
2633 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2634 fold_convert (integer_type_node, arg),
2635 integer_one_node);
2636 tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
2637 tmp, integer_zero_node,
2638 build_int_cst (integer_type_node,
2639 GFC_STAT_STOPPED_IMAGE));
2640 }
2641 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
2642 {
2643 // the value -1 represents that no team has been created yet
2644 tmp = build_int_cst (integer_type_node, -1);
2645 }
2646 else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
2647 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2648 args[0], build_int_cst (integer_type_node, -1));
2649 else if (flag_coarray == GFC_FCOARRAY_LIB)
2650 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
2651 integer_zero_node, build_int_cst (integer_type_node, -1));
2652 else
2653 gcc_unreachable ();
2654
2655 se->expr = tmp;
2656 }
2657
2658
2659 static void
trans_image_index(gfc_se * se,gfc_expr * expr)2660 trans_image_index (gfc_se * se, gfc_expr *expr)
2661 {
2662 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
2663 tmp, invalid_bound;
2664 gfc_se argse, subse;
2665 int rank, corank, codim;
2666
2667 type = gfc_get_int_type (gfc_default_integer_kind);
2668 corank = gfc_get_corank (expr->value.function.actual->expr);
2669 rank = expr->value.function.actual->expr->rank;
2670
2671 /* Obtain the descriptor of the COARRAY. */
2672 gfc_init_se (&argse, NULL);
2673 argse.want_coarray = 1;
2674 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2675 gfc_add_block_to_block (&se->pre, &argse.pre);
2676 gfc_add_block_to_block (&se->post, &argse.post);
2677 desc = argse.expr;
2678
2679 /* Obtain a handle to the SUB argument. */
2680 gfc_init_se (&subse, NULL);
2681 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2682 gfc_add_block_to_block (&se->pre, &subse.pre);
2683 gfc_add_block_to_block (&se->post, &subse.post);
2684 subdesc = build_fold_indirect_ref_loc (input_location,
2685 gfc_conv_descriptor_data_get (subse.expr));
2686
2687 /* Fortran 2008 does not require that the values remain in the cobounds,
2688 thus we need explicitly check this - and return 0 if they are exceeded. */
2689
2690 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2691 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2692 invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2693 fold_convert (gfc_array_index_type, tmp),
2694 lbound);
2695
2696 for (codim = corank + rank - 2; codim >= rank; codim--)
2697 {
2698 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2699 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2700 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2701 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2702 fold_convert (gfc_array_index_type, tmp),
2703 lbound);
2704 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2705 logical_type_node, invalid_bound, cond);
2706 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2707 fold_convert (gfc_array_index_type, tmp),
2708 ubound);
2709 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2710 logical_type_node, invalid_bound, cond);
2711 }
2712
2713 invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2714
2715 /* See Fortran 2008, C.10 for the following algorithm. */
2716
2717 /* coindex = sub(corank) - lcobound(n). */
2718 coindex = fold_convert (gfc_array_index_type,
2719 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2720 NULL));
2721 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2722 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2723 fold_convert (gfc_array_index_type, coindex),
2724 lbound);
2725
2726 for (codim = corank + rank - 2; codim >= rank; codim--)
2727 {
2728 tree extent, ubound;
2729
2730 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
2731 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2732 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2733 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2734
2735 /* coindex *= extent. */
2736 coindex = fold_build2_loc (input_location, MULT_EXPR,
2737 gfc_array_index_type, coindex, extent);
2738
2739 /* coindex += sub(codim). */
2740 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2741 coindex = fold_build2_loc (input_location, PLUS_EXPR,
2742 gfc_array_index_type, coindex,
2743 fold_convert (gfc_array_index_type, tmp));
2744
2745 /* coindex -= lbound(codim). */
2746 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2747 coindex = fold_build2_loc (input_location, MINUS_EXPR,
2748 gfc_array_index_type, coindex, lbound);
2749 }
2750
2751 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2752 fold_convert(type, coindex),
2753 build_int_cst (type, 1));
2754
2755 /* Return 0 if "coindex" exceeds num_images(). */
2756
2757 if (flag_coarray == GFC_FCOARRAY_SINGLE)
2758 num_images = build_int_cst (type, 1);
2759 else
2760 {
2761 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2762 integer_zero_node,
2763 build_int_cst (integer_type_node, -1));
2764 num_images = fold_convert (type, tmp);
2765 }
2766
2767 tmp = gfc_create_var (type, NULL);
2768 gfc_add_modify (&se->pre, tmp, coindex);
2769
2770 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
2771 num_images);
2772 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
2773 cond,
2774 fold_convert (logical_type_node, invalid_bound));
2775 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2776 build_int_cst (type, 0), tmp);
2777 }
2778
2779 static void
trans_num_images(gfc_se * se,gfc_expr * expr)2780 trans_num_images (gfc_se * se, gfc_expr *expr)
2781 {
2782 tree tmp, distance, failed;
2783 gfc_se argse;
2784
2785 if (expr->value.function.actual->expr)
2786 {
2787 gfc_init_se (&argse, NULL);
2788 gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2789 gfc_add_block_to_block (&se->pre, &argse.pre);
2790 gfc_add_block_to_block (&se->post, &argse.post);
2791 distance = fold_convert (integer_type_node, argse.expr);
2792 }
2793 else
2794 distance = integer_zero_node;
2795
2796 if (expr->value.function.actual->next->expr)
2797 {
2798 gfc_init_se (&argse, NULL);
2799 gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
2800 gfc_add_block_to_block (&se->pre, &argse.pre);
2801 gfc_add_block_to_block (&se->post, &argse.post);
2802 failed = fold_convert (integer_type_node, argse.expr);
2803 }
2804 else
2805 failed = build_int_cst (integer_type_node, -1);
2806 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2807 distance, failed);
2808 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2809 }
2810
2811
2812 static void
gfc_conv_intrinsic_rank(gfc_se * se,gfc_expr * expr)2813 gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2814 {
2815 gfc_se argse;
2816
2817 gfc_init_se (&argse, NULL);
2818 argse.data_not_needed = 1;
2819 argse.descriptor_only = 1;
2820
2821 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2822 gfc_add_block_to_block (&se->pre, &argse.pre);
2823 gfc_add_block_to_block (&se->post, &argse.post);
2824
2825 se->expr = gfc_conv_descriptor_rank (argse.expr);
2826 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2827 se->expr);
2828 }
2829
2830
2831 static void
gfc_conv_intrinsic_is_contiguous(gfc_se * se,gfc_expr * expr)2832 gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
2833 {
2834 gfc_expr *arg;
2835 gfc_ss *ss;
2836 gfc_se argse;
2837 tree desc, tmp, stride, extent, cond;
2838 int i;
2839 tree fncall0;
2840 gfc_array_spec *as;
2841
2842 arg = expr->value.function.actual->expr;
2843
2844 if (arg->ts.type == BT_CLASS)
2845 gfc_add_class_array_ref (arg);
2846
2847 ss = gfc_walk_expr (arg);
2848 gcc_assert (ss != gfc_ss_terminator);
2849 gfc_init_se (&argse, NULL);
2850 argse.data_not_needed = 1;
2851 gfc_conv_expr_descriptor (&argse, arg);
2852
2853 as = gfc_get_full_arrayspec_from_expr (arg);
2854
2855 /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
2856 Note in addition that zero-sized arrays don't count as contiguous. */
2857
2858 if (as && as->type == AS_ASSUMED_RANK)
2859 {
2860 /* Build the call to is_contiguous0. */
2861 argse.want_pointer = 1;
2862 gfc_conv_expr_descriptor (&argse, arg);
2863 gfc_add_block_to_block (&se->pre, &argse.pre);
2864 gfc_add_block_to_block (&se->post, &argse.post);
2865 desc = gfc_evaluate_now (argse.expr, &se->pre);
2866 fncall0 = build_call_expr_loc (input_location,
2867 gfor_fndecl_is_contiguous0, 1, desc);
2868 se->expr = fncall0;
2869 se->expr = convert (logical_type_node, se->expr);
2870 }
2871 else
2872 {
2873 gfc_add_block_to_block (&se->pre, &argse.pre);
2874 gfc_add_block_to_block (&se->post, &argse.post);
2875 desc = gfc_evaluate_now (argse.expr, &se->pre);
2876
2877 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
2878 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2879 stride, build_int_cst (TREE_TYPE (stride), 1));
2880
2881 for (i = 0; i < expr->value.function.actual->expr->rank - 1; i++)
2882 {
2883 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2884 extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2885 extent = fold_build2_loc (input_location, MINUS_EXPR,
2886 gfc_array_index_type, extent, tmp);
2887 extent = fold_build2_loc (input_location, PLUS_EXPR,
2888 gfc_array_index_type, extent,
2889 gfc_index_one_node);
2890 tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
2891 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2892 tmp, extent);
2893 stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
2894 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2895 stride, tmp);
2896 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2897 boolean_type_node, cond, tmp);
2898 }
2899 se->expr = convert (gfc_typenode_for_spec (&expr->ts), cond);
2900 }
2901 }
2902
2903
2904 /* Evaluate a single upper or lower bound. */
2905 /* TODO: bound intrinsic generates way too much unnecessary code. */
2906
2907 static void
gfc_conv_intrinsic_bound(gfc_se * se,gfc_expr * expr,int upper)2908 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
2909 {
2910 gfc_actual_arglist *arg;
2911 gfc_actual_arglist *arg2;
2912 tree desc;
2913 tree type;
2914 tree bound;
2915 tree tmp;
2916 tree cond, cond1, cond3, cond4, size;
2917 tree ubound;
2918 tree lbound;
2919 gfc_se argse;
2920 gfc_array_spec * as;
2921 bool assumed_rank_lb_one;
2922
2923 arg = expr->value.function.actual;
2924 arg2 = arg->next;
2925
2926 if (se->ss)
2927 {
2928 /* Create an implicit second parameter from the loop variable. */
2929 gcc_assert (!arg2->expr);
2930 gcc_assert (se->loop->dimen == 1);
2931 gcc_assert (se->ss->info->expr == expr);
2932 gfc_advance_se_ss_chain (se);
2933 bound = se->loop->loopvar[0];
2934 bound = fold_build2_loc (input_location, MINUS_EXPR,
2935 gfc_array_index_type, bound,
2936 se->loop->from[0]);
2937 }
2938 else
2939 {
2940 /* use the passed argument. */
2941 gcc_assert (arg2->expr);
2942 gfc_init_se (&argse, NULL);
2943 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2944 gfc_add_block_to_block (&se->pre, &argse.pre);
2945 bound = argse.expr;
2946 /* Convert from one based to zero based. */
2947 bound = fold_build2_loc (input_location, MINUS_EXPR,
2948 gfc_array_index_type, bound,
2949 gfc_index_one_node);
2950 }
2951
2952 /* TODO: don't re-evaluate the descriptor on each iteration. */
2953 /* Get a descriptor for the first parameter. */
2954 gfc_init_se (&argse, NULL);
2955 gfc_conv_expr_descriptor (&argse, arg->expr);
2956 gfc_add_block_to_block (&se->pre, &argse.pre);
2957 gfc_add_block_to_block (&se->post, &argse.post);
2958
2959 desc = argse.expr;
2960
2961 as = gfc_get_full_arrayspec_from_expr (arg->expr);
2962
2963 if (INTEGER_CST_P (bound))
2964 {
2965 if (((!as || as->type != AS_ASSUMED_RANK)
2966 && wi::geu_p (wi::to_wide (bound),
2967 GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2968 || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
2969 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2970 "dimension index", upper ? "UBOUND" : "LBOUND",
2971 &expr->where);
2972 }
2973
2974 if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2975 {
2976 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2977 {
2978 bound = gfc_evaluate_now (bound, &se->pre);
2979 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2980 bound, build_int_cst (TREE_TYPE (bound), 0));
2981 if (as && as->type == AS_ASSUMED_RANK)
2982 tmp = gfc_conv_descriptor_rank (desc);
2983 else
2984 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2985 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
2986 bound, fold_convert(TREE_TYPE (bound), tmp));
2987 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2988 logical_type_node, cond, tmp);
2989 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2990 gfc_msg_fault);
2991 }
2992 }
2993
2994 /* Take care of the lbound shift for assumed-rank arrays, which are
2995 nonallocatable and nonpointers. Those has a lbound of 1. */
2996 assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2997 && ((arg->expr->ts.type != BT_CLASS
2998 && !arg->expr->symtree->n.sym->attr.allocatable
2999 && !arg->expr->symtree->n.sym->attr.pointer)
3000 || (arg->expr->ts.type == BT_CLASS
3001 && !CLASS_DATA (arg->expr)->attr.allocatable
3002 && !CLASS_DATA (arg->expr)->attr.class_pointer));
3003
3004 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
3005 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
3006
3007 /* 13.14.53: Result value for LBOUND
3008
3009 Case (i): For an array section or for an array expression other than a
3010 whole array or array structure component, LBOUND(ARRAY, DIM)
3011 has the value 1. For a whole array or array structure
3012 component, LBOUND(ARRAY, DIM) has the value:
3013 (a) equal to the lower bound for subscript DIM of ARRAY if
3014 dimension DIM of ARRAY does not have extent zero
3015 or if ARRAY is an assumed-size array of rank DIM,
3016 or (b) 1 otherwise.
3017
3018 13.14.113: Result value for UBOUND
3019
3020 Case (i): For an array section or for an array expression other than a
3021 whole array or array structure component, UBOUND(ARRAY, DIM)
3022 has the value equal to the number of elements in the given
3023 dimension; otherwise, it has a value equal to the upper bound
3024 for subscript DIM of ARRAY if dimension DIM of ARRAY does
3025 not have size zero and has value zero if dimension DIM has
3026 size zero. */
3027
3028 if (!upper && assumed_rank_lb_one)
3029 se->expr = gfc_index_one_node;
3030 else if (as)
3031 {
3032 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
3033
3034 cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3035 ubound, lbound);
3036 cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3037 stride, gfc_index_zero_node);
3038 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3039 logical_type_node, cond3, cond1);
3040 cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3041 stride, gfc_index_zero_node);
3042
3043 if (upper)
3044 {
3045 tree cond5;
3046 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3047 logical_type_node, cond3, cond4);
3048 cond5 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3049 gfc_index_one_node, lbound);
3050 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3051 logical_type_node, cond4, cond5);
3052
3053 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3054 logical_type_node, cond, cond5);
3055
3056 if (assumed_rank_lb_one)
3057 {
3058 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3059 gfc_array_index_type, ubound, lbound);
3060 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3061 gfc_array_index_type, tmp, gfc_index_one_node);
3062 }
3063 else
3064 tmp = ubound;
3065
3066 se->expr = fold_build3_loc (input_location, COND_EXPR,
3067 gfc_array_index_type, cond,
3068 tmp, gfc_index_zero_node);
3069 }
3070 else
3071 {
3072 if (as->type == AS_ASSUMED_SIZE)
3073 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3074 bound, build_int_cst (TREE_TYPE (bound),
3075 arg->expr->rank - 1));
3076 else
3077 cond = logical_false_node;
3078
3079 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3080 logical_type_node, cond3, cond4);
3081 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3082 logical_type_node, cond, cond1);
3083
3084 se->expr = fold_build3_loc (input_location, COND_EXPR,
3085 gfc_array_index_type, cond,
3086 lbound, gfc_index_one_node);
3087 }
3088 }
3089 else
3090 {
3091 if (upper)
3092 {
3093 size = fold_build2_loc (input_location, MINUS_EXPR,
3094 gfc_array_index_type, ubound, lbound);
3095 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
3096 gfc_array_index_type, size,
3097 gfc_index_one_node);
3098 se->expr = fold_build2_loc (input_location, MAX_EXPR,
3099 gfc_array_index_type, se->expr,
3100 gfc_index_zero_node);
3101 }
3102 else
3103 se->expr = gfc_index_one_node;
3104 }
3105
3106 /* According to F2018 16.9.172, para 5, an assumed rank object, argument
3107 associated with and assumed size array, has the ubound of the final
3108 dimension set to -1 and UBOUND must return this. */
3109 if (upper && as && as->type == AS_ASSUMED_RANK)
3110 {
3111 tree minus_one = build_int_cst (gfc_array_index_type, -1);
3112 tree rank = fold_convert (gfc_array_index_type,
3113 gfc_conv_descriptor_rank (desc));
3114 rank = fold_build2_loc (input_location, PLUS_EXPR,
3115 gfc_array_index_type, rank, minus_one);
3116 /* Fix the expression to stop it from becoming even more complicated. */
3117 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3118 cond = fold_build2_loc (input_location, NE_EXPR,
3119 logical_type_node, bound, rank);
3120 cond1 = fold_build2_loc (input_location, NE_EXPR,
3121 logical_type_node, ubound, minus_one);
3122 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3123 logical_type_node, cond, cond1);
3124 se->expr = fold_build3_loc (input_location, COND_EXPR,
3125 gfc_array_index_type, cond,
3126 se->expr, minus_one);
3127 }
3128
3129 type = gfc_typenode_for_spec (&expr->ts);
3130 se->expr = convert (type, se->expr);
3131 }
3132
3133
3134 static void
conv_intrinsic_cobound(gfc_se * se,gfc_expr * expr)3135 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
3136 {
3137 gfc_actual_arglist *arg;
3138 gfc_actual_arglist *arg2;
3139 gfc_se argse;
3140 tree bound, resbound, resbound2, desc, cond, tmp;
3141 tree type;
3142 int corank;
3143
3144 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
3145 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
3146 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
3147
3148 arg = expr->value.function.actual;
3149 arg2 = arg->next;
3150
3151 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
3152 corank = gfc_get_corank (arg->expr);
3153
3154 gfc_init_se (&argse, NULL);
3155 argse.want_coarray = 1;
3156
3157 gfc_conv_expr_descriptor (&argse, arg->expr);
3158 gfc_add_block_to_block (&se->pre, &argse.pre);
3159 gfc_add_block_to_block (&se->post, &argse.post);
3160 desc = argse.expr;
3161
3162 if (se->ss)
3163 {
3164 /* Create an implicit second parameter from the loop variable. */
3165 gcc_assert (!arg2->expr);
3166 gcc_assert (corank > 0);
3167 gcc_assert (se->loop->dimen == 1);
3168 gcc_assert (se->ss->info->expr == expr);
3169
3170 bound = se->loop->loopvar[0];
3171 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3172 bound, gfc_rank_cst[arg->expr->rank]);
3173 gfc_advance_se_ss_chain (se);
3174 }
3175 else
3176 {
3177 /* use the passed argument. */
3178 gcc_assert (arg2->expr);
3179 gfc_init_se (&argse, NULL);
3180 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
3181 gfc_add_block_to_block (&se->pre, &argse.pre);
3182 bound = argse.expr;
3183
3184 if (INTEGER_CST_P (bound))
3185 {
3186 if (wi::ltu_p (wi::to_wide (bound), 1)
3187 || wi::gtu_p (wi::to_wide (bound),
3188 GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
3189 gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
3190 "dimension index", expr->value.function.isym->name,
3191 &expr->where);
3192 }
3193 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3194 {
3195 bound = gfc_evaluate_now (bound, &se->pre);
3196 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3197 bound, build_int_cst (TREE_TYPE (bound), 1));
3198 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
3199 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3200 bound, tmp);
3201 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3202 logical_type_node, cond, tmp);
3203 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
3204 gfc_msg_fault);
3205 }
3206
3207
3208 /* Subtract 1 to get to zero based and add dimensions. */
3209 switch (arg->expr->rank)
3210 {
3211 case 0:
3212 bound = fold_build2_loc (input_location, MINUS_EXPR,
3213 gfc_array_index_type, bound,
3214 gfc_index_one_node);
3215 case 1:
3216 break;
3217 default:
3218 bound = fold_build2_loc (input_location, PLUS_EXPR,
3219 gfc_array_index_type, bound,
3220 gfc_rank_cst[arg->expr->rank - 1]);
3221 }
3222 }
3223
3224 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
3225
3226 /* Handle UCOBOUND with special handling of the last codimension. */
3227 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
3228 {
3229 /* Last codimension: For -fcoarray=single just return
3230 the lcobound - otherwise add
3231 ceiling (real (num_images ()) / real (size)) - 1
3232 = (num_images () + size - 1) / size - 1
3233 = (num_images - 1) / size(),
3234 where size is the product of the extent of all but the last
3235 codimension. */
3236
3237 if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
3238 {
3239 tree cosize;
3240
3241 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
3242 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3243 2, integer_zero_node,
3244 build_int_cst (integer_type_node, -1));
3245 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3246 gfc_array_index_type,
3247 fold_convert (gfc_array_index_type, tmp),
3248 build_int_cst (gfc_array_index_type, 1));
3249 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
3250 gfc_array_index_type, tmp,
3251 fold_convert (gfc_array_index_type, cosize));
3252 resbound = fold_build2_loc (input_location, PLUS_EXPR,
3253 gfc_array_index_type, resbound, tmp);
3254 }
3255 else if (flag_coarray != GFC_FCOARRAY_SINGLE)
3256 {
3257 /* ubound = lbound + num_images() - 1. */
3258 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
3259 2, integer_zero_node,
3260 build_int_cst (integer_type_node, -1));
3261 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3262 gfc_array_index_type,
3263 fold_convert (gfc_array_index_type, tmp),
3264 build_int_cst (gfc_array_index_type, 1));
3265 resbound = fold_build2_loc (input_location, PLUS_EXPR,
3266 gfc_array_index_type, resbound, tmp);
3267 }
3268
3269 if (corank > 1)
3270 {
3271 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3272 bound,
3273 build_int_cst (TREE_TYPE (bound),
3274 arg->expr->rank + corank - 1));
3275
3276 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
3277 se->expr = fold_build3_loc (input_location, COND_EXPR,
3278 gfc_array_index_type, cond,
3279 resbound, resbound2);
3280 }
3281 else
3282 se->expr = resbound;
3283 }
3284 else
3285 se->expr = resbound;
3286
3287 type = gfc_typenode_for_spec (&expr->ts);
3288 se->expr = convert (type, se->expr);
3289 }
3290
3291
3292 static void
conv_intrinsic_stride(gfc_se * se,gfc_expr * expr)3293 conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
3294 {
3295 gfc_actual_arglist *array_arg;
3296 gfc_actual_arglist *dim_arg;
3297 gfc_se argse;
3298 tree desc, tmp;
3299
3300 array_arg = expr->value.function.actual;
3301 dim_arg = array_arg->next;
3302
3303 gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
3304
3305 gfc_init_se (&argse, NULL);
3306 gfc_conv_expr_descriptor (&argse, array_arg->expr);
3307 gfc_add_block_to_block (&se->pre, &argse.pre);
3308 gfc_add_block_to_block (&se->post, &argse.post);
3309 desc = argse.expr;
3310
3311 gcc_assert (dim_arg->expr);
3312 gfc_init_se (&argse, NULL);
3313 gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
3314 gfc_add_block_to_block (&se->pre, &argse.pre);
3315 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3316 argse.expr, gfc_index_one_node);
3317 se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
3318 }
3319
3320 static void
gfc_conv_intrinsic_abs(gfc_se * se,gfc_expr * expr)3321 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
3322 {
3323 tree arg, cabs;
3324
3325 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3326
3327 switch (expr->value.function.actual->expr->ts.type)
3328 {
3329 case BT_INTEGER:
3330 case BT_REAL:
3331 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
3332 arg);
3333 break;
3334
3335 case BT_COMPLEX:
3336 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
3337 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
3338 break;
3339
3340 default:
3341 gcc_unreachable ();
3342 }
3343 }
3344
3345
3346 /* Create a complex value from one or two real components. */
3347
3348 static void
gfc_conv_intrinsic_cmplx(gfc_se * se,gfc_expr * expr,int both)3349 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
3350 {
3351 tree real;
3352 tree imag;
3353 tree type;
3354 tree *args;
3355 unsigned int num_args;
3356
3357 num_args = gfc_intrinsic_argument_list_length (expr);
3358 args = XALLOCAVEC (tree, num_args);
3359
3360 type = gfc_typenode_for_spec (&expr->ts);
3361 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3362 real = convert (TREE_TYPE (type), args[0]);
3363 if (both)
3364 imag = convert (TREE_TYPE (type), args[1]);
3365 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
3366 {
3367 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
3368 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
3369 imag = convert (TREE_TYPE (type), imag);
3370 }
3371 else
3372 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
3373
3374 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
3375 }
3376
3377
3378 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3379 MODULO(A, P) = A - FLOOR (A / P) * P
3380
3381 The obvious algorithms above are numerically instable for large
3382 arguments, hence these intrinsics are instead implemented via calls
3383 to the fmod family of functions. It is the responsibility of the
3384 user to ensure that the second argument is non-zero. */
3385
3386 static void
gfc_conv_intrinsic_mod(gfc_se * se,gfc_expr * expr,int modulo)3387 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
3388 {
3389 tree type;
3390 tree tmp;
3391 tree test;
3392 tree test2;
3393 tree fmod;
3394 tree zero;
3395 tree args[2];
3396
3397 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3398
3399 switch (expr->ts.type)
3400 {
3401 case BT_INTEGER:
3402 /* Integer case is easy, we've got a builtin op. */
3403 type = TREE_TYPE (args[0]);
3404
3405 if (modulo)
3406 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
3407 args[0], args[1]);
3408 else
3409 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
3410 args[0], args[1]);
3411 break;
3412
3413 case BT_REAL:
3414 fmod = NULL_TREE;
3415 /* Check if we have a builtin fmod. */
3416 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
3417
3418 /* The builtin should always be available. */
3419 gcc_assert (fmod != NULL_TREE);
3420
3421 tmp = build_addr (fmod);
3422 se->expr = build_call_array_loc (input_location,
3423 TREE_TYPE (TREE_TYPE (fmod)),
3424 tmp, 2, args);
3425 if (modulo == 0)
3426 return;
3427
3428 type = TREE_TYPE (args[0]);
3429
3430 args[0] = gfc_evaluate_now (args[0], &se->pre);
3431 args[1] = gfc_evaluate_now (args[1], &se->pre);
3432
3433 /* Definition:
3434 modulo = arg - floor (arg/arg2) * arg2
3435
3436 In order to calculate the result accurately, we use the fmod
3437 function as follows.
3438
3439 res = fmod (arg, arg2);
3440 if (res)
3441 {
3442 if ((arg < 0) xor (arg2 < 0))
3443 res += arg2;
3444 }
3445 else
3446 res = copysign (0., arg2);
3447
3448 => As two nested ternary exprs:
3449
3450 res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3451 : copysign (0., arg2);
3452
3453 */
3454
3455 zero = gfc_build_const (type, integer_zero_node);
3456 tmp = gfc_evaluate_now (se->expr, &se->pre);
3457 if (!flag_signed_zeros)
3458 {
3459 test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3460 args[0], zero);
3461 test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3462 args[1], zero);
3463 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3464 logical_type_node, test, test2);
3465 test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3466 tmp, zero);
3467 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3468 logical_type_node, test, test2);
3469 test = gfc_evaluate_now (test, &se->pre);
3470 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3471 fold_build2_loc (input_location,
3472 PLUS_EXPR,
3473 type, tmp, args[1]),
3474 tmp);
3475 }
3476 else
3477 {
3478 tree expr1, copysign, cscall;
3479 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3480 expr->ts.kind);
3481 test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3482 args[0], zero);
3483 test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3484 args[1], zero);
3485 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3486 logical_type_node, test, test2);
3487 expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3488 fold_build2_loc (input_location,
3489 PLUS_EXPR,
3490 type, tmp, args[1]),
3491 tmp);
3492 test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3493 tmp, zero);
3494 cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3495 args[1]);
3496 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3497 expr1, cscall);
3498 }
3499 return;
3500
3501 default:
3502 gcc_unreachable ();
3503 }
3504 }
3505
3506 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3507 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3508 where the right shifts are logical (i.e. 0's are shifted in).
3509 Because SHIFT_EXPR's want shifts strictly smaller than the integral
3510 type width, we have to special-case both S == 0 and S == BITSIZE(J):
3511 DSHIFTL(I,J,0) = I
3512 DSHIFTL(I,J,BITSIZE) = J
3513 DSHIFTR(I,J,0) = J
3514 DSHIFTR(I,J,BITSIZE) = I. */
3515
3516 static void
gfc_conv_intrinsic_dshift(gfc_se * se,gfc_expr * expr,bool dshiftl)3517 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3518 {
3519 tree type, utype, stype, arg1, arg2, shift, res, left, right;
3520 tree args[3], cond, tmp;
3521 int bitsize;
3522
3523 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3524
3525 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3526 type = TREE_TYPE (args[0]);
3527 bitsize = TYPE_PRECISION (type);
3528 utype = unsigned_type_for (type);
3529 stype = TREE_TYPE (args[2]);
3530
3531 arg1 = gfc_evaluate_now (args[0], &se->pre);
3532 arg2 = gfc_evaluate_now (args[1], &se->pre);
3533 shift = gfc_evaluate_now (args[2], &se->pre);
3534
3535 /* The generic case. */
3536 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3537 build_int_cst (stype, bitsize), shift);
3538 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3539 arg1, dshiftl ? shift : tmp);
3540
3541 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3542 fold_convert (utype, arg2), dshiftl ? tmp : shift);
3543 right = fold_convert (type, right);
3544
3545 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3546
3547 /* Special cases. */
3548 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3549 build_int_cst (stype, 0));
3550 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3551 dshiftl ? arg1 : arg2, res);
3552
3553 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
3554 build_int_cst (stype, bitsize));
3555 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3556 dshiftl ? arg2 : arg1, res);
3557
3558 se->expr = res;
3559 }
3560
3561
3562 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
3563
3564 static void
gfc_conv_intrinsic_dim(gfc_se * se,gfc_expr * expr)3565 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3566 {
3567 tree val;
3568 tree tmp;
3569 tree type;
3570 tree zero;
3571 tree args[2];
3572
3573 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3574 type = TREE_TYPE (args[0]);
3575
3576 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3577 val = gfc_evaluate_now (val, &se->pre);
3578
3579 zero = gfc_build_const (type, integer_zero_node);
3580 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
3581 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3582 }
3583
3584
3585 /* SIGN(A, B) is absolute value of A times sign of B.
3586 The real value versions use library functions to ensure the correct
3587 handling of negative zero. Integer case implemented as:
3588 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3589 */
3590
3591 static void
gfc_conv_intrinsic_sign(gfc_se * se,gfc_expr * expr)3592 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3593 {
3594 tree tmp;
3595 tree type;
3596 tree args[2];
3597
3598 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3599 if (expr->ts.type == BT_REAL)
3600 {
3601 tree abs;
3602
3603 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3604 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3605
3606 /* We explicitly have to ignore the minus sign. We do so by using
3607 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
3608 if (!flag_sign_zero
3609 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3610 {
3611 tree cond, zero;
3612 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3613 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3614 args[1], zero);
3615 se->expr = fold_build3_loc (input_location, COND_EXPR,
3616 TREE_TYPE (args[0]), cond,
3617 build_call_expr_loc (input_location, abs, 1,
3618 args[0]),
3619 build_call_expr_loc (input_location, tmp, 2,
3620 args[0], args[1]));
3621 }
3622 else
3623 se->expr = build_call_expr_loc (input_location, tmp, 2,
3624 args[0], args[1]);
3625 return;
3626 }
3627
3628 /* Having excluded floating point types, we know we are now dealing
3629 with signed integer types. */
3630 type = TREE_TYPE (args[0]);
3631
3632 /* Args[0] is used multiple times below. */
3633 args[0] = gfc_evaluate_now (args[0], &se->pre);
3634
3635 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3636 the signs of A and B are the same, and of all ones if they differ. */
3637 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3638 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3639 build_int_cst (type, TYPE_PRECISION (type) - 1));
3640 tmp = gfc_evaluate_now (tmp, &se->pre);
3641
3642 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3643 is all ones (i.e. -1). */
3644 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3645 fold_build2_loc (input_location, PLUS_EXPR,
3646 type, args[0], tmp), tmp);
3647 }
3648
3649
3650 /* Test for the presence of an optional argument. */
3651
3652 static void
gfc_conv_intrinsic_present(gfc_se * se,gfc_expr * expr)3653 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3654 {
3655 gfc_expr *arg;
3656
3657 arg = expr->value.function.actual->expr;
3658 gcc_assert (arg->expr_type == EXPR_VARIABLE);
3659 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3660 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3661 }
3662
3663
3664 /* Calculate the double precision product of two single precision values. */
3665
3666 static void
gfc_conv_intrinsic_dprod(gfc_se * se,gfc_expr * expr)3667 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3668 {
3669 tree type;
3670 tree args[2];
3671
3672 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3673
3674 /* Convert the args to double precision before multiplying. */
3675 type = gfc_typenode_for_spec (&expr->ts);
3676 args[0] = convert (type, args[0]);
3677 args[1] = convert (type, args[1]);
3678 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3679 args[1]);
3680 }
3681
3682
3683 /* Return a length one character string containing an ascii character. */
3684
3685 static void
gfc_conv_intrinsic_char(gfc_se * se,gfc_expr * expr)3686 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3687 {
3688 tree arg[2];
3689 tree var;
3690 tree type;
3691 unsigned int num_args;
3692
3693 num_args = gfc_intrinsic_argument_list_length (expr);
3694 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3695
3696 type = gfc_get_char_type (expr->ts.kind);
3697 var = gfc_create_var (type, "char");
3698
3699 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3700 gfc_add_modify (&se->pre, var, arg[0]);
3701 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3702 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3703 }
3704
3705
3706 static void
gfc_conv_intrinsic_ctime(gfc_se * se,gfc_expr * expr)3707 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3708 {
3709 tree var;
3710 tree len;
3711 tree tmp;
3712 tree cond;
3713 tree fndecl;
3714 tree *args;
3715 unsigned int num_args;
3716
3717 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3718 args = XALLOCAVEC (tree, num_args);
3719
3720 var = gfc_create_var (pchar_type_node, "pstr");
3721 len = gfc_create_var (gfc_charlen_type_node, "len");
3722
3723 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3724 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3725 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3726
3727 fndecl = build_addr (gfor_fndecl_ctime);
3728 tmp = build_call_array_loc (input_location,
3729 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3730 fndecl, num_args, args);
3731 gfc_add_expr_to_block (&se->pre, tmp);
3732
3733 /* Free the temporary afterwards, if necessary. */
3734 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3735 len, build_int_cst (TREE_TYPE (len), 0));
3736 tmp = gfc_call_free (var);
3737 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3738 gfc_add_expr_to_block (&se->post, tmp);
3739
3740 se->expr = var;
3741 se->string_length = len;
3742 }
3743
3744
3745 static void
gfc_conv_intrinsic_fdate(gfc_se * se,gfc_expr * expr)3746 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3747 {
3748 tree var;
3749 tree len;
3750 tree tmp;
3751 tree cond;
3752 tree fndecl;
3753 tree *args;
3754 unsigned int num_args;
3755
3756 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3757 args = XALLOCAVEC (tree, num_args);
3758
3759 var = gfc_create_var (pchar_type_node, "pstr");
3760 len = gfc_create_var (gfc_charlen_type_node, "len");
3761
3762 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3763 args[0] = gfc_build_addr_expr (NULL_TREE, var);
3764 args[1] = gfc_build_addr_expr (NULL_TREE, len);
3765
3766 fndecl = build_addr (gfor_fndecl_fdate);
3767 tmp = build_call_array_loc (input_location,
3768 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3769 fndecl, num_args, args);
3770 gfc_add_expr_to_block (&se->pre, tmp);
3771
3772 /* Free the temporary afterwards, if necessary. */
3773 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3774 len, build_int_cst (TREE_TYPE (len), 0));
3775 tmp = gfc_call_free (var);
3776 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3777 gfc_add_expr_to_block (&se->post, tmp);
3778
3779 se->expr = var;
3780 se->string_length = len;
3781 }
3782
3783
3784 /* Generate a direct call to free() for the FREE subroutine. */
3785
3786 static tree
conv_intrinsic_free(gfc_code * code)3787 conv_intrinsic_free (gfc_code *code)
3788 {
3789 stmtblock_t block;
3790 gfc_se argse;
3791 tree arg, call;
3792
3793 gfc_init_se (&argse, NULL);
3794 gfc_conv_expr (&argse, code->ext.actual->expr);
3795 arg = fold_convert (ptr_type_node, argse.expr);
3796
3797 gfc_init_block (&block);
3798 call = build_call_expr_loc (input_location,
3799 builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3800 gfc_add_expr_to_block (&block, call);
3801 return gfc_finish_block (&block);
3802 }
3803
3804
3805 /* Call the RANDOM_INIT library subroutine with a hidden argument for
3806 handling seeding on coarray images. */
3807
3808 static tree
conv_intrinsic_random_init(gfc_code * code)3809 conv_intrinsic_random_init (gfc_code *code)
3810 {
3811 stmtblock_t block;
3812 gfc_se se;
3813 tree arg1, arg2, arg3, tmp;
3814 tree logical4_type_node = gfc_get_logical_type (4);
3815
3816 /* Make the function call. */
3817 gfc_init_block (&block);
3818 gfc_init_se (&se, NULL);
3819
3820 /* Convert REPEATABLE to a LOGICAL(4) entity. */
3821 gfc_conv_expr (&se, code->ext.actual->expr);
3822 gfc_add_block_to_block (&block, &se.pre);
3823 arg1 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block));
3824 gfc_add_block_to_block (&block, &se.post);
3825
3826 /* Convert IMAGE_DISTINCT to a LOGICAL(4) entity. */
3827 gfc_conv_expr (&se, code->ext.actual->next->expr);
3828 gfc_add_block_to_block (&block, &se.pre);
3829 arg2 = fold_convert (logical4_type_node, gfc_evaluate_now (se.expr, &block));
3830 gfc_add_block_to_block (&block, &se.post);
3831
3832 /* Create the hidden argument. For non-coarray codes and -fcoarray=single,
3833 simply set this to 0. For -fcoarray=lib, generate a call to
3834 THIS_IMAGE() without arguments. */
3835 arg3 = build_int_cst (gfc_get_int_type (4), 0);
3836 if (flag_coarray == GFC_FCOARRAY_LIB)
3837 {
3838 arg3 = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image,
3839 1, arg3);
3840 se.expr = fold_convert (gfc_get_int_type (4), arg3);
3841 }
3842
3843 tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init, 3,
3844 arg1, arg2, arg3);
3845 gfc_add_expr_to_block (&block, tmp);
3846
3847 return gfc_finish_block (&block);
3848 }
3849
3850
3851 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3852 conversions. */
3853
3854 static tree
conv_intrinsic_system_clock(gfc_code * code)3855 conv_intrinsic_system_clock (gfc_code *code)
3856 {
3857 stmtblock_t block;
3858 gfc_se count_se, count_rate_se, count_max_se;
3859 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3860 tree tmp;
3861 int least;
3862
3863 gfc_expr *count = code->ext.actual->expr;
3864 gfc_expr *count_rate = code->ext.actual->next->expr;
3865 gfc_expr *count_max = code->ext.actual->next->next->expr;
3866
3867 /* Evaluate our arguments. */
3868 if (count)
3869 {
3870 gfc_init_se (&count_se, NULL);
3871 gfc_conv_expr (&count_se, count);
3872 }
3873
3874 if (count_rate)
3875 {
3876 gfc_init_se (&count_rate_se, NULL);
3877 gfc_conv_expr (&count_rate_se, count_rate);
3878 }
3879
3880 if (count_max)
3881 {
3882 gfc_init_se (&count_max_se, NULL);
3883 gfc_conv_expr (&count_max_se, count_max);
3884 }
3885
3886 /* Find the smallest kind found of the arguments. */
3887 least = 16;
3888 least = (count && count->ts.kind < least) ? count->ts.kind : least;
3889 least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3890 : least;
3891 least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3892 : least;
3893
3894 /* Prepare temporary variables. */
3895
3896 if (count)
3897 {
3898 if (least >= 8)
3899 arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3900 else if (least == 4)
3901 arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3902 else if (count->ts.kind == 1)
3903 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3904 count->ts.kind);
3905 else
3906 arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3907 count->ts.kind);
3908 }
3909
3910 if (count_rate)
3911 {
3912 if (least >= 8)
3913 arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3914 else if (least == 4)
3915 arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3916 else
3917 arg2 = integer_zero_node;
3918 }
3919
3920 if (count_max)
3921 {
3922 if (least >= 8)
3923 arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3924 else if (least == 4)
3925 arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3926 else
3927 arg3 = integer_zero_node;
3928 }
3929
3930 /* Make the function call. */
3931 gfc_init_block (&block);
3932
3933 if (least <= 2)
3934 {
3935 if (least == 1)
3936 {
3937 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3938 : null_pointer_node;
3939 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3940 : null_pointer_node;
3941 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3942 : null_pointer_node;
3943 }
3944
3945 if (least == 2)
3946 {
3947 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3948 : null_pointer_node;
3949 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3950 : null_pointer_node;
3951 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3952 : null_pointer_node;
3953 }
3954 }
3955 else
3956 {
3957 if (least == 4)
3958 {
3959 tmp = build_call_expr_loc (input_location,
3960 gfor_fndecl_system_clock4, 3,
3961 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3962 : null_pointer_node,
3963 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3964 : null_pointer_node,
3965 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3966 : null_pointer_node);
3967 gfc_add_expr_to_block (&block, tmp);
3968 }
3969 /* Handle kind>=8, 10, or 16 arguments */
3970 if (least >= 8)
3971 {
3972 tmp = build_call_expr_loc (input_location,
3973 gfor_fndecl_system_clock8, 3,
3974 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3975 : null_pointer_node,
3976 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3977 : null_pointer_node,
3978 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3979 : null_pointer_node);
3980 gfc_add_expr_to_block (&block, tmp);
3981 }
3982 }
3983
3984 /* And store values back if needed. */
3985 if (arg1 && arg1 != count_se.expr)
3986 gfc_add_modify (&block, count_se.expr,
3987 fold_convert (TREE_TYPE (count_se.expr), arg1));
3988 if (arg2 && arg2 != count_rate_se.expr)
3989 gfc_add_modify (&block, count_rate_se.expr,
3990 fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3991 if (arg3 && arg3 != count_max_se.expr)
3992 gfc_add_modify (&block, count_max_se.expr,
3993 fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3994
3995 return gfc_finish_block (&block);
3996 }
3997
3998
3999 /* Return a character string containing the tty name. */
4000
4001 static void
gfc_conv_intrinsic_ttynam(gfc_se * se,gfc_expr * expr)4002 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
4003 {
4004 tree var;
4005 tree len;
4006 tree tmp;
4007 tree cond;
4008 tree fndecl;
4009 tree *args;
4010 unsigned int num_args;
4011
4012 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4013 args = XALLOCAVEC (tree, num_args);
4014
4015 var = gfc_create_var (pchar_type_node, "pstr");
4016 len = gfc_create_var (gfc_charlen_type_node, "len");
4017
4018 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4019 args[0] = gfc_build_addr_expr (NULL_TREE, var);
4020 args[1] = gfc_build_addr_expr (NULL_TREE, len);
4021
4022 fndecl = build_addr (gfor_fndecl_ttynam);
4023 tmp = build_call_array_loc (input_location,
4024 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
4025 fndecl, num_args, args);
4026 gfc_add_expr_to_block (&se->pre, tmp);
4027
4028 /* Free the temporary afterwards, if necessary. */
4029 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4030 len, build_int_cst (TREE_TYPE (len), 0));
4031 tmp = gfc_call_free (var);
4032 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4033 gfc_add_expr_to_block (&se->post, tmp);
4034
4035 se->expr = var;
4036 se->string_length = len;
4037 }
4038
4039
4040 /* Get the minimum/maximum value of all the parameters.
4041 minmax (a1, a2, a3, ...)
4042 {
4043 mvar = a1;
4044 mvar = COMP (mvar, a2)
4045 mvar = COMP (mvar, a3)
4046 ...
4047 return mvar;
4048 }
4049 Where COMP is MIN/MAX_EXPR for integral types or when we don't
4050 care about NaNs, or IFN_FMIN/MAX when the target has support for
4051 fast NaN-honouring min/max. When neither holds expand a sequence
4052 of explicit comparisons. */
4053
4054 /* TODO: Mismatching types can occur when specific names are used.
4055 These should be handled during resolution. */
4056 static void
gfc_conv_intrinsic_minmax(gfc_se * se,gfc_expr * expr,enum tree_code op)4057 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
4058 {
4059 tree tmp;
4060 tree mvar;
4061 tree val;
4062 tree *args;
4063 tree type;
4064 gfc_actual_arglist *argexpr;
4065 unsigned int i, nargs;
4066
4067 nargs = gfc_intrinsic_argument_list_length (expr);
4068 args = XALLOCAVEC (tree, nargs);
4069
4070 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
4071 type = gfc_typenode_for_spec (&expr->ts);
4072
4073 argexpr = expr->value.function.actual;
4074 if (TREE_TYPE (args[0]) != type)
4075 args[0] = convert (type, args[0]);
4076 /* Only evaluate the argument once. */
4077 if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
4078 args[0] = gfc_evaluate_now (args[0], &se->pre);
4079
4080 mvar = gfc_create_var (type, "M");
4081 gfc_add_modify (&se->pre, mvar, args[0]);
4082
4083 for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
4084 {
4085 tree cond = NULL_TREE;
4086 val = args[i];
4087
4088 /* Handle absent optional arguments by ignoring the comparison. */
4089 if (argexpr->expr->expr_type == EXPR_VARIABLE
4090 && argexpr->expr->symtree->n.sym->attr.optional
4091 && TREE_CODE (val) == INDIRECT_REF)
4092 {
4093 cond = fold_build2_loc (input_location,
4094 NE_EXPR, logical_type_node,
4095 TREE_OPERAND (val, 0),
4096 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
4097 }
4098 else if (!VAR_P (val) && !TREE_CONSTANT (val))
4099 /* Only evaluate the argument once. */
4100 val = gfc_evaluate_now (val, &se->pre);
4101
4102 tree calc;
4103 /* For floating point types, the question is what MAX(a, NaN) or
4104 MIN(a, NaN) should return (where "a" is a normal number).
4105 There are valid usecase for returning either one, but the
4106 Fortran standard doesn't specify which one should be chosen.
4107 Also, there is no consensus among other tested compilers. In
4108 short, it's a mess. So lets just do whatever is fastest. */
4109 tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
4110 calc = fold_build2_loc (input_location, code, type,
4111 convert (type, val), mvar);
4112 tmp = build2_v (MODIFY_EXPR, mvar, calc);
4113
4114 if (cond != NULL_TREE)
4115 tmp = build3_v (COND_EXPR, cond, tmp,
4116 build_empty_stmt (input_location));
4117 gfc_add_expr_to_block (&se->pre, tmp);
4118 }
4119 se->expr = mvar;
4120 }
4121
4122
4123 /* Generate library calls for MIN and MAX intrinsics for character
4124 variables. */
4125 static void
gfc_conv_intrinsic_minmax_char(gfc_se * se,gfc_expr * expr,int op)4126 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
4127 {
4128 tree *args;
4129 tree var, len, fndecl, tmp, cond, function;
4130 unsigned int nargs;
4131
4132 nargs = gfc_intrinsic_argument_list_length (expr);
4133 args = XALLOCAVEC (tree, nargs + 4);
4134 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
4135
4136 /* Create the result variables. */
4137 len = gfc_create_var (gfc_charlen_type_node, "len");
4138 args[0] = gfc_build_addr_expr (NULL_TREE, len);
4139 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4140 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
4141 args[2] = build_int_cst (integer_type_node, op);
4142 args[3] = build_int_cst (integer_type_node, nargs / 2);
4143
4144 if (expr->ts.kind == 1)
4145 function = gfor_fndecl_string_minmax;
4146 else if (expr->ts.kind == 4)
4147 function = gfor_fndecl_string_minmax_char4;
4148 else
4149 gcc_unreachable ();
4150
4151 /* Make the function call. */
4152 fndecl = build_addr (function);
4153 tmp = build_call_array_loc (input_location,
4154 TREE_TYPE (TREE_TYPE (function)), fndecl,
4155 nargs + 4, args);
4156 gfc_add_expr_to_block (&se->pre, tmp);
4157
4158 /* Free the temporary afterwards, if necessary. */
4159 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4160 len, build_int_cst (TREE_TYPE (len), 0));
4161 tmp = gfc_call_free (var);
4162 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4163 gfc_add_expr_to_block (&se->post, tmp);
4164
4165 se->expr = var;
4166 se->string_length = len;
4167 }
4168
4169
4170 /* Create a symbol node for this intrinsic. The symbol from the frontend
4171 has the generic name. */
4172
4173 static gfc_symbol *
gfc_get_symbol_for_expr(gfc_expr * expr,bool ignore_optional)4174 gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
4175 {
4176 gfc_symbol *sym;
4177
4178 /* TODO: Add symbols for intrinsic function to the global namespace. */
4179 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
4180 sym = gfc_new_symbol (expr->value.function.name, NULL);
4181
4182 sym->ts = expr->ts;
4183 sym->attr.external = 1;
4184 sym->attr.function = 1;
4185 sym->attr.always_explicit = 1;
4186 sym->attr.proc = PROC_INTRINSIC;
4187 sym->attr.flavor = FL_PROCEDURE;
4188 sym->result = sym;
4189 if (expr->rank > 0)
4190 {
4191 sym->attr.dimension = 1;
4192 sym->as = gfc_get_array_spec ();
4193 sym->as->type = AS_ASSUMED_SHAPE;
4194 sym->as->rank = expr->rank;
4195 }
4196
4197 gfc_copy_formal_args_intr (sym, expr->value.function.isym,
4198 ignore_optional ? expr->value.function.actual
4199 : NULL);
4200
4201 return sym;
4202 }
4203
4204 /* Generate a call to an external intrinsic function. */
4205 static void
gfc_conv_intrinsic_funcall(gfc_se * se,gfc_expr * expr)4206 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
4207 {
4208 gfc_symbol *sym;
4209 vec<tree, va_gc> *append_args;
4210
4211 gcc_assert (!se->ss || se->ss->info->expr == expr);
4212
4213 if (se->ss)
4214 gcc_assert (expr->rank > 0);
4215 else
4216 gcc_assert (expr->rank == 0);
4217
4218 sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
4219
4220 /* Calls to libgfortran_matmul need to be appended special arguments,
4221 to be able to call the BLAS ?gemm functions if required and possible. */
4222 append_args = NULL;
4223 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
4224 && !expr->external_blas
4225 && sym->ts.type != BT_LOGICAL)
4226 {
4227 tree cint = gfc_get_int_type (gfc_c_int_kind);
4228
4229 if (flag_external_blas
4230 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
4231 && (sym->ts.kind == 4 || sym->ts.kind == 8))
4232 {
4233 tree gemm_fndecl;
4234
4235 if (sym->ts.type == BT_REAL)
4236 {
4237 if (sym->ts.kind == 4)
4238 gemm_fndecl = gfor_fndecl_sgemm;
4239 else
4240 gemm_fndecl = gfor_fndecl_dgemm;
4241 }
4242 else
4243 {
4244 if (sym->ts.kind == 4)
4245 gemm_fndecl = gfor_fndecl_cgemm;
4246 else
4247 gemm_fndecl = gfor_fndecl_zgemm;
4248 }
4249
4250 vec_alloc (append_args, 3);
4251 append_args->quick_push (build_int_cst (cint, 1));
4252 append_args->quick_push (build_int_cst (cint,
4253 flag_blas_matmul_limit));
4254 append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
4255 gemm_fndecl));
4256 }
4257 else
4258 {
4259 vec_alloc (append_args, 3);
4260 append_args->quick_push (build_int_cst (cint, 0));
4261 append_args->quick_push (build_int_cst (cint, 0));
4262 append_args->quick_push (null_pointer_node);
4263 }
4264 }
4265
4266 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4267 append_args);
4268 gfc_free_symbol (sym);
4269 }
4270
4271 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
4272 Implemented as
4273 any(a)
4274 {
4275 forall (i=...)
4276 if (a[i] != 0)
4277 return 1
4278 end forall
4279 return 0
4280 }
4281 all(a)
4282 {
4283 forall (i=...)
4284 if (a[i] == 0)
4285 return 0
4286 end forall
4287 return 1
4288 }
4289 */
4290 static void
gfc_conv_intrinsic_anyall(gfc_se * se,gfc_expr * expr,enum tree_code op)4291 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
4292 {
4293 tree resvar;
4294 stmtblock_t block;
4295 stmtblock_t body;
4296 tree type;
4297 tree tmp;
4298 tree found;
4299 gfc_loopinfo loop;
4300 gfc_actual_arglist *actual;
4301 gfc_ss *arrayss;
4302 gfc_se arrayse;
4303 tree exit_label;
4304
4305 if (se->ss)
4306 {
4307 gfc_conv_intrinsic_funcall (se, expr);
4308 return;
4309 }
4310
4311 actual = expr->value.function.actual;
4312 type = gfc_typenode_for_spec (&expr->ts);
4313 /* Initialize the result. */
4314 resvar = gfc_create_var (type, "test");
4315 if (op == EQ_EXPR)
4316 tmp = convert (type, boolean_true_node);
4317 else
4318 tmp = convert (type, boolean_false_node);
4319 gfc_add_modify (&se->pre, resvar, tmp);
4320
4321 /* Walk the arguments. */
4322 arrayss = gfc_walk_expr (actual->expr);
4323 gcc_assert (arrayss != gfc_ss_terminator);
4324
4325 /* Initialize the scalarizer. */
4326 gfc_init_loopinfo (&loop);
4327 exit_label = gfc_build_label_decl (NULL_TREE);
4328 TREE_USED (exit_label) = 1;
4329 gfc_add_ss_to_loop (&loop, arrayss);
4330
4331 /* Initialize the loop. */
4332 gfc_conv_ss_startstride (&loop);
4333 gfc_conv_loop_setup (&loop, &expr->where);
4334
4335 gfc_mark_ss_chain_used (arrayss, 1);
4336 /* Generate the loop body. */
4337 gfc_start_scalarized_body (&loop, &body);
4338
4339 /* If the condition matches then set the return value. */
4340 gfc_start_block (&block);
4341 if (op == EQ_EXPR)
4342 tmp = convert (type, boolean_false_node);
4343 else
4344 tmp = convert (type, boolean_true_node);
4345 gfc_add_modify (&block, resvar, tmp);
4346
4347 /* And break out of the loop. */
4348 tmp = build1_v (GOTO_EXPR, exit_label);
4349 gfc_add_expr_to_block (&block, tmp);
4350
4351 found = gfc_finish_block (&block);
4352
4353 /* Check this element. */
4354 gfc_init_se (&arrayse, NULL);
4355 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4356 arrayse.ss = arrayss;
4357 gfc_conv_expr_val (&arrayse, actual->expr);
4358
4359 gfc_add_block_to_block (&body, &arrayse.pre);
4360 tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
4361 build_int_cst (TREE_TYPE (arrayse.expr), 0));
4362 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
4363 gfc_add_expr_to_block (&body, tmp);
4364 gfc_add_block_to_block (&body, &arrayse.post);
4365
4366 gfc_trans_scalarizing_loops (&loop, &body);
4367
4368 /* Add the exit label. */
4369 tmp = build1_v (LABEL_EXPR, exit_label);
4370 gfc_add_expr_to_block (&loop.pre, tmp);
4371
4372 gfc_add_block_to_block (&se->pre, &loop.pre);
4373 gfc_add_block_to_block (&se->pre, &loop.post);
4374 gfc_cleanup_loop (&loop);
4375
4376 se->expr = resvar;
4377 }
4378
4379 /* COUNT(A) = Number of true elements in A. */
4380 static void
gfc_conv_intrinsic_count(gfc_se * se,gfc_expr * expr)4381 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
4382 {
4383 tree resvar;
4384 tree type;
4385 stmtblock_t body;
4386 tree tmp;
4387 gfc_loopinfo loop;
4388 gfc_actual_arglist *actual;
4389 gfc_ss *arrayss;
4390 gfc_se arrayse;
4391
4392 if (se->ss)
4393 {
4394 gfc_conv_intrinsic_funcall (se, expr);
4395 return;
4396 }
4397
4398 actual = expr->value.function.actual;
4399
4400 type = gfc_typenode_for_spec (&expr->ts);
4401 /* Initialize the result. */
4402 resvar = gfc_create_var (type, "count");
4403 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4404
4405 /* Walk the arguments. */
4406 arrayss = gfc_walk_expr (actual->expr);
4407 gcc_assert (arrayss != gfc_ss_terminator);
4408
4409 /* Initialize the scalarizer. */
4410 gfc_init_loopinfo (&loop);
4411 gfc_add_ss_to_loop (&loop, arrayss);
4412
4413 /* Initialize the loop. */
4414 gfc_conv_ss_startstride (&loop);
4415 gfc_conv_loop_setup (&loop, &expr->where);
4416
4417 gfc_mark_ss_chain_used (arrayss, 1);
4418 /* Generate the loop body. */
4419 gfc_start_scalarized_body (&loop, &body);
4420
4421 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4422 resvar, build_int_cst (TREE_TYPE (resvar), 1));
4423 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4424
4425 gfc_init_se (&arrayse, NULL);
4426 gfc_copy_loopinfo_to_se (&arrayse, &loop);
4427 arrayse.ss = arrayss;
4428 gfc_conv_expr_val (&arrayse, actual->expr);
4429 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4430 build_empty_stmt (input_location));
4431
4432 gfc_add_block_to_block (&body, &arrayse.pre);
4433 gfc_add_expr_to_block (&body, tmp);
4434 gfc_add_block_to_block (&body, &arrayse.post);
4435
4436 gfc_trans_scalarizing_loops (&loop, &body);
4437
4438 gfc_add_block_to_block (&se->pre, &loop.pre);
4439 gfc_add_block_to_block (&se->pre, &loop.post);
4440 gfc_cleanup_loop (&loop);
4441
4442 se->expr = resvar;
4443 }
4444
4445
4446 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4447 struct and return the corresponding loopinfo. */
4448
4449 static gfc_loopinfo *
enter_nested_loop(gfc_se * se)4450 enter_nested_loop (gfc_se *se)
4451 {
4452 se->ss = se->ss->nested_ss;
4453 gcc_assert (se->ss == se->ss->loop->ss);
4454
4455 return se->ss->loop;
4456 }
4457
4458 /* Build the condition for a mask, which may be optional. */
4459
4460 static tree
conv_mask_condition(gfc_se * maskse,gfc_expr * maskexpr,bool optional_mask)4461 conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
4462 bool optional_mask)
4463 {
4464 tree present;
4465 tree type;
4466
4467 if (optional_mask)
4468 {
4469 type = TREE_TYPE (maskse->expr);
4470 present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
4471 present = convert (type, present);
4472 present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
4473 present);
4474 return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
4475 type, present, maskse->expr);
4476 }
4477 else
4478 return maskse->expr;
4479 }
4480
4481 /* Inline implementation of the sum and product intrinsics. */
4482 static void
gfc_conv_intrinsic_arith(gfc_se * se,gfc_expr * expr,enum tree_code op,bool norm2)4483 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4484 bool norm2)
4485 {
4486 tree resvar;
4487 tree scale = NULL_TREE;
4488 tree type;
4489 stmtblock_t body;
4490 stmtblock_t block;
4491 tree tmp;
4492 gfc_loopinfo loop, *ploop;
4493 gfc_actual_arglist *arg_array, *arg_mask;
4494 gfc_ss *arrayss = NULL;
4495 gfc_ss *maskss = NULL;
4496 gfc_se arrayse;
4497 gfc_se maskse;
4498 gfc_se *parent_se;
4499 gfc_expr *arrayexpr;
4500 gfc_expr *maskexpr;
4501 bool optional_mask;
4502
4503 if (expr->rank > 0)
4504 {
4505 gcc_assert (gfc_inline_intrinsic_function_p (expr));
4506 parent_se = se;
4507 }
4508 else
4509 parent_se = NULL;
4510
4511 type = gfc_typenode_for_spec (&expr->ts);
4512 /* Initialize the result. */
4513 resvar = gfc_create_var (type, "val");
4514 if (norm2)
4515 {
4516 /* result = 0.0;
4517 scale = 1.0. */
4518 scale = gfc_create_var (type, "scale");
4519 gfc_add_modify (&se->pre, scale,
4520 gfc_build_const (type, integer_one_node));
4521 tmp = gfc_build_const (type, integer_zero_node);
4522 }
4523 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4524 tmp = gfc_build_const (type, integer_zero_node);
4525 else if (op == NE_EXPR)
4526 /* PARITY. */
4527 tmp = convert (type, boolean_false_node);
4528 else if (op == BIT_AND_EXPR)
4529 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4530 type, integer_one_node));
4531 else
4532 tmp = gfc_build_const (type, integer_one_node);
4533
4534 gfc_add_modify (&se->pre, resvar, tmp);
4535
4536 arg_array = expr->value.function.actual;
4537
4538 arrayexpr = arg_array->expr;
4539
4540 if (op == NE_EXPR || norm2)
4541 {
4542 /* PARITY and NORM2. */
4543 maskexpr = NULL;
4544 optional_mask = false;
4545 }
4546 else
4547 {
4548 arg_mask = arg_array->next->next;
4549 gcc_assert (arg_mask != NULL);
4550 maskexpr = arg_mask->expr;
4551 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
4552 && maskexpr->symtree->n.sym->attr.dummy
4553 && maskexpr->symtree->n.sym->attr.optional;
4554 }
4555
4556 if (expr->rank == 0)
4557 {
4558 /* Walk the arguments. */
4559 arrayss = gfc_walk_expr (arrayexpr);
4560 gcc_assert (arrayss != gfc_ss_terminator);
4561
4562 if (maskexpr && maskexpr->rank > 0)
4563 {
4564 maskss = gfc_walk_expr (maskexpr);
4565 gcc_assert (maskss != gfc_ss_terminator);
4566 }
4567 else
4568 maskss = NULL;
4569
4570 /* Initialize the scalarizer. */
4571 gfc_init_loopinfo (&loop);
4572
4573 /* We add the mask first because the number of iterations is
4574 taken from the last ss, and this breaks if an absent
4575 optional argument is used for mask. */
4576
4577 if (maskexpr && maskexpr->rank > 0)
4578 gfc_add_ss_to_loop (&loop, maskss);
4579 gfc_add_ss_to_loop (&loop, arrayss);
4580
4581 /* Initialize the loop. */
4582 gfc_conv_ss_startstride (&loop);
4583 gfc_conv_loop_setup (&loop, &expr->where);
4584
4585 if (maskexpr && maskexpr->rank > 0)
4586 gfc_mark_ss_chain_used (maskss, 1);
4587 gfc_mark_ss_chain_used (arrayss, 1);
4588
4589 ploop = &loop;
4590 }
4591 else
4592 /* All the work has been done in the parent loops. */
4593 ploop = enter_nested_loop (se);
4594
4595 gcc_assert (ploop);
4596
4597 /* Generate the loop body. */
4598 gfc_start_scalarized_body (ploop, &body);
4599
4600 /* If we have a mask, only add this element if the mask is set. */
4601 if (maskexpr && maskexpr->rank > 0)
4602 {
4603 gfc_init_se (&maskse, parent_se);
4604 gfc_copy_loopinfo_to_se (&maskse, ploop);
4605 if (expr->rank == 0)
4606 maskse.ss = maskss;
4607 gfc_conv_expr_val (&maskse, maskexpr);
4608 gfc_add_block_to_block (&body, &maskse.pre);
4609
4610 gfc_start_block (&block);
4611 }
4612 else
4613 gfc_init_block (&block);
4614
4615 /* Do the actual summation/product. */
4616 gfc_init_se (&arrayse, parent_se);
4617 gfc_copy_loopinfo_to_se (&arrayse, ploop);
4618 if (expr->rank == 0)
4619 arrayse.ss = arrayss;
4620 gfc_conv_expr_val (&arrayse, arrayexpr);
4621 gfc_add_block_to_block (&block, &arrayse.pre);
4622
4623 if (norm2)
4624 {
4625 /* if (x (i) != 0.0)
4626 {
4627 absX = abs(x(i))
4628 if (absX > scale)
4629 {
4630 val = scale/absX;
4631 result = 1.0 + result * val * val;
4632 scale = absX;
4633 }
4634 else
4635 {
4636 val = absX/scale;
4637 result += val * val;
4638 }
4639 } */
4640 tree res1, res2, cond, absX, val;
4641 stmtblock_t ifblock1, ifblock2, ifblock3;
4642
4643 gfc_init_block (&ifblock1);
4644
4645 absX = gfc_create_var (type, "absX");
4646 gfc_add_modify (&ifblock1, absX,
4647 fold_build1_loc (input_location, ABS_EXPR, type,
4648 arrayse.expr));
4649 val = gfc_create_var (type, "val");
4650 gfc_add_expr_to_block (&ifblock1, val);
4651
4652 gfc_init_block (&ifblock2);
4653 gfc_add_modify (&ifblock2, val,
4654 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4655 absX));
4656 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4657 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4658 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4659 gfc_build_const (type, integer_one_node));
4660 gfc_add_modify (&ifblock2, resvar, res1);
4661 gfc_add_modify (&ifblock2, scale, absX);
4662 res1 = gfc_finish_block (&ifblock2);
4663
4664 gfc_init_block (&ifblock3);
4665 gfc_add_modify (&ifblock3, val,
4666 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4667 scale));
4668 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4669 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4670 gfc_add_modify (&ifblock3, resvar, res2);
4671 res2 = gfc_finish_block (&ifblock3);
4672
4673 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
4674 absX, scale);
4675 tmp = build3_v (COND_EXPR, cond, res1, res2);
4676 gfc_add_expr_to_block (&ifblock1, tmp);
4677 tmp = gfc_finish_block (&ifblock1);
4678
4679 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
4680 arrayse.expr,
4681 gfc_build_const (type, integer_zero_node));
4682
4683 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4684 gfc_add_expr_to_block (&block, tmp);
4685 }
4686 else
4687 {
4688 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4689 gfc_add_modify (&block, resvar, tmp);
4690 }
4691
4692 gfc_add_block_to_block (&block, &arrayse.post);
4693
4694 if (maskexpr && maskexpr->rank > 0)
4695 {
4696 /* We enclose the above in if (mask) {...} . If the mask is an
4697 optional argument, generate
4698 IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */
4699 tree ifmask;
4700 tmp = gfc_finish_block (&block);
4701 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4702 tmp = build3_v (COND_EXPR, ifmask, tmp,
4703 build_empty_stmt (input_location));
4704 }
4705 else
4706 tmp = gfc_finish_block (&block);
4707 gfc_add_expr_to_block (&body, tmp);
4708
4709 gfc_trans_scalarizing_loops (ploop, &body);
4710
4711 /* For a scalar mask, enclose the loop in an if statement. */
4712 if (maskexpr && maskexpr->rank == 0)
4713 {
4714 gfc_init_block (&block);
4715 gfc_add_block_to_block (&block, &ploop->pre);
4716 gfc_add_block_to_block (&block, &ploop->post);
4717 tmp = gfc_finish_block (&block);
4718
4719 if (expr->rank > 0)
4720 {
4721 tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4722 build_empty_stmt (input_location));
4723 gfc_advance_se_ss_chain (se);
4724 }
4725 else
4726 {
4727 tree ifmask;
4728
4729 gcc_assert (expr->rank == 0);
4730 gfc_init_se (&maskse, NULL);
4731 gfc_conv_expr_val (&maskse, maskexpr);
4732 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
4733 tmp = build3_v (COND_EXPR, ifmask, tmp,
4734 build_empty_stmt (input_location));
4735 }
4736
4737 gfc_add_expr_to_block (&block, tmp);
4738 gfc_add_block_to_block (&se->pre, &block);
4739 gcc_assert (se->post.head == NULL);
4740 }
4741 else
4742 {
4743 gfc_add_block_to_block (&se->pre, &ploop->pre);
4744 gfc_add_block_to_block (&se->pre, &ploop->post);
4745 }
4746
4747 if (expr->rank == 0)
4748 gfc_cleanup_loop (ploop);
4749
4750 if (norm2)
4751 {
4752 /* result = scale * sqrt(result). */
4753 tree sqrt;
4754 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4755 resvar = build_call_expr_loc (input_location,
4756 sqrt, 1, resvar);
4757 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4758 }
4759
4760 se->expr = resvar;
4761 }
4762
4763
4764 /* Inline implementation of the dot_product intrinsic. This function
4765 is based on gfc_conv_intrinsic_arith (the previous function). */
4766 static void
gfc_conv_intrinsic_dot_product(gfc_se * se,gfc_expr * expr)4767 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4768 {
4769 tree resvar;
4770 tree type;
4771 stmtblock_t body;
4772 stmtblock_t block;
4773 tree tmp;
4774 gfc_loopinfo loop;
4775 gfc_actual_arglist *actual;
4776 gfc_ss *arrayss1, *arrayss2;
4777 gfc_se arrayse1, arrayse2;
4778 gfc_expr *arrayexpr1, *arrayexpr2;
4779
4780 type = gfc_typenode_for_spec (&expr->ts);
4781
4782 /* Initialize the result. */
4783 resvar = gfc_create_var (type, "val");
4784 if (expr->ts.type == BT_LOGICAL)
4785 tmp = build_int_cst (type, 0);
4786 else
4787 tmp = gfc_build_const (type, integer_zero_node);
4788
4789 gfc_add_modify (&se->pre, resvar, tmp);
4790
4791 /* Walk argument #1. */
4792 actual = expr->value.function.actual;
4793 arrayexpr1 = actual->expr;
4794 arrayss1 = gfc_walk_expr (arrayexpr1);
4795 gcc_assert (arrayss1 != gfc_ss_terminator);
4796
4797 /* Walk argument #2. */
4798 actual = actual->next;
4799 arrayexpr2 = actual->expr;
4800 arrayss2 = gfc_walk_expr (arrayexpr2);
4801 gcc_assert (arrayss2 != gfc_ss_terminator);
4802
4803 /* Initialize the scalarizer. */
4804 gfc_init_loopinfo (&loop);
4805 gfc_add_ss_to_loop (&loop, arrayss1);
4806 gfc_add_ss_to_loop (&loop, arrayss2);
4807
4808 /* Initialize the loop. */
4809 gfc_conv_ss_startstride (&loop);
4810 gfc_conv_loop_setup (&loop, &expr->where);
4811
4812 gfc_mark_ss_chain_used (arrayss1, 1);
4813 gfc_mark_ss_chain_used (arrayss2, 1);
4814
4815 /* Generate the loop body. */
4816 gfc_start_scalarized_body (&loop, &body);
4817 gfc_init_block (&block);
4818
4819 /* Make the tree expression for [conjg(]array1[)]. */
4820 gfc_init_se (&arrayse1, NULL);
4821 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4822 arrayse1.ss = arrayss1;
4823 gfc_conv_expr_val (&arrayse1, arrayexpr1);
4824 if (expr->ts.type == BT_COMPLEX)
4825 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4826 arrayse1.expr);
4827 gfc_add_block_to_block (&block, &arrayse1.pre);
4828
4829 /* Make the tree expression for array2. */
4830 gfc_init_se (&arrayse2, NULL);
4831 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4832 arrayse2.ss = arrayss2;
4833 gfc_conv_expr_val (&arrayse2, arrayexpr2);
4834 gfc_add_block_to_block (&block, &arrayse2.pre);
4835
4836 /* Do the actual product and sum. */
4837 if (expr->ts.type == BT_LOGICAL)
4838 {
4839 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4840 arrayse1.expr, arrayse2.expr);
4841 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4842 }
4843 else
4844 {
4845 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4846 arrayse2.expr);
4847 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4848 }
4849 gfc_add_modify (&block, resvar, tmp);
4850
4851 /* Finish up the loop block and the loop. */
4852 tmp = gfc_finish_block (&block);
4853 gfc_add_expr_to_block (&body, tmp);
4854
4855 gfc_trans_scalarizing_loops (&loop, &body);
4856 gfc_add_block_to_block (&se->pre, &loop.pre);
4857 gfc_add_block_to_block (&se->pre, &loop.post);
4858 gfc_cleanup_loop (&loop);
4859
4860 se->expr = resvar;
4861 }
4862
4863
4864 /* Emit code for minloc or maxloc intrinsic. There are many different cases
4865 we need to handle. For performance reasons we sometimes create two
4866 loops instead of one, where the second one is much simpler.
4867 Examples for minloc intrinsic:
4868 1) Result is an array, a call is generated
4869 2) Array mask is used and NaNs need to be supported:
4870 limit = Infinity;
4871 pos = 0;
4872 S = from;
4873 while (S <= to) {
4874 if (mask[S]) {
4875 if (pos == 0) pos = S + (1 - from);
4876 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4877 }
4878 S++;
4879 }
4880 goto lab2;
4881 lab1:;
4882 while (S <= to) {
4883 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4884 S++;
4885 }
4886 lab2:;
4887 3) NaNs need to be supported, but it is known at compile time or cheaply
4888 at runtime whether array is nonempty or not:
4889 limit = Infinity;
4890 pos = 0;
4891 S = from;
4892 while (S <= to) {
4893 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4894 S++;
4895 }
4896 if (from <= to) pos = 1;
4897 goto lab2;
4898 lab1:;
4899 while (S <= to) {
4900 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4901 S++;
4902 }
4903 lab2:;
4904 4) NaNs aren't supported, array mask is used:
4905 limit = infinities_supported ? Infinity : huge (limit);
4906 pos = 0;
4907 S = from;
4908 while (S <= to) {
4909 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4910 S++;
4911 }
4912 goto lab2;
4913 lab1:;
4914 while (S <= to) {
4915 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4916 S++;
4917 }
4918 lab2:;
4919 5) Same without array mask:
4920 limit = infinities_supported ? Infinity : huge (limit);
4921 pos = (from <= to) ? 1 : 0;
4922 S = from;
4923 while (S <= to) {
4924 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4925 S++;
4926 }
4927 For 3) and 5), if mask is scalar, this all goes into a conditional,
4928 setting pos = 0; in the else branch.
4929
4930 Since we now also support the BACK argument, instead of using
4931 if (a[S] < limit), we now use
4932
4933 if (back)
4934 cond = a[S] <= limit;
4935 else
4936 cond = a[S] < limit;
4937 if (cond) {
4938 ....
4939
4940 The optimizer is smart enough to move the condition out of the loop.
4941 The are now marked as unlikely to for further speedup. */
4942
4943 static void
gfc_conv_intrinsic_minmaxloc(gfc_se * se,gfc_expr * expr,enum tree_code op)4944 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
4945 {
4946 stmtblock_t body;
4947 stmtblock_t block;
4948 stmtblock_t ifblock;
4949 stmtblock_t elseblock;
4950 tree limit;
4951 tree type;
4952 tree tmp;
4953 tree cond;
4954 tree elsetmp;
4955 tree ifbody;
4956 tree offset;
4957 tree nonempty;
4958 tree lab1, lab2;
4959 tree b_if, b_else;
4960 gfc_loopinfo loop;
4961 gfc_actual_arglist *actual;
4962 gfc_ss *arrayss;
4963 gfc_ss *maskss;
4964 gfc_se arrayse;
4965 gfc_se maskse;
4966 gfc_expr *arrayexpr;
4967 gfc_expr *maskexpr;
4968 gfc_expr *backexpr;
4969 gfc_se backse;
4970 tree pos;
4971 int n;
4972 bool optional_mask;
4973
4974 actual = expr->value.function.actual;
4975
4976 /* The last argument, BACK, is passed by value. Ensure that
4977 by setting its name to %VAL. */
4978 for (gfc_actual_arglist *a = actual; a; a = a->next)
4979 {
4980 if (a->next == NULL)
4981 a->name = "%VAL";
4982 }
4983
4984 if (se->ss)
4985 {
4986 gfc_conv_intrinsic_funcall (se, expr);
4987 return;
4988 }
4989
4990 arrayexpr = actual->expr;
4991
4992 /* Special case for character maxloc. Remove unneeded actual
4993 arguments, then call a library function. */
4994
4995 if (arrayexpr->ts.type == BT_CHARACTER)
4996 {
4997 gfc_actual_arglist *a, *b;
4998 a = actual;
4999 while (a->next)
5000 {
5001 b = a->next;
5002 if (b->expr == NULL || strcmp (b->name, "dim") == 0)
5003 {
5004 a->next = b->next;
5005 b->next = NULL;
5006 gfc_free_actual_arglist (b);
5007 }
5008 else
5009 a = b;
5010 }
5011 gfc_conv_intrinsic_funcall (se, expr);
5012 return;
5013 }
5014
5015 /* Initialize the result. */
5016 pos = gfc_create_var (gfc_array_index_type, "pos");
5017 offset = gfc_create_var (gfc_array_index_type, "offset");
5018 type = gfc_typenode_for_spec (&expr->ts);
5019
5020 /* Walk the arguments. */
5021 arrayss = gfc_walk_expr (arrayexpr);
5022 gcc_assert (arrayss != gfc_ss_terminator);
5023
5024 actual = actual->next->next;
5025 gcc_assert (actual);
5026 maskexpr = actual->expr;
5027 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5028 && maskexpr->symtree->n.sym->attr.dummy
5029 && maskexpr->symtree->n.sym->attr.optional;
5030 backexpr = actual->next->next->expr;
5031 nonempty = NULL;
5032 if (maskexpr && maskexpr->rank != 0)
5033 {
5034 maskss = gfc_walk_expr (maskexpr);
5035 gcc_assert (maskss != gfc_ss_terminator);
5036 }
5037 else
5038 {
5039 mpz_t asize;
5040 if (gfc_array_size (arrayexpr, &asize))
5041 {
5042 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5043 mpz_clear (asize);
5044 nonempty = fold_build2_loc (input_location, GT_EXPR,
5045 logical_type_node, nonempty,
5046 gfc_index_zero_node);
5047 }
5048 maskss = NULL;
5049 }
5050
5051 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
5052 switch (arrayexpr->ts.type)
5053 {
5054 case BT_REAL:
5055 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
5056 break;
5057
5058 case BT_INTEGER:
5059 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
5060 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
5061 arrayexpr->ts.kind);
5062 break;
5063
5064 default:
5065 gcc_unreachable ();
5066 }
5067
5068 /* We start with the most negative possible value for MAXLOC, and the most
5069 positive possible value for MINLOC. The most negative possible value is
5070 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5071 possible value is HUGE in both cases. */
5072 if (op == GT_EXPR)
5073 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5074 if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
5075 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
5076 build_int_cst (TREE_TYPE (tmp), 1));
5077
5078 gfc_add_modify (&se->pre, limit, tmp);
5079
5080 /* Initialize the scalarizer. */
5081 gfc_init_loopinfo (&loop);
5082
5083 /* We add the mask first because the number of iterations is taken
5084 from the last ss, and this breaks if an absent optional argument
5085 is used for mask. */
5086
5087 if (maskss)
5088 gfc_add_ss_to_loop (&loop, maskss);
5089
5090 gfc_add_ss_to_loop (&loop, arrayss);
5091
5092 /* Initialize the loop. */
5093 gfc_conv_ss_startstride (&loop);
5094
5095 /* The code generated can have more than one loop in sequence (see the
5096 comment at the function header). This doesn't work well with the
5097 scalarizer, which changes arrays' offset when the scalarization loops
5098 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
5099 are currently inlined in the scalar case only (for which loop is of rank
5100 one). As there is no dependency to care about in that case, there is no
5101 temporary, so that we can use the scalarizer temporary code to handle
5102 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
5103 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
5104 to restore offset.
5105 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
5106 should eventually go away. We could either create two loops properly,
5107 or find another way to save/restore the array offsets between the two
5108 loops (without conflicting with temporary management), or use a single
5109 loop minmaxloc implementation. See PR 31067. */
5110 loop.temp_dim = loop.dimen;
5111 gfc_conv_loop_setup (&loop, &expr->where);
5112
5113 gcc_assert (loop.dimen == 1);
5114 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
5115 nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5116 loop.from[0], loop.to[0]);
5117
5118 lab1 = NULL;
5119 lab2 = NULL;
5120 /* Initialize the position to zero, following Fortran 2003. We are free
5121 to do this because Fortran 95 allows the result of an entirely false
5122 mask to be processor dependent. If we know at compile time the array
5123 is non-empty and no MASK is used, we can initialize to 1 to simplify
5124 the inner loop. */
5125 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
5126 gfc_add_modify (&loop.pre, pos,
5127 fold_build3_loc (input_location, COND_EXPR,
5128 gfc_array_index_type,
5129 nonempty, gfc_index_one_node,
5130 gfc_index_zero_node));
5131 else
5132 {
5133 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
5134 lab1 = gfc_build_label_decl (NULL_TREE);
5135 TREE_USED (lab1) = 1;
5136 lab2 = gfc_build_label_decl (NULL_TREE);
5137 TREE_USED (lab2) = 1;
5138 }
5139
5140 /* An offset must be added to the loop
5141 counter to obtain the required position. */
5142 gcc_assert (loop.from[0]);
5143
5144 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5145 gfc_index_one_node, loop.from[0]);
5146 gfc_add_modify (&loop.pre, offset, tmp);
5147
5148 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
5149 if (maskss)
5150 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
5151 /* Generate the loop body. */
5152 gfc_start_scalarized_body (&loop, &body);
5153
5154 /* If we have a mask, only check this element if the mask is set. */
5155 if (maskss)
5156 {
5157 gfc_init_se (&maskse, NULL);
5158 gfc_copy_loopinfo_to_se (&maskse, &loop);
5159 maskse.ss = maskss;
5160 gfc_conv_expr_val (&maskse, maskexpr);
5161 gfc_add_block_to_block (&body, &maskse.pre);
5162
5163 gfc_start_block (&block);
5164 }
5165 else
5166 gfc_init_block (&block);
5167
5168 /* Compare with the current limit. */
5169 gfc_init_se (&arrayse, NULL);
5170 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5171 arrayse.ss = arrayss;
5172 gfc_conv_expr_val (&arrayse, arrayexpr);
5173 gfc_add_block_to_block (&block, &arrayse.pre);
5174
5175 gfc_init_se (&backse, NULL);
5176 gfc_conv_expr_val (&backse, backexpr);
5177 gfc_add_block_to_block (&block, &backse.pre);
5178
5179 /* We do the following if this is a more extreme value. */
5180 gfc_start_block (&ifblock);
5181
5182 /* Assign the value to the limit... */
5183 gfc_add_modify (&ifblock, limit, arrayse.expr);
5184
5185 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
5186 {
5187 stmtblock_t ifblock2;
5188 tree ifbody2;
5189
5190 gfc_start_block (&ifblock2);
5191 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5192 loop.loopvar[0], offset);
5193 gfc_add_modify (&ifblock2, pos, tmp);
5194 ifbody2 = gfc_finish_block (&ifblock2);
5195 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos,
5196 gfc_index_zero_node);
5197 tmp = build3_v (COND_EXPR, cond, ifbody2,
5198 build_empty_stmt (input_location));
5199 gfc_add_expr_to_block (&block, tmp);
5200 }
5201
5202 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5203 loop.loopvar[0], offset);
5204 gfc_add_modify (&ifblock, pos, tmp);
5205
5206 if (lab1)
5207 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
5208
5209 ifbody = gfc_finish_block (&ifblock);
5210
5211 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
5212 {
5213 if (lab1)
5214 cond = fold_build2_loc (input_location,
5215 op == GT_EXPR ? GE_EXPR : LE_EXPR,
5216 logical_type_node, arrayse.expr, limit);
5217 else
5218 {
5219 tree ifbody2, elsebody2;
5220
5221 /* We switch to > or >= depending on the value of the BACK argument. */
5222 cond = gfc_create_var (logical_type_node, "cond");
5223
5224 gfc_start_block (&ifblock);
5225 b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5226 logical_type_node, arrayse.expr, limit);
5227
5228 gfc_add_modify (&ifblock, cond, b_if);
5229 ifbody2 = gfc_finish_block (&ifblock);
5230
5231 gfc_start_block (&elseblock);
5232 b_else = fold_build2_loc (input_location, op, logical_type_node,
5233 arrayse.expr, limit);
5234
5235 gfc_add_modify (&elseblock, cond, b_else);
5236 elsebody2 = gfc_finish_block (&elseblock);
5237
5238 tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5239 backse.expr, ifbody2, elsebody2);
5240
5241 gfc_add_expr_to_block (&block, tmp);
5242 }
5243
5244 cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5245 ifbody = build3_v (COND_EXPR, cond, ifbody,
5246 build_empty_stmt (input_location));
5247 }
5248 gfc_add_expr_to_block (&block, ifbody);
5249
5250 if (maskss)
5251 {
5252 /* We enclose the above in if (mask) {...}. If the mask is an
5253 optional argument, generate IF (.NOT. PRESENT(MASK)
5254 .OR. MASK(I)). */
5255
5256 tree ifmask;
5257 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5258 tmp = gfc_finish_block (&block);
5259 tmp = build3_v (COND_EXPR, ifmask, tmp,
5260 build_empty_stmt (input_location));
5261 }
5262 else
5263 tmp = gfc_finish_block (&block);
5264 gfc_add_expr_to_block (&body, tmp);
5265
5266 if (lab1)
5267 {
5268 gfc_trans_scalarized_loop_boundary (&loop, &body);
5269
5270 if (HONOR_NANS (DECL_MODE (limit)))
5271 {
5272 if (nonempty != NULL)
5273 {
5274 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
5275 tmp = build3_v (COND_EXPR, nonempty, ifbody,
5276 build_empty_stmt (input_location));
5277 gfc_add_expr_to_block (&loop.code[0], tmp);
5278 }
5279 }
5280
5281 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
5282 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
5283
5284 /* If we have a mask, only check this element if the mask is set. */
5285 if (maskss)
5286 {
5287 gfc_init_se (&maskse, NULL);
5288 gfc_copy_loopinfo_to_se (&maskse, &loop);
5289 maskse.ss = maskss;
5290 gfc_conv_expr_val (&maskse, maskexpr);
5291 gfc_add_block_to_block (&body, &maskse.pre);
5292
5293 gfc_start_block (&block);
5294 }
5295 else
5296 gfc_init_block (&block);
5297
5298 /* Compare with the current limit. */
5299 gfc_init_se (&arrayse, NULL);
5300 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5301 arrayse.ss = arrayss;
5302 gfc_conv_expr_val (&arrayse, arrayexpr);
5303 gfc_add_block_to_block (&block, &arrayse.pre);
5304
5305 /* We do the following if this is a more extreme value. */
5306 gfc_start_block (&ifblock);
5307
5308 /* Assign the value to the limit... */
5309 gfc_add_modify (&ifblock, limit, arrayse.expr);
5310
5311 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
5312 loop.loopvar[0], offset);
5313 gfc_add_modify (&ifblock, pos, tmp);
5314
5315 ifbody = gfc_finish_block (&ifblock);
5316
5317 /* We switch to > or >= depending on the value of the BACK argument. */
5318 {
5319 tree ifbody2, elsebody2;
5320
5321 cond = gfc_create_var (logical_type_node, "cond");
5322
5323 gfc_start_block (&ifblock);
5324 b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5325 logical_type_node, arrayse.expr, limit);
5326
5327 gfc_add_modify (&ifblock, cond, b_if);
5328 ifbody2 = gfc_finish_block (&ifblock);
5329
5330 gfc_start_block (&elseblock);
5331 b_else = fold_build2_loc (input_location, op, logical_type_node,
5332 arrayse.expr, limit);
5333
5334 gfc_add_modify (&elseblock, cond, b_else);
5335 elsebody2 = gfc_finish_block (&elseblock);
5336
5337 tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
5338 backse.expr, ifbody2, elsebody2);
5339 }
5340
5341 gfc_add_expr_to_block (&block, tmp);
5342 cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
5343 tmp = build3_v (COND_EXPR, cond, ifbody,
5344 build_empty_stmt (input_location));
5345
5346 gfc_add_expr_to_block (&block, tmp);
5347
5348 if (maskss)
5349 {
5350 /* We enclose the above in if (mask) {...}. If the mask is
5351 an optional argument, generate IF (.NOT. PRESENT(MASK)
5352 .OR. MASK(I)).*/
5353
5354 tree ifmask;
5355 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5356 tmp = gfc_finish_block (&block);
5357 tmp = build3_v (COND_EXPR, ifmask, tmp,
5358 build_empty_stmt (input_location));
5359 }
5360 else
5361 tmp = gfc_finish_block (&block);
5362 gfc_add_expr_to_block (&body, tmp);
5363 /* Avoid initializing loopvar[0] again, it should be left where
5364 it finished by the first loop. */
5365 loop.from[0] = loop.loopvar[0];
5366 }
5367
5368 gfc_trans_scalarizing_loops (&loop, &body);
5369
5370 if (lab2)
5371 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
5372
5373 /* For a scalar mask, enclose the loop in an if statement. */
5374 if (maskexpr && maskss == NULL)
5375 {
5376 tree ifmask;
5377
5378 gfc_init_se (&maskse, NULL);
5379 gfc_conv_expr_val (&maskse, maskexpr);
5380 gfc_init_block (&block);
5381 gfc_add_block_to_block (&block, &loop.pre);
5382 gfc_add_block_to_block (&block, &loop.post);
5383 tmp = gfc_finish_block (&block);
5384
5385 /* For the else part of the scalar mask, just initialize
5386 the pos variable the same way as above. */
5387
5388 gfc_init_block (&elseblock);
5389 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
5390 elsetmp = gfc_finish_block (&elseblock);
5391 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5392 tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
5393 gfc_add_expr_to_block (&block, tmp);
5394 gfc_add_block_to_block (&se->pre, &block);
5395 }
5396 else
5397 {
5398 gfc_add_block_to_block (&se->pre, &loop.pre);
5399 gfc_add_block_to_block (&se->pre, &loop.post);
5400 }
5401 gfc_cleanup_loop (&loop);
5402
5403 se->expr = convert (type, pos);
5404 }
5405
5406 /* Emit code for findloc. */
5407
5408 static void
gfc_conv_intrinsic_findloc(gfc_se * se,gfc_expr * expr)5409 gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
5410 {
5411 gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
5412 *kind_arg, *back_arg;
5413 gfc_expr *value_expr;
5414 int ikind;
5415 tree resvar;
5416 stmtblock_t block;
5417 stmtblock_t body;
5418 stmtblock_t loopblock;
5419 tree type;
5420 tree tmp;
5421 tree found;
5422 tree forward_branch;
5423 tree back_branch;
5424 gfc_loopinfo loop;
5425 gfc_ss *arrayss;
5426 gfc_ss *maskss;
5427 gfc_se arrayse;
5428 gfc_se valuese;
5429 gfc_se maskse;
5430 gfc_se backse;
5431 tree exit_label;
5432 gfc_expr *maskexpr;
5433 tree offset;
5434 int i;
5435 bool optional_mask;
5436
5437 array_arg = expr->value.function.actual;
5438 value_arg = array_arg->next;
5439 dim_arg = value_arg->next;
5440 mask_arg = dim_arg->next;
5441 kind_arg = mask_arg->next;
5442 back_arg = kind_arg->next;
5443
5444 /* Remove kind and set ikind. */
5445 if (kind_arg->expr)
5446 {
5447 ikind = mpz_get_si (kind_arg->expr->value.integer);
5448 gfc_free_expr (kind_arg->expr);
5449 kind_arg->expr = NULL;
5450 }
5451 else
5452 ikind = gfc_default_integer_kind;
5453
5454 value_expr = value_arg->expr;
5455
5456 /* Unless it's a string, pass VALUE by value. */
5457 if (value_expr->ts.type != BT_CHARACTER)
5458 value_arg->name = "%VAL";
5459
5460 /* Pass BACK argument by value. */
5461 back_arg->name = "%VAL";
5462
5463 /* Call the library if we have a character function or if
5464 rank > 0. */
5465 if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
5466 {
5467 se->ignore_optional = 1;
5468 if (expr->rank == 0)
5469 {
5470 /* Remove dim argument. */
5471 gfc_free_expr (dim_arg->expr);
5472 dim_arg->expr = NULL;
5473 }
5474 gfc_conv_intrinsic_funcall (se, expr);
5475 return;
5476 }
5477
5478 type = gfc_get_int_type (ikind);
5479
5480 /* Initialize the result. */
5481 resvar = gfc_create_var (gfc_array_index_type, "pos");
5482 gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
5483 offset = gfc_create_var (gfc_array_index_type, "offset");
5484
5485 maskexpr = mask_arg->expr;
5486 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5487 && maskexpr->symtree->n.sym->attr.dummy
5488 && maskexpr->symtree->n.sym->attr.optional;
5489
5490 /* Generate two loops, one for BACK=.true. and one for BACK=.false. */
5491
5492 for (i = 0 ; i < 2; i++)
5493 {
5494 /* Walk the arguments. */
5495 arrayss = gfc_walk_expr (array_arg->expr);
5496 gcc_assert (arrayss != gfc_ss_terminator);
5497
5498 if (maskexpr && maskexpr->rank != 0)
5499 {
5500 maskss = gfc_walk_expr (maskexpr);
5501 gcc_assert (maskss != gfc_ss_terminator);
5502 }
5503 else
5504 maskss = NULL;
5505
5506 /* Initialize the scalarizer. */
5507 gfc_init_loopinfo (&loop);
5508 exit_label = gfc_build_label_decl (NULL_TREE);
5509 TREE_USED (exit_label) = 1;
5510
5511 /* We add the mask first because the number of iterations is
5512 taken from the last ss, and this breaks if an absent
5513 optional argument is used for mask. */
5514
5515 if (maskss)
5516 gfc_add_ss_to_loop (&loop, maskss);
5517 gfc_add_ss_to_loop (&loop, arrayss);
5518
5519 /* Initialize the loop. */
5520 gfc_conv_ss_startstride (&loop);
5521 gfc_conv_loop_setup (&loop, &expr->where);
5522
5523 /* Calculate the offset. */
5524 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5525 gfc_index_one_node, loop.from[0]);
5526 gfc_add_modify (&loop.pre, offset, tmp);
5527
5528 gfc_mark_ss_chain_used (arrayss, 1);
5529 if (maskss)
5530 gfc_mark_ss_chain_used (maskss, 1);
5531
5532 /* The first loop is for BACK=.true. */
5533 if (i == 0)
5534 loop.reverse[0] = GFC_REVERSE_SET;
5535
5536 /* Generate the loop body. */
5537 gfc_start_scalarized_body (&loop, &body);
5538
5539 /* If we have an array mask, only add the element if it is
5540 set. */
5541 if (maskss)
5542 {
5543 gfc_init_se (&maskse, NULL);
5544 gfc_copy_loopinfo_to_se (&maskse, &loop);
5545 maskse.ss = maskss;
5546 gfc_conv_expr_val (&maskse, maskexpr);
5547 gfc_add_block_to_block (&body, &maskse.pre);
5548 }
5549
5550 /* If the condition matches then set the return value. */
5551 gfc_start_block (&block);
5552
5553 /* Add the offset. */
5554 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5555 TREE_TYPE (resvar),
5556 loop.loopvar[0], offset);
5557 gfc_add_modify (&block, resvar, tmp);
5558 /* And break out of the loop. */
5559 tmp = build1_v (GOTO_EXPR, exit_label);
5560 gfc_add_expr_to_block (&block, tmp);
5561
5562 found = gfc_finish_block (&block);
5563
5564 /* Check this element. */
5565 gfc_init_se (&arrayse, NULL);
5566 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5567 arrayse.ss = arrayss;
5568 gfc_conv_expr_val (&arrayse, array_arg->expr);
5569 gfc_add_block_to_block (&body, &arrayse.pre);
5570
5571 gfc_init_se (&valuese, NULL);
5572 gfc_conv_expr_val (&valuese, value_arg->expr);
5573 gfc_add_block_to_block (&body, &valuese.pre);
5574
5575 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5576 arrayse.expr, valuese.expr);
5577
5578 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
5579 if (maskss)
5580 {
5581 /* We enclose the above in if (mask) {...}. If the mask is
5582 an optional argument, generate IF (.NOT. PRESENT(MASK)
5583 .OR. MASK(I)). */
5584
5585 tree ifmask;
5586 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5587 tmp = build3_v (COND_EXPR, ifmask, tmp,
5588 build_empty_stmt (input_location));
5589 }
5590
5591 gfc_add_expr_to_block (&body, tmp);
5592 gfc_add_block_to_block (&body, &arrayse.post);
5593
5594 gfc_trans_scalarizing_loops (&loop, &body);
5595
5596 /* Add the exit label. */
5597 tmp = build1_v (LABEL_EXPR, exit_label);
5598 gfc_add_expr_to_block (&loop.pre, tmp);
5599 gfc_start_block (&loopblock);
5600 gfc_add_block_to_block (&loopblock, &loop.pre);
5601 gfc_add_block_to_block (&loopblock, &loop.post);
5602 if (i == 0)
5603 forward_branch = gfc_finish_block (&loopblock);
5604 else
5605 back_branch = gfc_finish_block (&loopblock);
5606
5607 gfc_cleanup_loop (&loop);
5608 }
5609
5610 /* Enclose the two loops in an IF statement. */
5611
5612 gfc_init_se (&backse, NULL);
5613 gfc_conv_expr_val (&backse, back_arg->expr);
5614 gfc_add_block_to_block (&se->pre, &backse.pre);
5615 tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
5616
5617 /* For a scalar mask, enclose the loop in an if statement. */
5618 if (maskexpr && maskss == NULL)
5619 {
5620 tree ifmask;
5621 tree if_stmt;
5622
5623 gfc_init_se (&maskse, NULL);
5624 gfc_conv_expr_val (&maskse, maskexpr);
5625 gfc_init_block (&block);
5626 gfc_add_expr_to_block (&block, maskse.expr);
5627 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
5628 if_stmt = build3_v (COND_EXPR, ifmask, tmp,
5629 build_empty_stmt (input_location));
5630 gfc_add_expr_to_block (&block, if_stmt);
5631 tmp = gfc_finish_block (&block);
5632 }
5633
5634 gfc_add_expr_to_block (&se->pre, tmp);
5635 se->expr = convert (type, resvar);
5636
5637 }
5638
5639 /* Emit code for minval or maxval intrinsic. There are many different cases
5640 we need to handle. For performance reasons we sometimes create two
5641 loops instead of one, where the second one is much simpler.
5642 Examples for minval intrinsic:
5643 1) Result is an array, a call is generated
5644 2) Array mask is used and NaNs need to be supported, rank 1:
5645 limit = Infinity;
5646 nonempty = false;
5647 S = from;
5648 while (S <= to) {
5649 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
5650 S++;
5651 }
5652 limit = nonempty ? NaN : huge (limit);
5653 lab:
5654 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
5655 3) NaNs need to be supported, but it is known at compile time or cheaply
5656 at runtime whether array is nonempty or not, rank 1:
5657 limit = Infinity;
5658 S = from;
5659 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
5660 limit = (from <= to) ? NaN : huge (limit);
5661 lab:
5662 while (S <= to) { limit = min (a[S], limit); S++; }
5663 4) Array mask is used and NaNs need to be supported, rank > 1:
5664 limit = Infinity;
5665 nonempty = false;
5666 fast = false;
5667 S1 = from1;
5668 while (S1 <= to1) {
5669 S2 = from2;
5670 while (S2 <= to2) {
5671 if (mask[S1][S2]) {
5672 if (fast) limit = min (a[S1][S2], limit);
5673 else {
5674 nonempty = true;
5675 if (a[S1][S2] <= limit) {
5676 limit = a[S1][S2];
5677 fast = true;
5678 }
5679 }
5680 }
5681 S2++;
5682 }
5683 S1++;
5684 }
5685 if (!fast)
5686 limit = nonempty ? NaN : huge (limit);
5687 5) NaNs need to be supported, but it is known at compile time or cheaply
5688 at runtime whether array is nonempty or not, rank > 1:
5689 limit = Infinity;
5690 fast = false;
5691 S1 = from1;
5692 while (S1 <= to1) {
5693 S2 = from2;
5694 while (S2 <= to2) {
5695 if (fast) limit = min (a[S1][S2], limit);
5696 else {
5697 if (a[S1][S2] <= limit) {
5698 limit = a[S1][S2];
5699 fast = true;
5700 }
5701 }
5702 S2++;
5703 }
5704 S1++;
5705 }
5706 if (!fast)
5707 limit = (nonempty_array) ? NaN : huge (limit);
5708 6) NaNs aren't supported, but infinities are. Array mask is used:
5709 limit = Infinity;
5710 nonempty = false;
5711 S = from;
5712 while (S <= to) {
5713 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
5714 S++;
5715 }
5716 limit = nonempty ? limit : huge (limit);
5717 7) Same without array mask:
5718 limit = Infinity;
5719 S = from;
5720 while (S <= to) { limit = min (a[S], limit); S++; }
5721 limit = (from <= to) ? limit : huge (limit);
5722 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
5723 limit = huge (limit);
5724 S = from;
5725 while (S <= to) { limit = min (a[S], limit); S++); }
5726 (or
5727 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
5728 with array mask instead).
5729 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
5730 setting limit = huge (limit); in the else branch. */
5731
5732 static void
gfc_conv_intrinsic_minmaxval(gfc_se * se,gfc_expr * expr,enum tree_code op)5733 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
5734 {
5735 tree limit;
5736 tree type;
5737 tree tmp;
5738 tree ifbody;
5739 tree nonempty;
5740 tree nonempty_var;
5741 tree lab;
5742 tree fast;
5743 tree huge_cst = NULL, nan_cst = NULL;
5744 stmtblock_t body;
5745 stmtblock_t block, block2;
5746 gfc_loopinfo loop;
5747 gfc_actual_arglist *actual;
5748 gfc_ss *arrayss;
5749 gfc_ss *maskss;
5750 gfc_se arrayse;
5751 gfc_se maskse;
5752 gfc_expr *arrayexpr;
5753 gfc_expr *maskexpr;
5754 int n;
5755 bool optional_mask;
5756
5757 if (se->ss)
5758 {
5759 gfc_conv_intrinsic_funcall (se, expr);
5760 return;
5761 }
5762
5763 actual = expr->value.function.actual;
5764 arrayexpr = actual->expr;
5765
5766 if (arrayexpr->ts.type == BT_CHARACTER)
5767 {
5768 gfc_actual_arglist *a2, *a3;
5769 a2 = actual->next; /* dim */
5770 a3 = a2->next; /* mask */
5771 if (a2->expr == NULL || expr->rank == 0)
5772 {
5773 if (a3->expr == NULL)
5774 actual->next = NULL;
5775 else
5776 {
5777 actual->next = a3;
5778 a2->next = NULL;
5779 }
5780 gfc_free_actual_arglist (a2);
5781 }
5782 else
5783 if (a3->expr == NULL)
5784 {
5785 a2->next = NULL;
5786 gfc_free_actual_arglist (a3);
5787 }
5788 gfc_conv_intrinsic_funcall (se, expr);
5789 return;
5790 }
5791 type = gfc_typenode_for_spec (&expr->ts);
5792 /* Initialize the result. */
5793 limit = gfc_create_var (type, "limit");
5794 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
5795 switch (expr->ts.type)
5796 {
5797 case BT_REAL:
5798 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
5799 expr->ts.kind, 0);
5800 if (HONOR_INFINITIES (DECL_MODE (limit)))
5801 {
5802 REAL_VALUE_TYPE real;
5803 real_inf (&real);
5804 tmp = build_real (type, real);
5805 }
5806 else
5807 tmp = huge_cst;
5808 if (HONOR_NANS (DECL_MODE (limit)))
5809 nan_cst = gfc_build_nan (type, "");
5810 break;
5811
5812 case BT_INTEGER:
5813 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
5814 break;
5815
5816 default:
5817 gcc_unreachable ();
5818 }
5819
5820 /* We start with the most negative possible value for MAXVAL, and the most
5821 positive possible value for MINVAL. The most negative possible value is
5822 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5823 possible value is HUGE in both cases. */
5824 if (op == GT_EXPR)
5825 {
5826 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5827 if (huge_cst)
5828 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
5829 TREE_TYPE (huge_cst), huge_cst);
5830 }
5831
5832 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
5833 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5834 tmp, build_int_cst (type, 1));
5835
5836 gfc_add_modify (&se->pre, limit, tmp);
5837
5838 /* Walk the arguments. */
5839 arrayss = gfc_walk_expr (arrayexpr);
5840 gcc_assert (arrayss != gfc_ss_terminator);
5841
5842 actual = actual->next->next;
5843 gcc_assert (actual);
5844 maskexpr = actual->expr;
5845 optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
5846 && maskexpr->symtree->n.sym->attr.dummy
5847 && maskexpr->symtree->n.sym->attr.optional;
5848 nonempty = NULL;
5849 if (maskexpr && maskexpr->rank != 0)
5850 {
5851 maskss = gfc_walk_expr (maskexpr);
5852 gcc_assert (maskss != gfc_ss_terminator);
5853 }
5854 else
5855 {
5856 mpz_t asize;
5857 if (gfc_array_size (arrayexpr, &asize))
5858 {
5859 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5860 mpz_clear (asize);
5861 nonempty = fold_build2_loc (input_location, GT_EXPR,
5862 logical_type_node, nonempty,
5863 gfc_index_zero_node);
5864 }
5865 maskss = NULL;
5866 }
5867
5868 /* Initialize the scalarizer. */
5869 gfc_init_loopinfo (&loop);
5870
5871 /* We add the mask first because the number of iterations is taken
5872 from the last ss, and this breaks if an absent optional argument
5873 is used for mask. */
5874
5875 if (maskss)
5876 gfc_add_ss_to_loop (&loop, maskss);
5877 gfc_add_ss_to_loop (&loop, arrayss);
5878
5879 /* Initialize the loop. */
5880 gfc_conv_ss_startstride (&loop);
5881
5882 /* The code generated can have more than one loop in sequence (see the
5883 comment at the function header). This doesn't work well with the
5884 scalarizer, which changes arrays' offset when the scalarization loops
5885 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
5886 are currently inlined in the scalar case only. As there is no dependency
5887 to care about in that case, there is no temporary, so that we can use the
5888 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
5889 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5890 gfc_trans_scalarized_loop_boundary even later to restore offset.
5891 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5892 should eventually go away. We could either create two loops properly,
5893 or find another way to save/restore the array offsets between the two
5894 loops (without conflicting with temporary management), or use a single
5895 loop minmaxval implementation. See PR 31067. */
5896 loop.temp_dim = loop.dimen;
5897 gfc_conv_loop_setup (&loop, &expr->where);
5898
5899 if (nonempty == NULL && maskss == NULL
5900 && loop.dimen == 1 && loop.from[0] && loop.to[0])
5901 nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
5902 loop.from[0], loop.to[0]);
5903 nonempty_var = NULL;
5904 if (nonempty == NULL
5905 && (HONOR_INFINITIES (DECL_MODE (limit))
5906 || HONOR_NANS (DECL_MODE (limit))))
5907 {
5908 nonempty_var = gfc_create_var (logical_type_node, "nonempty");
5909 gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
5910 nonempty = nonempty_var;
5911 }
5912 lab = NULL;
5913 fast = NULL;
5914 if (HONOR_NANS (DECL_MODE (limit)))
5915 {
5916 if (loop.dimen == 1)
5917 {
5918 lab = gfc_build_label_decl (NULL_TREE);
5919 TREE_USED (lab) = 1;
5920 }
5921 else
5922 {
5923 fast = gfc_create_var (logical_type_node, "fast");
5924 gfc_add_modify (&se->pre, fast, logical_false_node);
5925 }
5926 }
5927
5928 gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
5929 if (maskss)
5930 gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
5931 /* Generate the loop body. */
5932 gfc_start_scalarized_body (&loop, &body);
5933
5934 /* If we have a mask, only add this element if the mask is set. */
5935 if (maskss)
5936 {
5937 gfc_init_se (&maskse, NULL);
5938 gfc_copy_loopinfo_to_se (&maskse, &loop);
5939 maskse.ss = maskss;
5940 gfc_conv_expr_val (&maskse, maskexpr);
5941 gfc_add_block_to_block (&body, &maskse.pre);
5942
5943 gfc_start_block (&block);
5944 }
5945 else
5946 gfc_init_block (&block);
5947
5948 /* Compare with the current limit. */
5949 gfc_init_se (&arrayse, NULL);
5950 gfc_copy_loopinfo_to_se (&arrayse, &loop);
5951 arrayse.ss = arrayss;
5952 gfc_conv_expr_val (&arrayse, arrayexpr);
5953 gfc_add_block_to_block (&block, &arrayse.pre);
5954
5955 gfc_init_block (&block2);
5956
5957 if (nonempty_var)
5958 gfc_add_modify (&block2, nonempty_var, logical_true_node);
5959
5960 if (HONOR_NANS (DECL_MODE (limit)))
5961 {
5962 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5963 logical_type_node, arrayse.expr, limit);
5964 if (lab)
5965 ifbody = build1_v (GOTO_EXPR, lab);
5966 else
5967 {
5968 stmtblock_t ifblock;
5969
5970 gfc_init_block (&ifblock);
5971 gfc_add_modify (&ifblock, limit, arrayse.expr);
5972 gfc_add_modify (&ifblock, fast, logical_true_node);
5973 ifbody = gfc_finish_block (&ifblock);
5974 }
5975 tmp = build3_v (COND_EXPR, tmp, ifbody,
5976 build_empty_stmt (input_location));
5977 gfc_add_expr_to_block (&block2, tmp);
5978 }
5979 else
5980 {
5981 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5982 signed zeros. */
5983 tmp = fold_build2_loc (input_location,
5984 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5985 type, arrayse.expr, limit);
5986 gfc_add_modify (&block2, limit, tmp);
5987 }
5988
5989 if (fast)
5990 {
5991 tree elsebody = gfc_finish_block (&block2);
5992
5993 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5994 signed zeros. */
5995 if (HONOR_NANS (DECL_MODE (limit)))
5996 {
5997 tmp = fold_build2_loc (input_location, op, logical_type_node,
5998 arrayse.expr, limit);
5999 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6000 ifbody = build3_v (COND_EXPR, tmp, ifbody,
6001 build_empty_stmt (input_location));
6002 }
6003 else
6004 {
6005 tmp = fold_build2_loc (input_location,
6006 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6007 type, arrayse.expr, limit);
6008 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6009 }
6010 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
6011 gfc_add_expr_to_block (&block, tmp);
6012 }
6013 else
6014 gfc_add_block_to_block (&block, &block2);
6015
6016 gfc_add_block_to_block (&block, &arrayse.post);
6017
6018 tmp = gfc_finish_block (&block);
6019 if (maskss)
6020 {
6021 /* We enclose the above in if (mask) {...}. If the mask is an
6022 optional argument, generate IF (.NOT. PRESENT(MASK)
6023 .OR. MASK(I)). */
6024 tree ifmask;
6025 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6026 tmp = build3_v (COND_EXPR, ifmask, tmp,
6027 build_empty_stmt (input_location));
6028 }
6029 gfc_add_expr_to_block (&body, tmp);
6030
6031 if (lab)
6032 {
6033 gfc_trans_scalarized_loop_boundary (&loop, &body);
6034
6035 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6036 nan_cst, huge_cst);
6037 gfc_add_modify (&loop.code[0], limit, tmp);
6038 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
6039
6040 /* If we have a mask, only add this element if the mask is set. */
6041 if (maskss)
6042 {
6043 gfc_init_se (&maskse, NULL);
6044 gfc_copy_loopinfo_to_se (&maskse, &loop);
6045 maskse.ss = maskss;
6046 gfc_conv_expr_val (&maskse, maskexpr);
6047 gfc_add_block_to_block (&body, &maskse.pre);
6048
6049 gfc_start_block (&block);
6050 }
6051 else
6052 gfc_init_block (&block);
6053
6054 /* Compare with the current limit. */
6055 gfc_init_se (&arrayse, NULL);
6056 gfc_copy_loopinfo_to_se (&arrayse, &loop);
6057 arrayse.ss = arrayss;
6058 gfc_conv_expr_val (&arrayse, arrayexpr);
6059 gfc_add_block_to_block (&block, &arrayse.pre);
6060
6061 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
6062 signed zeros. */
6063 if (HONOR_NANS (DECL_MODE (limit)))
6064 {
6065 tmp = fold_build2_loc (input_location, op, logical_type_node,
6066 arrayse.expr, limit);
6067 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
6068 tmp = build3_v (COND_EXPR, tmp, ifbody,
6069 build_empty_stmt (input_location));
6070 gfc_add_expr_to_block (&block, tmp);
6071 }
6072 else
6073 {
6074 tmp = fold_build2_loc (input_location,
6075 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
6076 type, arrayse.expr, limit);
6077 gfc_add_modify (&block, limit, tmp);
6078 }
6079
6080 gfc_add_block_to_block (&block, &arrayse.post);
6081
6082 tmp = gfc_finish_block (&block);
6083 if (maskss)
6084 /* We enclose the above in if (mask) {...}. */
6085 {
6086 tree ifmask;
6087 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6088 tmp = build3_v (COND_EXPR, ifmask, tmp,
6089 build_empty_stmt (input_location));
6090 }
6091
6092 gfc_add_expr_to_block (&body, tmp);
6093 /* Avoid initializing loopvar[0] again, it should be left where
6094 it finished by the first loop. */
6095 loop.from[0] = loop.loopvar[0];
6096 }
6097 gfc_trans_scalarizing_loops (&loop, &body);
6098
6099 if (fast)
6100 {
6101 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
6102 nan_cst, huge_cst);
6103 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
6104 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
6105 ifbody);
6106 gfc_add_expr_to_block (&loop.pre, tmp);
6107 }
6108 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
6109 {
6110 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
6111 huge_cst);
6112 gfc_add_modify (&loop.pre, limit, tmp);
6113 }
6114
6115 /* For a scalar mask, enclose the loop in an if statement. */
6116 if (maskexpr && maskss == NULL)
6117 {
6118 tree else_stmt;
6119 tree ifmask;
6120
6121 gfc_init_se (&maskse, NULL);
6122 gfc_conv_expr_val (&maskse, maskexpr);
6123 gfc_init_block (&block);
6124 gfc_add_block_to_block (&block, &loop.pre);
6125 gfc_add_block_to_block (&block, &loop.post);
6126 tmp = gfc_finish_block (&block);
6127
6128 if (HONOR_INFINITIES (DECL_MODE (limit)))
6129 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
6130 else
6131 else_stmt = build_empty_stmt (input_location);
6132
6133 ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
6134 tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
6135 gfc_add_expr_to_block (&block, tmp);
6136 gfc_add_block_to_block (&se->pre, &block);
6137 }
6138 else
6139 {
6140 gfc_add_block_to_block (&se->pre, &loop.pre);
6141 gfc_add_block_to_block (&se->pre, &loop.post);
6142 }
6143
6144 gfc_cleanup_loop (&loop);
6145
6146 se->expr = limit;
6147 }
6148
6149 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
6150 static void
gfc_conv_intrinsic_btest(gfc_se * se,gfc_expr * expr)6151 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
6152 {
6153 tree args[2];
6154 tree type;
6155 tree tmp;
6156
6157 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6158 type = TREE_TYPE (args[0]);
6159
6160 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6161 build_int_cst (type, 1), args[1]);
6162 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
6163 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
6164 build_int_cst (type, 0));
6165 type = gfc_typenode_for_spec (&expr->ts);
6166 se->expr = convert (type, tmp);
6167 }
6168
6169
6170 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
6171 static void
gfc_conv_intrinsic_bitcomp(gfc_se * se,gfc_expr * expr,enum tree_code op)6172 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6173 {
6174 tree args[2];
6175
6176 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6177
6178 /* Convert both arguments to the unsigned type of the same size. */
6179 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
6180 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
6181
6182 /* If they have unequal type size, convert to the larger one. */
6183 if (TYPE_PRECISION (TREE_TYPE (args[0]))
6184 > TYPE_PRECISION (TREE_TYPE (args[1])))
6185 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
6186 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
6187 > TYPE_PRECISION (TREE_TYPE (args[0])))
6188 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
6189
6190 /* Now, we compare them. */
6191 se->expr = fold_build2_loc (input_location, op, logical_type_node,
6192 args[0], args[1]);
6193 }
6194
6195
6196 /* Generate code to perform the specified operation. */
6197 static void
gfc_conv_intrinsic_bitop(gfc_se * se,gfc_expr * expr,enum tree_code op)6198 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
6199 {
6200 tree args[2];
6201
6202 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6203 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
6204 args[0], args[1]);
6205 }
6206
6207 /* Bitwise not. */
6208 static void
gfc_conv_intrinsic_not(gfc_se * se,gfc_expr * expr)6209 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
6210 {
6211 tree arg;
6212
6213 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6214 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
6215 TREE_TYPE (arg), arg);
6216 }
6217
6218 /* Set or clear a single bit. */
6219 static void
gfc_conv_intrinsic_singlebitop(gfc_se * se,gfc_expr * expr,int set)6220 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
6221 {
6222 tree args[2];
6223 tree type;
6224 tree tmp;
6225 enum tree_code op;
6226
6227 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6228 type = TREE_TYPE (args[0]);
6229
6230 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
6231 build_int_cst (type, 1), args[1]);
6232 if (set)
6233 op = BIT_IOR_EXPR;
6234 else
6235 {
6236 op = BIT_AND_EXPR;
6237 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
6238 }
6239 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
6240 }
6241
6242 /* Extract a sequence of bits.
6243 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
6244 static void
gfc_conv_intrinsic_ibits(gfc_se * se,gfc_expr * expr)6245 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
6246 {
6247 tree args[3];
6248 tree type;
6249 tree tmp;
6250 tree mask;
6251
6252 gfc_conv_intrinsic_function_args (se, expr, args, 3);
6253 type = TREE_TYPE (args[0]);
6254
6255 mask = build_int_cst (type, -1);
6256 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
6257 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
6258
6259 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
6260
6261 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
6262 }
6263
6264 static void
gfc_conv_intrinsic_shape(gfc_se * se,gfc_expr * expr)6265 gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
6266 {
6267 gfc_actual_arglist *s, *k;
6268 gfc_expr *e;
6269 gfc_array_spec *as;
6270 gfc_ss *ss;
6271
6272 /* Remove the KIND argument, if present. */
6273 s = expr->value.function.actual;
6274 k = s->next;
6275 e = k->expr;
6276 gfc_free_expr (e);
6277 k->expr = NULL;
6278
6279 gfc_conv_intrinsic_funcall (se, expr);
6280
6281 as = gfc_get_full_arrayspec_from_expr (s->expr);;
6282 ss = gfc_walk_expr (s->expr);
6283
6284 /* According to F2018 16.9.172, para 5, an assumed rank entity, argument
6285 associated with an assumed size array, has the ubound of the final
6286 dimension set to -1 and SHAPE must return this. */
6287 if (as && as->type == AS_ASSUMED_RANK
6288 && se->expr && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))
6289 && ss && ss->info->type == GFC_SS_SECTION)
6290 {
6291 tree desc, rank, minus_one, cond, ubound, tmp;
6292 stmtblock_t block;
6293 gfc_se ase;
6294
6295 minus_one = build_int_cst (gfc_array_index_type, -1);
6296
6297 /* Recover the descriptor for the array. */
6298 gfc_init_se (&ase, NULL);
6299 ase.descriptor_only = 1;
6300 gfc_conv_expr_lhs (&ase, ss->info->expr);
6301
6302 /* Obtain rank-1 so that we can address both descriptors. */
6303 rank = gfc_conv_descriptor_rank (ase.expr);
6304 rank = fold_convert (gfc_array_index_type, rank);
6305 rank = fold_build2_loc (input_location, PLUS_EXPR,
6306 gfc_array_index_type,
6307 rank, minus_one);
6308 rank = gfc_evaluate_now (rank, &se->pre);
6309
6310 /* The ubound for the final dimension will be tested for being -1. */
6311 ubound = gfc_conv_descriptor_ubound_get (ase.expr, rank);
6312 ubound = gfc_evaluate_now (ubound, &se->pre);
6313 cond = fold_build2_loc (input_location, EQ_EXPR,
6314 logical_type_node,
6315 ubound, minus_one);
6316
6317 /* Obtain the last element of the result from the library shape
6318 intrinsic and set it to -1 if that is the value of ubound. */
6319 desc = se->expr;
6320 tmp = gfc_conv_array_data (desc);
6321 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6322 tmp = gfc_build_array_ref (tmp, rank, NULL, NULL);
6323
6324 gfc_init_block (&block);
6325 gfc_add_modify (&block, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6326
6327 cond = build3_v (COND_EXPR, cond,
6328 gfc_finish_block (&block),
6329 build_empty_stmt (input_location));
6330 gfc_add_expr_to_block (&se->pre, cond);
6331 }
6332
6333 }
6334
6335 static void
gfc_conv_intrinsic_shift(gfc_se * se,gfc_expr * expr,bool right_shift,bool arithmetic)6336 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
6337 bool arithmetic)
6338 {
6339 tree args[2], type, num_bits, cond;
6340
6341 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6342
6343 args[0] = gfc_evaluate_now (args[0], &se->pre);
6344 args[1] = gfc_evaluate_now (args[1], &se->pre);
6345 type = TREE_TYPE (args[0]);
6346
6347 if (!arithmetic)
6348 args[0] = fold_convert (unsigned_type_for (type), args[0]);
6349 else
6350 gcc_assert (right_shift);
6351
6352 se->expr = fold_build2_loc (input_location,
6353 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
6354 TREE_TYPE (args[0]), args[0], args[1]);
6355
6356 if (!arithmetic)
6357 se->expr = fold_convert (type, se->expr);
6358
6359 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6360 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6361 special case. */
6362 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6363 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6364 args[1], num_bits);
6365
6366 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6367 build_int_cst (type, 0), se->expr);
6368 }
6369
6370 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
6371 ? 0
6372 : ((shift >= 0) ? i << shift : i >> -shift)
6373 where all shifts are logical shifts. */
6374 static void
gfc_conv_intrinsic_ishft(gfc_se * se,gfc_expr * expr)6375 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
6376 {
6377 tree args[2];
6378 tree type;
6379 tree utype;
6380 tree tmp;
6381 tree width;
6382 tree num_bits;
6383 tree cond;
6384 tree lshift;
6385 tree rshift;
6386
6387 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6388
6389 args[0] = gfc_evaluate_now (args[0], &se->pre);
6390 args[1] = gfc_evaluate_now (args[1], &se->pre);
6391
6392 type = TREE_TYPE (args[0]);
6393 utype = unsigned_type_for (type);
6394
6395 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
6396 args[1]);
6397
6398 /* Left shift if positive. */
6399 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
6400
6401 /* Right shift if negative.
6402 We convert to an unsigned type because we want a logical shift.
6403 The standard doesn't define the case of shifting negative
6404 numbers, and we try to be compatible with other compilers, most
6405 notably g77, here. */
6406 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
6407 utype, convert (utype, args[0]), width));
6408
6409 tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
6410 build_int_cst (TREE_TYPE (args[1]), 0));
6411 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
6412
6413 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
6414 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
6415 special case. */
6416 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
6417 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
6418 num_bits);
6419 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6420 build_int_cst (type, 0), tmp);
6421 }
6422
6423
6424 /* Circular shift. AKA rotate or barrel shift. */
6425
6426 static void
gfc_conv_intrinsic_ishftc(gfc_se * se,gfc_expr * expr)6427 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
6428 {
6429 tree *args;
6430 tree type;
6431 tree tmp;
6432 tree lrot;
6433 tree rrot;
6434 tree zero;
6435 unsigned int num_args;
6436
6437 num_args = gfc_intrinsic_argument_list_length (expr);
6438 args = XALLOCAVEC (tree, num_args);
6439
6440 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6441
6442 if (num_args == 3)
6443 {
6444 /* Use a library function for the 3 parameter version. */
6445 tree int4type = gfc_get_int_type (4);
6446
6447 type = TREE_TYPE (args[0]);
6448 /* We convert the first argument to at least 4 bytes, and
6449 convert back afterwards. This removes the need for library
6450 functions for all argument sizes, and function will be
6451 aligned to at least 32 bits, so there's no loss. */
6452 if (expr->ts.kind < 4)
6453 args[0] = convert (int4type, args[0]);
6454
6455 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
6456 need loads of library functions. They cannot have values >
6457 BIT_SIZE (I) so the conversion is safe. */
6458 args[1] = convert (int4type, args[1]);
6459 args[2] = convert (int4type, args[2]);
6460
6461 switch (expr->ts.kind)
6462 {
6463 case 1:
6464 case 2:
6465 case 4:
6466 tmp = gfor_fndecl_math_ishftc4;
6467 break;
6468 case 8:
6469 tmp = gfor_fndecl_math_ishftc8;
6470 break;
6471 case 16:
6472 tmp = gfor_fndecl_math_ishftc16;
6473 break;
6474 default:
6475 gcc_unreachable ();
6476 }
6477 se->expr = build_call_expr_loc (input_location,
6478 tmp, 3, args[0], args[1], args[2]);
6479 /* Convert the result back to the original type, if we extended
6480 the first argument's width above. */
6481 if (expr->ts.kind < 4)
6482 se->expr = convert (type, se->expr);
6483
6484 return;
6485 }
6486 type = TREE_TYPE (args[0]);
6487
6488 /* Evaluate arguments only once. */
6489 args[0] = gfc_evaluate_now (args[0], &se->pre);
6490 args[1] = gfc_evaluate_now (args[1], &se->pre);
6491
6492 /* Rotate left if positive. */
6493 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
6494
6495 /* Rotate right if negative. */
6496 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
6497 args[1]);
6498 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
6499
6500 zero = build_int_cst (TREE_TYPE (args[1]), 0);
6501 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
6502 zero);
6503 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
6504
6505 /* Do nothing if shift == 0. */
6506 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
6507 zero);
6508 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
6509 rrot);
6510 }
6511
6512
6513 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
6514 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
6515
6516 The conditional expression is necessary because the result of LEADZ(0)
6517 is defined, but the result of __builtin_clz(0) is undefined for most
6518 targets.
6519
6520 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
6521 difference in bit size between the argument of LEADZ and the C int. */
6522
6523 static void
gfc_conv_intrinsic_leadz(gfc_se * se,gfc_expr * expr)6524 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
6525 {
6526 tree arg;
6527 tree arg_type;
6528 tree cond;
6529 tree result_type;
6530 tree leadz;
6531 tree bit_size;
6532 tree tmp;
6533 tree func;
6534 int s, argsize;
6535
6536 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6537 argsize = TYPE_PRECISION (TREE_TYPE (arg));
6538
6539 /* Which variant of __builtin_clz* should we call? */
6540 if (argsize <= INT_TYPE_SIZE)
6541 {
6542 arg_type = unsigned_type_node;
6543 func = builtin_decl_explicit (BUILT_IN_CLZ);
6544 }
6545 else if (argsize <= LONG_TYPE_SIZE)
6546 {
6547 arg_type = long_unsigned_type_node;
6548 func = builtin_decl_explicit (BUILT_IN_CLZL);
6549 }
6550 else if (argsize <= LONG_LONG_TYPE_SIZE)
6551 {
6552 arg_type = long_long_unsigned_type_node;
6553 func = builtin_decl_explicit (BUILT_IN_CLZLL);
6554 }
6555 else
6556 {
6557 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
6558 arg_type = gfc_build_uint_type (argsize);
6559 func = NULL_TREE;
6560 }
6561
6562 /* Convert the actual argument twice: first, to the unsigned type of the
6563 same size; then, to the proper argument type for the built-in
6564 function. But the return type is of the default INTEGER kind. */
6565 arg = fold_convert (gfc_build_uint_type (argsize), arg);
6566 arg = fold_convert (arg_type, arg);
6567 arg = gfc_evaluate_now (arg, &se->pre);
6568 result_type = gfc_get_int_type (gfc_default_integer_kind);
6569
6570 /* Compute LEADZ for the case i .ne. 0. */
6571 if (func)
6572 {
6573 s = TYPE_PRECISION (arg_type) - argsize;
6574 tmp = fold_convert (result_type,
6575 build_call_expr_loc (input_location, func,
6576 1, arg));
6577 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
6578 tmp, build_int_cst (result_type, s));
6579 }
6580 else
6581 {
6582 /* We end up here if the argument type is larger than 'long long'.
6583 We generate this code:
6584
6585 if (x & (ULL_MAX << ULL_SIZE) != 0)
6586 return clzll ((unsigned long long) (x >> ULLSIZE));
6587 else
6588 return ULL_SIZE + clzll ((unsigned long long) x);
6589 where ULL_MAX is the largest value that a ULL_MAX can hold
6590 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6591 is the bit-size of the long long type (64 in this example). */
6592 tree ullsize, ullmax, tmp1, tmp2, btmp;
6593
6594 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
6595 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
6596 long_long_unsigned_type_node,
6597 build_int_cst (long_long_unsigned_type_node,
6598 0));
6599
6600 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
6601 fold_convert (arg_type, ullmax), ullsize);
6602 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
6603 arg, cond);
6604 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6605 cond, build_int_cst (arg_type, 0));
6606
6607 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
6608 arg, ullsize);
6609 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
6610 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
6611 tmp1 = fold_convert (result_type,
6612 build_call_expr_loc (input_location, btmp, 1, tmp1));
6613
6614 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
6615 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
6616 tmp2 = fold_convert (result_type,
6617 build_call_expr_loc (input_location, btmp, 1, tmp2));
6618 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
6619 tmp2, ullsize);
6620
6621 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
6622 cond, tmp1, tmp2);
6623 }
6624
6625 /* Build BIT_SIZE. */
6626 bit_size = build_int_cst (result_type, argsize);
6627
6628 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6629 arg, build_int_cst (arg_type, 0));
6630 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
6631 bit_size, leadz);
6632 }
6633
6634
6635 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
6636
6637 The conditional expression is necessary because the result of TRAILZ(0)
6638 is defined, but the result of __builtin_ctz(0) is undefined for most
6639 targets. */
6640
6641 static void
gfc_conv_intrinsic_trailz(gfc_se * se,gfc_expr * expr)6642 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
6643 {
6644 tree arg;
6645 tree arg_type;
6646 tree cond;
6647 tree result_type;
6648 tree trailz;
6649 tree bit_size;
6650 tree func;
6651 int argsize;
6652
6653 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6654 argsize = TYPE_PRECISION (TREE_TYPE (arg));
6655
6656 /* Which variant of __builtin_ctz* should we call? */
6657 if (argsize <= INT_TYPE_SIZE)
6658 {
6659 arg_type = unsigned_type_node;
6660 func = builtin_decl_explicit (BUILT_IN_CTZ);
6661 }
6662 else if (argsize <= LONG_TYPE_SIZE)
6663 {
6664 arg_type = long_unsigned_type_node;
6665 func = builtin_decl_explicit (BUILT_IN_CTZL);
6666 }
6667 else if (argsize <= LONG_LONG_TYPE_SIZE)
6668 {
6669 arg_type = long_long_unsigned_type_node;
6670 func = builtin_decl_explicit (BUILT_IN_CTZLL);
6671 }
6672 else
6673 {
6674 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
6675 arg_type = gfc_build_uint_type (argsize);
6676 func = NULL_TREE;
6677 }
6678
6679 /* Convert the actual argument twice: first, to the unsigned type of the
6680 same size; then, to the proper argument type for the built-in
6681 function. But the return type is of the default INTEGER kind. */
6682 arg = fold_convert (gfc_build_uint_type (argsize), arg);
6683 arg = fold_convert (arg_type, arg);
6684 arg = gfc_evaluate_now (arg, &se->pre);
6685 result_type = gfc_get_int_type (gfc_default_integer_kind);
6686
6687 /* Compute TRAILZ for the case i .ne. 0. */
6688 if (func)
6689 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
6690 func, 1, arg));
6691 else
6692 {
6693 /* We end up here if the argument type is larger than 'long long'.
6694 We generate this code:
6695
6696 if ((x & ULL_MAX) == 0)
6697 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
6698 else
6699 return ctzll ((unsigned long long) x);
6700
6701 where ULL_MAX is the largest value that a ULL_MAX can hold
6702 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
6703 is the bit-size of the long long type (64 in this example). */
6704 tree ullsize, ullmax, tmp1, tmp2, btmp;
6705
6706 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
6707 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
6708 long_long_unsigned_type_node,
6709 build_int_cst (long_long_unsigned_type_node, 0));
6710
6711 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
6712 fold_convert (arg_type, ullmax));
6713 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
6714 build_int_cst (arg_type, 0));
6715
6716 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
6717 arg, ullsize);
6718 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
6719 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
6720 tmp1 = fold_convert (result_type,
6721 build_call_expr_loc (input_location, btmp, 1, tmp1));
6722 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
6723 tmp1, ullsize);
6724
6725 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
6726 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
6727 tmp2 = fold_convert (result_type,
6728 build_call_expr_loc (input_location, btmp, 1, tmp2));
6729
6730 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
6731 cond, tmp1, tmp2);
6732 }
6733
6734 /* Build BIT_SIZE. */
6735 bit_size = build_int_cst (result_type, argsize);
6736
6737 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6738 arg, build_int_cst (arg_type, 0));
6739 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
6740 bit_size, trailz);
6741 }
6742
6743 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
6744 for types larger than "long long", we call the long long built-in for
6745 the lower and higher bits and combine the result. */
6746
6747 static void
gfc_conv_intrinsic_popcnt_poppar(gfc_se * se,gfc_expr * expr,int parity)6748 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
6749 {
6750 tree arg;
6751 tree arg_type;
6752 tree result_type;
6753 tree func;
6754 int argsize;
6755
6756 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6757 argsize = TYPE_PRECISION (TREE_TYPE (arg));
6758 result_type = gfc_get_int_type (gfc_default_integer_kind);
6759
6760 /* Which variant of the builtin should we call? */
6761 if (argsize <= INT_TYPE_SIZE)
6762 {
6763 arg_type = unsigned_type_node;
6764 func = builtin_decl_explicit (parity
6765 ? BUILT_IN_PARITY
6766 : BUILT_IN_POPCOUNT);
6767 }
6768 else if (argsize <= LONG_TYPE_SIZE)
6769 {
6770 arg_type = long_unsigned_type_node;
6771 func = builtin_decl_explicit (parity
6772 ? BUILT_IN_PARITYL
6773 : BUILT_IN_POPCOUNTL);
6774 }
6775 else if (argsize <= LONG_LONG_TYPE_SIZE)
6776 {
6777 arg_type = long_long_unsigned_type_node;
6778 func = builtin_decl_explicit (parity
6779 ? BUILT_IN_PARITYLL
6780 : BUILT_IN_POPCOUNTLL);
6781 }
6782 else
6783 {
6784 /* Our argument type is larger than 'long long', which mean none
6785 of the POPCOUNT builtins covers it. We thus call the 'long long'
6786 variant multiple times, and add the results. */
6787 tree utype, arg2, call1, call2;
6788
6789 /* For now, we only cover the case where argsize is twice as large
6790 as 'long long'. */
6791 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
6792
6793 func = builtin_decl_explicit (parity
6794 ? BUILT_IN_PARITYLL
6795 : BUILT_IN_POPCOUNTLL);
6796
6797 /* Convert it to an integer, and store into a variable. */
6798 utype = gfc_build_uint_type (argsize);
6799 arg = fold_convert (utype, arg);
6800 arg = gfc_evaluate_now (arg, &se->pre);
6801
6802 /* Call the builtin twice. */
6803 call1 = build_call_expr_loc (input_location, func, 1,
6804 fold_convert (long_long_unsigned_type_node,
6805 arg));
6806
6807 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
6808 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
6809 call2 = build_call_expr_loc (input_location, func, 1,
6810 fold_convert (long_long_unsigned_type_node,
6811 arg2));
6812
6813 /* Combine the results. */
6814 if (parity)
6815 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
6816 call1, call2);
6817 else
6818 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
6819 call1, call2);
6820
6821 return;
6822 }
6823
6824 /* Convert the actual argument twice: first, to the unsigned type of the
6825 same size; then, to the proper argument type for the built-in
6826 function. */
6827 arg = fold_convert (gfc_build_uint_type (argsize), arg);
6828 arg = fold_convert (arg_type, arg);
6829
6830 se->expr = fold_convert (result_type,
6831 build_call_expr_loc (input_location, func, 1, arg));
6832 }
6833
6834
6835 /* Process an intrinsic with unspecified argument-types that has an optional
6836 argument (which could be of type character), e.g. EOSHIFT. For those, we
6837 need to append the string length of the optional argument if it is not
6838 present and the type is really character.
6839 primary specifies the position (starting at 1) of the non-optional argument
6840 specifying the type and optional gives the position of the optional
6841 argument in the arglist. */
6842
6843 static void
conv_generic_with_optional_char_arg(gfc_se * se,gfc_expr * expr,unsigned primary,unsigned optional)6844 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
6845 unsigned primary, unsigned optional)
6846 {
6847 gfc_actual_arglist* prim_arg;
6848 gfc_actual_arglist* opt_arg;
6849 unsigned cur_pos;
6850 gfc_actual_arglist* arg;
6851 gfc_symbol* sym;
6852 vec<tree, va_gc> *append_args;
6853
6854 /* Find the two arguments given as position. */
6855 cur_pos = 0;
6856 prim_arg = NULL;
6857 opt_arg = NULL;
6858 for (arg = expr->value.function.actual; arg; arg = arg->next)
6859 {
6860 ++cur_pos;
6861
6862 if (cur_pos == primary)
6863 prim_arg = arg;
6864 if (cur_pos == optional)
6865 opt_arg = arg;
6866
6867 if (cur_pos >= primary && cur_pos >= optional)
6868 break;
6869 }
6870 gcc_assert (prim_arg);
6871 gcc_assert (prim_arg->expr);
6872 gcc_assert (opt_arg);
6873
6874 /* If we do have type CHARACTER and the optional argument is really absent,
6875 append a dummy 0 as string length. */
6876 append_args = NULL;
6877 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
6878 {
6879 tree dummy;
6880
6881 dummy = build_int_cst (gfc_charlen_type_node, 0);
6882 vec_alloc (append_args, 1);
6883 append_args->quick_push (dummy);
6884 }
6885
6886 /* Build the call itself. */
6887 gcc_assert (!se->ignore_optional);
6888 sym = gfc_get_symbol_for_expr (expr, false);
6889 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
6890 append_args);
6891 gfc_free_symbol (sym);
6892 }
6893
6894 /* The length of a character string. */
6895 static void
gfc_conv_intrinsic_len(gfc_se * se,gfc_expr * expr)6896 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
6897 {
6898 tree len;
6899 tree type;
6900 tree decl;
6901 gfc_symbol *sym;
6902 gfc_se argse;
6903 gfc_expr *arg;
6904
6905 gcc_assert (!se->ss);
6906
6907 arg = expr->value.function.actual->expr;
6908
6909 type = gfc_typenode_for_spec (&expr->ts);
6910 switch (arg->expr_type)
6911 {
6912 case EXPR_CONSTANT:
6913 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
6914 break;
6915
6916 case EXPR_ARRAY:
6917 /* Obtain the string length from the function used by
6918 trans-array.c(gfc_trans_array_constructor). */
6919 len = NULL_TREE;
6920 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
6921 break;
6922
6923 case EXPR_VARIABLE:
6924 if (arg->ref == NULL
6925 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
6926 {
6927 /* This doesn't catch all cases.
6928 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6929 and the surrounding thread. */
6930 sym = arg->symtree->n.sym;
6931 decl = gfc_get_symbol_decl (sym);
6932 if (decl == current_function_decl && sym->attr.function
6933 && (sym->result == sym))
6934 decl = gfc_get_fake_result_decl (sym, 0);
6935
6936 len = sym->ts.u.cl->backend_decl;
6937 gcc_assert (len);
6938 break;
6939 }
6940
6941 /* Fall through. */
6942
6943 default:
6944 gfc_init_se (&argse, se);
6945 if (arg->rank == 0)
6946 gfc_conv_expr (&argse, arg);
6947 else
6948 gfc_conv_expr_descriptor (&argse, arg);
6949 gfc_add_block_to_block (&se->pre, &argse.pre);
6950 gfc_add_block_to_block (&se->post, &argse.post);
6951 len = argse.string_length;
6952 break;
6953 }
6954 se->expr = convert (type, len);
6955 }
6956
6957 /* The length of a character string not including trailing blanks. */
6958 static void
gfc_conv_intrinsic_len_trim(gfc_se * se,gfc_expr * expr)6959 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
6960 {
6961 int kind = expr->value.function.actual->expr->ts.kind;
6962 tree args[2], type, fndecl;
6963
6964 gfc_conv_intrinsic_function_args (se, expr, args, 2);
6965 type = gfc_typenode_for_spec (&expr->ts);
6966
6967 if (kind == 1)
6968 fndecl = gfor_fndecl_string_len_trim;
6969 else if (kind == 4)
6970 fndecl = gfor_fndecl_string_len_trim_char4;
6971 else
6972 gcc_unreachable ();
6973
6974 se->expr = build_call_expr_loc (input_location,
6975 fndecl, 2, args[0], args[1]);
6976 se->expr = convert (type, se->expr);
6977 }
6978
6979
6980 /* Returns the starting position of a substring within a string. */
6981
6982 static void
gfc_conv_intrinsic_index_scan_verify(gfc_se * se,gfc_expr * expr,tree function)6983 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
6984 tree function)
6985 {
6986 tree logical4_type_node = gfc_get_logical_type (4);
6987 tree type;
6988 tree fndecl;
6989 tree *args;
6990 unsigned int num_args;
6991
6992 args = XALLOCAVEC (tree, 5);
6993
6994 /* Get number of arguments; characters count double due to the
6995 string length argument. Kind= is not passed to the library
6996 and thus ignored. */
6997 if (expr->value.function.actual->next->next->expr == NULL)
6998 num_args = 4;
6999 else
7000 num_args = 5;
7001
7002 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7003 type = gfc_typenode_for_spec (&expr->ts);
7004
7005 if (num_args == 4)
7006 args[4] = build_int_cst (logical4_type_node, 0);
7007 else
7008 args[4] = convert (logical4_type_node, args[4]);
7009
7010 fndecl = build_addr (function);
7011 se->expr = build_call_array_loc (input_location,
7012 TREE_TYPE (TREE_TYPE (function)), fndecl,
7013 5, args);
7014 se->expr = convert (type, se->expr);
7015
7016 }
7017
7018 /* The ascii value for a single character. */
7019 static void
gfc_conv_intrinsic_ichar(gfc_se * se,gfc_expr * expr)7020 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
7021 {
7022 tree args[3], type, pchartype;
7023 int nargs;
7024
7025 nargs = gfc_intrinsic_argument_list_length (expr);
7026 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
7027 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
7028 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
7029 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
7030 type = gfc_typenode_for_spec (&expr->ts);
7031
7032 se->expr = build_fold_indirect_ref_loc (input_location,
7033 args[1]);
7034 se->expr = convert (type, se->expr);
7035 }
7036
7037
7038 /* Intrinsic ISNAN calls __builtin_isnan. */
7039
7040 static void
gfc_conv_intrinsic_isnan(gfc_se * se,gfc_expr * expr)7041 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
7042 {
7043 tree arg;
7044
7045 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7046 se->expr = build_call_expr_loc (input_location,
7047 builtin_decl_explicit (BUILT_IN_ISNAN),
7048 1, arg);
7049 STRIP_TYPE_NOPS (se->expr);
7050 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7051 }
7052
7053
7054 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
7055 their argument against a constant integer value. */
7056
7057 static void
gfc_conv_has_intvalue(gfc_se * se,gfc_expr * expr,const int value)7058 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
7059 {
7060 tree arg;
7061
7062 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7063 se->expr = fold_build2_loc (input_location, EQ_EXPR,
7064 gfc_typenode_for_spec (&expr->ts),
7065 arg, build_int_cst (TREE_TYPE (arg), value));
7066 }
7067
7068
7069
7070 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
7071
7072 static void
gfc_conv_intrinsic_merge(gfc_se * se,gfc_expr * expr)7073 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
7074 {
7075 tree tsource;
7076 tree fsource;
7077 tree mask;
7078 tree type;
7079 tree len, len2;
7080 tree *args;
7081 unsigned int num_args;
7082
7083 num_args = gfc_intrinsic_argument_list_length (expr);
7084 args = XALLOCAVEC (tree, num_args);
7085
7086 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
7087 if (expr->ts.type != BT_CHARACTER)
7088 {
7089 tsource = args[0];
7090 fsource = args[1];
7091 mask = args[2];
7092 }
7093 else
7094 {
7095 /* We do the same as in the non-character case, but the argument
7096 list is different because of the string length arguments. We
7097 also have to set the string length for the result. */
7098 len = args[0];
7099 tsource = args[1];
7100 len2 = args[2];
7101 fsource = args[3];
7102 mask = args[4];
7103
7104 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
7105 &se->pre);
7106 se->string_length = len;
7107 }
7108 type = TREE_TYPE (tsource);
7109 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
7110 fold_convert (type, fsource));
7111 }
7112
7113
7114 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
7115
7116 static void
gfc_conv_intrinsic_merge_bits(gfc_se * se,gfc_expr * expr)7117 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
7118 {
7119 tree args[3], mask, type;
7120
7121 gfc_conv_intrinsic_function_args (se, expr, args, 3);
7122 mask = gfc_evaluate_now (args[2], &se->pre);
7123
7124 type = TREE_TYPE (args[0]);
7125 gcc_assert (TREE_TYPE (args[1]) == type);
7126 gcc_assert (TREE_TYPE (mask) == type);
7127
7128 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
7129 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
7130 fold_build1_loc (input_location, BIT_NOT_EXPR,
7131 type, mask));
7132 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
7133 args[0], args[1]);
7134 }
7135
7136
7137 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
7138 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
7139
7140 static void
gfc_conv_intrinsic_mask(gfc_se * se,gfc_expr * expr,int left)7141 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
7142 {
7143 tree arg, allones, type, utype, res, cond, bitsize;
7144 int i;
7145
7146 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7147 arg = gfc_evaluate_now (arg, &se->pre);
7148
7149 type = gfc_get_int_type (expr->ts.kind);
7150 utype = unsigned_type_for (type);
7151
7152 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
7153 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
7154
7155 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
7156 build_int_cst (utype, 0));
7157
7158 if (left)
7159 {
7160 /* Left-justified mask. */
7161 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
7162 bitsize, arg);
7163 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7164 fold_convert (utype, res));
7165
7166 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
7167 smaller than type width. */
7168 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7169 build_int_cst (TREE_TYPE (arg), 0));
7170 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
7171 build_int_cst (utype, 0), res);
7172 }
7173 else
7174 {
7175 /* Right-justified mask. */
7176 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
7177 fold_convert (utype, arg));
7178 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
7179
7180 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
7181 strictly smaller than type width. */
7182 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7183 arg, bitsize);
7184 res = fold_build3_loc (input_location, COND_EXPR, utype,
7185 cond, allones, res);
7186 }
7187
7188 se->expr = fold_convert (type, res);
7189 }
7190
7191
7192 /* FRACTION (s) is translated into:
7193 isfinite (s) ? frexp (s, &dummy_int) : NaN */
7194 static void
gfc_conv_intrinsic_fraction(gfc_se * se,gfc_expr * expr)7195 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
7196 {
7197 tree arg, type, tmp, res, frexp, cond;
7198
7199 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7200
7201 type = gfc_typenode_for_spec (&expr->ts);
7202 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7203 arg = gfc_evaluate_now (arg, &se->pre);
7204
7205 cond = build_call_expr_loc (input_location,
7206 builtin_decl_explicit (BUILT_IN_ISFINITE),
7207 1, arg);
7208
7209 tmp = gfc_create_var (integer_type_node, NULL);
7210 res = build_call_expr_loc (input_location, frexp, 2,
7211 fold_convert (type, arg),
7212 gfc_build_addr_expr (NULL_TREE, tmp));
7213 res = fold_convert (type, res);
7214
7215 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
7216 cond, res, gfc_build_nan (type, ""));
7217 }
7218
7219
7220 /* NEAREST (s, dir) is translated into
7221 tmp = copysign (HUGE_VAL, dir);
7222 return nextafter (s, tmp);
7223 */
7224 static void
gfc_conv_intrinsic_nearest(gfc_se * se,gfc_expr * expr)7225 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
7226 {
7227 tree args[2], type, tmp, nextafter, copysign, huge_val;
7228
7229 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
7230 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
7231
7232 type = gfc_typenode_for_spec (&expr->ts);
7233 gfc_conv_intrinsic_function_args (se, expr, args, 2);
7234
7235 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
7236 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
7237 fold_convert (type, args[1]));
7238 se->expr = build_call_expr_loc (input_location, nextafter, 2,
7239 fold_convert (type, args[0]), tmp);
7240 se->expr = fold_convert (type, se->expr);
7241 }
7242
7243
7244 /* SPACING (s) is translated into
7245 int e;
7246 if (!isfinite (s))
7247 res = NaN;
7248 else if (s == 0)
7249 res = tiny;
7250 else
7251 {
7252 frexp (s, &e);
7253 e = e - prec;
7254 e = MAX_EXPR (e, emin);
7255 res = scalbn (1., e);
7256 }
7257 return res;
7258
7259 where prec is the precision of s, gfc_real_kinds[k].digits,
7260 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
7261 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
7262
7263 static void
gfc_conv_intrinsic_spacing(gfc_se * se,gfc_expr * expr)7264 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
7265 {
7266 tree arg, type, prec, emin, tiny, res, e;
7267 tree cond, nan, tmp, frexp, scalbn;
7268 int k;
7269 stmtblock_t block;
7270
7271 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
7272 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
7273 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
7274 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
7275
7276 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7277 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7278
7279 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7280 arg = gfc_evaluate_now (arg, &se->pre);
7281
7282 type = gfc_typenode_for_spec (&expr->ts);
7283 e = gfc_create_var (integer_type_node, NULL);
7284 res = gfc_create_var (type, NULL);
7285
7286
7287 /* Build the block for s /= 0. */
7288 gfc_start_block (&block);
7289 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
7290 gfc_build_addr_expr (NULL_TREE, e));
7291 gfc_add_expr_to_block (&block, tmp);
7292
7293 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
7294 prec);
7295 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
7296 integer_type_node, tmp, emin));
7297
7298 tmp = build_call_expr_loc (input_location, scalbn, 2,
7299 build_real_from_int_cst (type, integer_one_node), e);
7300 gfc_add_modify (&block, res, tmp);
7301
7302 /* Finish by building the IF statement for value zero. */
7303 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
7304 build_real_from_int_cst (type, integer_zero_node));
7305 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
7306 gfc_finish_block (&block));
7307
7308 /* And deal with infinities and NaNs. */
7309 cond = build_call_expr_loc (input_location,
7310 builtin_decl_explicit (BUILT_IN_ISFINITE),
7311 1, arg);
7312 nan = gfc_build_nan (type, "");
7313 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
7314
7315 gfc_add_expr_to_block (&se->pre, tmp);
7316 se->expr = res;
7317 }
7318
7319
7320 /* RRSPACING (s) is translated into
7321 int e;
7322 real x;
7323 x = fabs (s);
7324 if (isfinite (x))
7325 {
7326 if (x != 0)
7327 {
7328 frexp (s, &e);
7329 x = scalbn (x, precision - e);
7330 }
7331 }
7332 else
7333 x = NaN;
7334 return x;
7335
7336 where precision is gfc_real_kinds[k].digits. */
7337
7338 static void
gfc_conv_intrinsic_rrspacing(gfc_se * se,gfc_expr * expr)7339 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
7340 {
7341 tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
7342 int prec, k;
7343 stmtblock_t block;
7344
7345 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
7346 prec = gfc_real_kinds[k].digits;
7347
7348 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7349 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7350 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
7351
7352 type = gfc_typenode_for_spec (&expr->ts);
7353 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7354 arg = gfc_evaluate_now (arg, &se->pre);
7355
7356 e = gfc_create_var (integer_type_node, NULL);
7357 x = gfc_create_var (type, NULL);
7358 gfc_add_modify (&se->pre, x,
7359 build_call_expr_loc (input_location, fabs, 1, arg));
7360
7361
7362 gfc_start_block (&block);
7363 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
7364 gfc_build_addr_expr (NULL_TREE, e));
7365 gfc_add_expr_to_block (&block, tmp);
7366
7367 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
7368 build_int_cst (integer_type_node, prec), e);
7369 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
7370 gfc_add_modify (&block, x, tmp);
7371 stmt = gfc_finish_block (&block);
7372
7373 /* if (x != 0) */
7374 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x,
7375 build_real_from_int_cst (type, integer_zero_node));
7376 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
7377
7378 /* And deal with infinities and NaNs. */
7379 cond = build_call_expr_loc (input_location,
7380 builtin_decl_explicit (BUILT_IN_ISFINITE),
7381 1, x);
7382 nan = gfc_build_nan (type, "");
7383 tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
7384
7385 gfc_add_expr_to_block (&se->pre, tmp);
7386 se->expr = fold_convert (type, x);
7387 }
7388
7389
7390 /* SCALE (s, i) is translated into scalbn (s, i). */
7391 static void
gfc_conv_intrinsic_scale(gfc_se * se,gfc_expr * expr)7392 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
7393 {
7394 tree args[2], type, scalbn;
7395
7396 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7397
7398 type = gfc_typenode_for_spec (&expr->ts);
7399 gfc_conv_intrinsic_function_args (se, expr, args, 2);
7400 se->expr = build_call_expr_loc (input_location, scalbn, 2,
7401 fold_convert (type, args[0]),
7402 fold_convert (integer_type_node, args[1]));
7403 se->expr = fold_convert (type, se->expr);
7404 }
7405
7406
7407 /* SET_EXPONENT (s, i) is translated into
7408 isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */
7409 static void
gfc_conv_intrinsic_set_exponent(gfc_se * se,gfc_expr * expr)7410 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
7411 {
7412 tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
7413
7414 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
7415 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
7416
7417 type = gfc_typenode_for_spec (&expr->ts);
7418 gfc_conv_intrinsic_function_args (se, expr, args, 2);
7419 args[0] = gfc_evaluate_now (args[0], &se->pre);
7420
7421 tmp = gfc_create_var (integer_type_node, NULL);
7422 tmp = build_call_expr_loc (input_location, frexp, 2,
7423 fold_convert (type, args[0]),
7424 gfc_build_addr_expr (NULL_TREE, tmp));
7425 res = build_call_expr_loc (input_location, scalbn, 2, tmp,
7426 fold_convert (integer_type_node, args[1]));
7427 res = fold_convert (type, res);
7428
7429 /* Call to isfinite */
7430 cond = build_call_expr_loc (input_location,
7431 builtin_decl_explicit (BUILT_IN_ISFINITE),
7432 1, args[0]);
7433 nan = gfc_build_nan (type, "");
7434
7435 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
7436 res, nan);
7437 }
7438
7439
7440 static void
gfc_conv_intrinsic_size(gfc_se * se,gfc_expr * expr)7441 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
7442 {
7443 gfc_actual_arglist *actual;
7444 tree arg1;
7445 tree type;
7446 tree fncall0;
7447 tree fncall1;
7448 gfc_se argse;
7449 gfc_expr *e;
7450 gfc_symbol *sym = NULL;
7451
7452 gfc_init_se (&argse, NULL);
7453 actual = expr->value.function.actual;
7454
7455 if (actual->expr->ts.type == BT_CLASS)
7456 gfc_add_class_array_ref (actual->expr);
7457
7458 e = actual->expr;
7459
7460 /* These are emerging from the interface mapping, when a class valued
7461 function appears as the rhs in a realloc on assign statement, where
7462 the size of the result is that of one of the actual arguments. */
7463 if (e->expr_type == EXPR_VARIABLE
7464 && e->symtree->n.sym->ns == NULL /* This is distinctive! */
7465 && e->symtree->n.sym->ts.type == BT_CLASS
7466 && e->ref && e->ref->type == REF_COMPONENT
7467 && strcmp (e->ref->u.c.component->name, "_data") == 0)
7468 sym = e->symtree->n.sym;
7469
7470 argse.data_not_needed = 1;
7471 if (gfc_is_class_array_function (e))
7472 {
7473 /* For functions that return a class array conv_expr_descriptor is not
7474 able to get the descriptor right. Therefore this special case. */
7475 gfc_conv_expr_reference (&argse, e);
7476 argse.expr = gfc_build_addr_expr (NULL_TREE,
7477 gfc_class_data_get (argse.expr));
7478 }
7479 else if (sym && sym->backend_decl)
7480 {
7481 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
7482 argse.expr = sym->backend_decl;
7483 argse.expr = gfc_build_addr_expr (NULL_TREE,
7484 gfc_class_data_get (argse.expr));
7485 }
7486 else
7487 {
7488 argse.want_pointer = 1;
7489 gfc_conv_expr_descriptor (&argse, actual->expr);
7490 }
7491 gfc_add_block_to_block (&se->pre, &argse.pre);
7492 gfc_add_block_to_block (&se->post, &argse.post);
7493 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
7494
7495 /* Build the call to size0. */
7496 fncall0 = build_call_expr_loc (input_location,
7497 gfor_fndecl_size0, 1, arg1);
7498
7499 actual = actual->next;
7500
7501 if (actual->expr)
7502 {
7503 gfc_init_se (&argse, NULL);
7504 gfc_conv_expr_type (&argse, actual->expr,
7505 gfc_array_index_type);
7506 gfc_add_block_to_block (&se->pre, &argse.pre);
7507
7508 /* Unusually, for an intrinsic, size does not exclude
7509 an optional arg2, so we must test for it. */
7510 if (actual->expr->expr_type == EXPR_VARIABLE
7511 && actual->expr->symtree->n.sym->attr.dummy
7512 && actual->expr->symtree->n.sym->attr.optional)
7513 {
7514 tree tmp;
7515 /* Build the call to size1. */
7516 fncall1 = build_call_expr_loc (input_location,
7517 gfor_fndecl_size1, 2,
7518 arg1, argse.expr);
7519
7520 gfc_init_se (&argse, NULL);
7521 argse.want_pointer = 1;
7522 argse.data_not_needed = 1;
7523 gfc_conv_expr (&argse, actual->expr);
7524 gfc_add_block_to_block (&se->pre, &argse.pre);
7525 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7526 argse.expr, null_pointer_node);
7527 tmp = gfc_evaluate_now (tmp, &se->pre);
7528 se->expr = fold_build3_loc (input_location, COND_EXPR,
7529 pvoid_type_node, tmp, fncall1, fncall0);
7530 }
7531 else
7532 {
7533 se->expr = NULL_TREE;
7534 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
7535 gfc_array_index_type,
7536 argse.expr, gfc_index_one_node);
7537 }
7538 }
7539 else if (expr->value.function.actual->expr->rank == 1)
7540 {
7541 argse.expr = gfc_index_zero_node;
7542 se->expr = NULL_TREE;
7543 }
7544 else
7545 se->expr = fncall0;
7546
7547 if (se->expr == NULL_TREE)
7548 {
7549 tree ubound, lbound;
7550
7551 arg1 = build_fold_indirect_ref_loc (input_location,
7552 arg1);
7553 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
7554 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
7555 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
7556 gfc_array_index_type, ubound, lbound);
7557 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
7558 gfc_array_index_type,
7559 se->expr, gfc_index_one_node);
7560 se->expr = fold_build2_loc (input_location, MAX_EXPR,
7561 gfc_array_index_type, se->expr,
7562 gfc_index_zero_node);
7563 }
7564
7565 type = gfc_typenode_for_spec (&expr->ts);
7566 se->expr = convert (type, se->expr);
7567 }
7568
7569
7570 /* Helper function to compute the size of a character variable,
7571 excluding the terminating null characters. The result has
7572 gfc_array_index_type type. */
7573
7574 tree
size_of_string_in_bytes(int kind,tree string_length)7575 size_of_string_in_bytes (int kind, tree string_length)
7576 {
7577 tree bytesize;
7578 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
7579
7580 bytesize = build_int_cst (gfc_array_index_type,
7581 gfc_character_kinds[i].bit_size / 8);
7582
7583 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7584 bytesize,
7585 fold_convert (gfc_array_index_type, string_length));
7586 }
7587
7588
7589 static void
gfc_conv_intrinsic_sizeof(gfc_se * se,gfc_expr * expr)7590 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
7591 {
7592 gfc_expr *arg;
7593 gfc_se argse;
7594 tree source_bytes;
7595 tree tmp;
7596 tree lower;
7597 tree upper;
7598 tree byte_size;
7599 tree field;
7600 int n;
7601
7602 gfc_init_se (&argse, NULL);
7603 arg = expr->value.function.actual->expr;
7604
7605 if (arg->rank || arg->ts.type == BT_ASSUMED)
7606 gfc_conv_expr_descriptor (&argse, arg);
7607 else
7608 gfc_conv_expr_reference (&argse, arg);
7609
7610 if (arg->ts.type == BT_ASSUMED)
7611 {
7612 /* This only works if an array descriptor has been passed; thus, extract
7613 the size from the descriptor. */
7614 gcc_assert (TYPE_PRECISION (gfc_array_index_type)
7615 == TYPE_PRECISION (size_type_node));
7616 tmp = arg->symtree->n.sym->backend_decl;
7617 tmp = DECL_LANG_SPECIFIC (tmp)
7618 && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
7619 ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
7620 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
7621 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7622
7623 tmp = gfc_conv_descriptor_dtype (tmp);
7624 field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
7625 GFC_DTYPE_ELEM_LEN);
7626 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
7627 tmp, field, NULL_TREE);
7628
7629 byte_size = fold_convert (gfc_array_index_type, tmp);
7630 }
7631 else if (arg->ts.type == BT_CLASS)
7632 {
7633 /* Conv_expr_descriptor returns a component_ref to _data component of the
7634 class object. The class object may be a non-pointer object, e.g.
7635 located on the stack, or a memory location pointed to, e.g. a
7636 parameter, i.e., an indirect_ref. */
7637 if (arg->rank < 0
7638 || (arg->rank > 0 && !VAR_P (argse.expr)
7639 && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0))
7640 && GFC_DECL_CLASS (TREE_OPERAND (
7641 TREE_OPERAND (argse.expr, 0), 0)))
7642 || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))))
7643 byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
7644 else if (arg->rank > 0
7645 || (arg->rank == 0
7646 && arg->ref && arg->ref->type == REF_COMPONENT))
7647 /* The scalarizer added an additional temp. To get the class' vptr
7648 one has to look at the original backend_decl. */
7649 byte_size = gfc_class_vtab_size_get (
7650 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
7651 else
7652 byte_size = gfc_class_vtab_size_get (argse.expr);
7653 }
7654 else
7655 {
7656 if (arg->ts.type == BT_CHARACTER)
7657 byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
7658 else
7659 {
7660 if (arg->rank == 0)
7661 byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7662 argse.expr));
7663 else
7664 byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
7665 byte_size = fold_convert (gfc_array_index_type,
7666 size_in_bytes (byte_size));
7667 }
7668 }
7669
7670 if (arg->rank == 0)
7671 se->expr = byte_size;
7672 else
7673 {
7674 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
7675 gfc_add_modify (&argse.pre, source_bytes, byte_size);
7676
7677 if (arg->rank == -1)
7678 {
7679 tree cond, loop_var, exit_label;
7680 stmtblock_t body;
7681
7682 tmp = fold_convert (gfc_array_index_type,
7683 gfc_conv_descriptor_rank (argse.expr));
7684 loop_var = gfc_create_var (gfc_array_index_type, "i");
7685 gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
7686 exit_label = gfc_build_label_decl (NULL_TREE);
7687
7688 /* Create loop:
7689 for (;;)
7690 {
7691 if (i >= rank)
7692 goto exit;
7693 source_bytes = source_bytes * array.dim[i].extent;
7694 i = i + 1;
7695 }
7696 exit: */
7697 gfc_start_block (&body);
7698 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
7699 loop_var, tmp);
7700 tmp = build1_v (GOTO_EXPR, exit_label);
7701 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
7702 cond, tmp, build_empty_stmt (input_location));
7703 gfc_add_expr_to_block (&body, tmp);
7704
7705 lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
7706 upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
7707 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
7708 tmp = fold_build2_loc (input_location, MULT_EXPR,
7709 gfc_array_index_type, tmp, source_bytes);
7710 gfc_add_modify (&body, source_bytes, tmp);
7711
7712 tmp = fold_build2_loc (input_location, PLUS_EXPR,
7713 gfc_array_index_type, loop_var,
7714 gfc_index_one_node);
7715 gfc_add_modify_loc (input_location, &body, loop_var, tmp);
7716
7717 tmp = gfc_finish_block (&body);
7718
7719 tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
7720 tmp);
7721 gfc_add_expr_to_block (&argse.pre, tmp);
7722
7723 tmp = build1_v (LABEL_EXPR, exit_label);
7724 gfc_add_expr_to_block (&argse.pre, tmp);
7725 }
7726 else
7727 {
7728 /* Obtain the size of the array in bytes. */
7729 for (n = 0; n < arg->rank; n++)
7730 {
7731 tree idx;
7732 idx = gfc_rank_cst[n];
7733 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
7734 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
7735 tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
7736 tmp = fold_build2_loc (input_location, MULT_EXPR,
7737 gfc_array_index_type, tmp, source_bytes);
7738 gfc_add_modify (&argse.pre, source_bytes, tmp);
7739 }
7740 }
7741 se->expr = source_bytes;
7742 }
7743
7744 gfc_add_block_to_block (&se->pre, &argse.pre);
7745 }
7746
7747
7748 static void
gfc_conv_intrinsic_storage_size(gfc_se * se,gfc_expr * expr)7749 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
7750 {
7751 gfc_expr *arg;
7752 gfc_se argse;
7753 tree type, result_type, tmp;
7754
7755 arg = expr->value.function.actual->expr;
7756
7757 gfc_init_se (&argse, NULL);
7758 result_type = gfc_get_int_type (expr->ts.kind);
7759
7760 if (arg->rank == 0)
7761 {
7762 if (arg->ts.type == BT_CLASS)
7763 {
7764 gfc_add_vptr_component (arg);
7765 gfc_add_size_component (arg);
7766 gfc_conv_expr (&argse, arg);
7767 tmp = fold_convert (result_type, argse.expr);
7768 goto done;
7769 }
7770
7771 gfc_conv_expr_reference (&argse, arg);
7772 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7773 argse.expr));
7774 }
7775 else
7776 {
7777 argse.want_pointer = 0;
7778 gfc_conv_expr_descriptor (&argse, arg);
7779 if (arg->ts.type == BT_CLASS)
7780 {
7781 if (arg->rank > 0)
7782 tmp = gfc_class_vtab_size_get (
7783 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
7784 else
7785 tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
7786 tmp = fold_convert (result_type, tmp);
7787 goto done;
7788 }
7789 type = gfc_get_element_type (TREE_TYPE (argse.expr));
7790 }
7791
7792 /* Obtain the argument's word length. */
7793 if (arg->ts.type == BT_CHARACTER)
7794 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
7795 else
7796 tmp = size_in_bytes (type);
7797 tmp = fold_convert (result_type, tmp);
7798
7799 done:
7800 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
7801 build_int_cst (result_type, BITS_PER_UNIT));
7802 gfc_add_block_to_block (&se->pre, &argse.pre);
7803 }
7804
7805
7806 /* Intrinsic string comparison functions. */
7807
7808 static void
gfc_conv_intrinsic_strcmp(gfc_se * se,gfc_expr * expr,enum tree_code op)7809 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
7810 {
7811 tree args[4];
7812
7813 gfc_conv_intrinsic_function_args (se, expr, args, 4);
7814
7815 se->expr
7816 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
7817 expr->value.function.actual->expr->ts.kind,
7818 op);
7819 se->expr = fold_build2_loc (input_location, op,
7820 gfc_typenode_for_spec (&expr->ts), se->expr,
7821 build_int_cst (TREE_TYPE (se->expr), 0));
7822 }
7823
7824 /* Generate a call to the adjustl/adjustr library function. */
7825 static void
gfc_conv_intrinsic_adjust(gfc_se * se,gfc_expr * expr,tree fndecl)7826 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
7827 {
7828 tree args[3];
7829 tree len;
7830 tree type;
7831 tree var;
7832 tree tmp;
7833
7834 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
7835 len = args[1];
7836
7837 type = TREE_TYPE (args[2]);
7838 var = gfc_conv_string_tmp (se, type, len);
7839 args[0] = var;
7840
7841 tmp = build_call_expr_loc (input_location,
7842 fndecl, 3, args[0], args[1], args[2]);
7843 gfc_add_expr_to_block (&se->pre, tmp);
7844 se->expr = var;
7845 se->string_length = len;
7846 }
7847
7848
7849 /* Generate code for the TRANSFER intrinsic:
7850 For scalar results:
7851 DEST = TRANSFER (SOURCE, MOLD)
7852 where:
7853 typeof<DEST> = typeof<MOLD>
7854 and:
7855 MOLD is scalar.
7856
7857 For array results:
7858 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
7859 where:
7860 typeof<DEST> = typeof<MOLD>
7861 and:
7862 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
7863 sizeof (DEST(0) * SIZE). */
7864 static void
gfc_conv_intrinsic_transfer(gfc_se * se,gfc_expr * expr)7865 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
7866 {
7867 tree tmp;
7868 tree tmpdecl;
7869 tree ptr;
7870 tree extent;
7871 tree source;
7872 tree source_type;
7873 tree source_bytes;
7874 tree mold_type;
7875 tree dest_word_len;
7876 tree size_words;
7877 tree size_bytes;
7878 tree upper;
7879 tree lower;
7880 tree stmt;
7881 tree class_ref = NULL_TREE;
7882 gfc_actual_arglist *arg;
7883 gfc_se argse;
7884 gfc_array_info *info;
7885 stmtblock_t block;
7886 int n;
7887 bool scalar_mold;
7888 gfc_expr *source_expr, *mold_expr, *class_expr;
7889
7890 info = NULL;
7891 if (se->loop)
7892 info = &se->ss->info->data.array;
7893
7894 /* Convert SOURCE. The output from this stage is:-
7895 source_bytes = length of the source in bytes
7896 source = pointer to the source data. */
7897 arg = expr->value.function.actual;
7898 source_expr = arg->expr;
7899
7900 /* Ensure double transfer through LOGICAL preserves all
7901 the needed bits. */
7902 if (arg->expr->expr_type == EXPR_FUNCTION
7903 && arg->expr->value.function.esym == NULL
7904 && arg->expr->value.function.isym != NULL
7905 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
7906 && arg->expr->ts.type == BT_LOGICAL
7907 && expr->ts.type != arg->expr->ts.type)
7908 arg->expr->value.function.name = "__transfer_in_transfer";
7909
7910 gfc_init_se (&argse, NULL);
7911
7912 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
7913
7914 /* Obtain the pointer to source and the length of source in bytes. */
7915 if (arg->expr->rank == 0)
7916 {
7917 gfc_conv_expr_reference (&argse, arg->expr);
7918 if (arg->expr->ts.type == BT_CLASS)
7919 {
7920 tmp = build_fold_indirect_ref_loc (input_location, argse.expr);
7921 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
7922 source = gfc_class_data_get (tmp);
7923 else
7924 {
7925 /* Array elements are evaluated as a reference to the data.
7926 To obtain the vptr for the element size, the argument
7927 expression must be stripped to the class reference and
7928 re-evaluated. The pre and post blocks are not needed. */
7929 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
7930 source = argse.expr;
7931 class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr);
7932 gfc_init_se (&argse, NULL);
7933 gfc_conv_expr (&argse, class_expr);
7934 class_ref = argse.expr;
7935 }
7936 }
7937 else
7938 source = argse.expr;
7939
7940 /* Obtain the source word length. */
7941 switch (arg->expr->ts.type)
7942 {
7943 case BT_CHARACTER:
7944 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
7945 argse.string_length);
7946 break;
7947 case BT_CLASS:
7948 if (class_ref != NULL_TREE)
7949 tmp = gfc_class_vtab_size_get (class_ref);
7950 else
7951 tmp = gfc_class_vtab_size_get (argse.expr);
7952 break;
7953 default:
7954 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7955 source));
7956 tmp = fold_convert (gfc_array_index_type,
7957 size_in_bytes (source_type));
7958 break;
7959 }
7960 }
7961 else
7962 {
7963 argse.want_pointer = 0;
7964 gfc_conv_expr_descriptor (&argse, arg->expr);
7965 source = gfc_conv_descriptor_data_get (argse.expr);
7966 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
7967
7968 /* Repack the source if not simply contiguous. */
7969 if (!gfc_is_simply_contiguous (arg->expr, false, true))
7970 {
7971 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
7972
7973 if (warn_array_temporaries)
7974 gfc_warning (OPT_Warray_temporaries,
7975 "Creating array temporary at %L", &expr->where);
7976
7977 source = build_call_expr_loc (input_location,
7978 gfor_fndecl_in_pack, 1, tmp);
7979 source = gfc_evaluate_now (source, &argse.pre);
7980
7981 /* Free the temporary. */
7982 gfc_start_block (&block);
7983 tmp = gfc_call_free (source);
7984 gfc_add_expr_to_block (&block, tmp);
7985 stmt = gfc_finish_block (&block);
7986
7987 /* Clean up if it was repacked. */
7988 gfc_init_block (&block);
7989 tmp = gfc_conv_array_data (argse.expr);
7990 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7991 source, tmp);
7992 tmp = build3_v (COND_EXPR, tmp, stmt,
7993 build_empty_stmt (input_location));
7994 gfc_add_expr_to_block (&block, tmp);
7995 gfc_add_block_to_block (&block, &se->post);
7996 gfc_init_block (&se->post);
7997 gfc_add_block_to_block (&se->post, &block);
7998 }
7999
8000 /* Obtain the source word length. */
8001 if (arg->expr->ts.type == BT_CHARACTER)
8002 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
8003 argse.string_length);
8004 else
8005 tmp = fold_convert (gfc_array_index_type,
8006 size_in_bytes (source_type));
8007
8008 /* Obtain the size of the array in bytes. */
8009 extent = gfc_create_var (gfc_array_index_type, NULL);
8010 for (n = 0; n < arg->expr->rank; n++)
8011 {
8012 tree idx;
8013 idx = gfc_rank_cst[n];
8014 gfc_add_modify (&argse.pre, source_bytes, tmp);
8015 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
8016 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
8017 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8018 gfc_array_index_type, upper, lower);
8019 gfc_add_modify (&argse.pre, extent, tmp);
8020 tmp = fold_build2_loc (input_location, PLUS_EXPR,
8021 gfc_array_index_type, extent,
8022 gfc_index_one_node);
8023 tmp = fold_build2_loc (input_location, MULT_EXPR,
8024 gfc_array_index_type, tmp, source_bytes);
8025 }
8026 }
8027
8028 gfc_add_modify (&argse.pre, source_bytes, tmp);
8029 gfc_add_block_to_block (&se->pre, &argse.pre);
8030 gfc_add_block_to_block (&se->post, &argse.post);
8031
8032 /* Now convert MOLD. The outputs are:
8033 mold_type = the TREE type of MOLD
8034 dest_word_len = destination word length in bytes. */
8035 arg = arg->next;
8036 mold_expr = arg->expr;
8037
8038 gfc_init_se (&argse, NULL);
8039
8040 scalar_mold = arg->expr->rank == 0;
8041
8042 if (arg->expr->rank == 0)
8043 {
8044 gfc_conv_expr_reference (&argse, arg->expr);
8045 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
8046 argse.expr));
8047 }
8048 else
8049 {
8050 gfc_init_se (&argse, NULL);
8051 argse.want_pointer = 0;
8052 gfc_conv_expr_descriptor (&argse, arg->expr);
8053 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
8054 }
8055
8056 gfc_add_block_to_block (&se->pre, &argse.pre);
8057 gfc_add_block_to_block (&se->post, &argse.post);
8058
8059 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
8060 {
8061 /* If this TRANSFER is nested in another TRANSFER, use a type
8062 that preserves all bits. */
8063 if (arg->expr->ts.type == BT_LOGICAL)
8064 mold_type = gfc_get_int_type (arg->expr->ts.kind);
8065 }
8066
8067 /* Obtain the destination word length. */
8068 switch (arg->expr->ts.type)
8069 {
8070 case BT_CHARACTER:
8071 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
8072 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
8073 break;
8074 case BT_CLASS:
8075 tmp = gfc_class_vtab_size_get (argse.expr);
8076 break;
8077 default:
8078 tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
8079 break;
8080 }
8081 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
8082 gfc_add_modify (&se->pre, dest_word_len, tmp);
8083
8084 /* Finally convert SIZE, if it is present. */
8085 arg = arg->next;
8086 size_words = gfc_create_var (gfc_array_index_type, NULL);
8087
8088 if (arg->expr)
8089 {
8090 gfc_init_se (&argse, NULL);
8091 gfc_conv_expr_reference (&argse, arg->expr);
8092 tmp = convert (gfc_array_index_type,
8093 build_fold_indirect_ref_loc (input_location,
8094 argse.expr));
8095 gfc_add_block_to_block (&se->pre, &argse.pre);
8096 gfc_add_block_to_block (&se->post, &argse.post);
8097 }
8098 else
8099 tmp = NULL_TREE;
8100
8101 /* Separate array and scalar results. */
8102 if (scalar_mold && tmp == NULL_TREE)
8103 goto scalar_transfer;
8104
8105 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
8106 if (tmp != NULL_TREE)
8107 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8108 tmp, dest_word_len);
8109 else
8110 tmp = source_bytes;
8111
8112 gfc_add_modify (&se->pre, size_bytes, tmp);
8113 gfc_add_modify (&se->pre, size_words,
8114 fold_build2_loc (input_location, CEIL_DIV_EXPR,
8115 gfc_array_index_type,
8116 size_bytes, dest_word_len));
8117
8118 /* Evaluate the bounds of the result. If the loop range exists, we have
8119 to check if it is too large. If so, we modify loop->to be consistent
8120 with min(size, size(source)). Otherwise, size is made consistent with
8121 the loop range, so that the right number of bytes is transferred.*/
8122 n = se->loop->order[0];
8123 if (se->loop->to[n] != NULL_TREE)
8124 {
8125 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8126 se->loop->to[n], se->loop->from[n]);
8127 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8128 tmp, gfc_index_one_node);
8129 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8130 tmp, size_words);
8131 gfc_add_modify (&se->pre, size_words, tmp);
8132 gfc_add_modify (&se->pre, size_bytes,
8133 fold_build2_loc (input_location, MULT_EXPR,
8134 gfc_array_index_type,
8135 size_words, dest_word_len));
8136 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8137 size_words, se->loop->from[n]);
8138 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8139 upper, gfc_index_one_node);
8140 }
8141 else
8142 {
8143 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8144 size_words, gfc_index_one_node);
8145 se->loop->from[n] = gfc_index_zero_node;
8146 }
8147
8148 se->loop->to[n] = upper;
8149
8150 /* Build a destination descriptor, using the pointer, source, as the
8151 data field. */
8152 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
8153 NULL_TREE, false, true, false, &expr->where);
8154
8155 /* Cast the pointer to the result. */
8156 tmp = gfc_conv_descriptor_data_get (info->descriptor);
8157 tmp = fold_convert (pvoid_type_node, tmp);
8158
8159 /* Use memcpy to do the transfer. */
8160 tmp
8161 = build_call_expr_loc (input_location,
8162 builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
8163 fold_convert (pvoid_type_node, source),
8164 fold_convert (size_type_node,
8165 fold_build2_loc (input_location,
8166 MIN_EXPR,
8167 gfc_array_index_type,
8168 size_bytes,
8169 source_bytes)));
8170 gfc_add_expr_to_block (&se->pre, tmp);
8171
8172 se->expr = info->descriptor;
8173 if (expr->ts.type == BT_CHARACTER)
8174 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
8175
8176 return;
8177
8178 /* Deal with scalar results. */
8179 scalar_transfer:
8180 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
8181 dest_word_len, source_bytes);
8182 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8183 extent, gfc_index_zero_node);
8184
8185 if (expr->ts.type == BT_CHARACTER)
8186 {
8187 tree direct, indirect, free;
8188
8189 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
8190 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
8191 "transfer");
8192
8193 /* If source is longer than the destination, use a pointer to
8194 the source directly. */
8195 gfc_init_block (&block);
8196 gfc_add_modify (&block, tmpdecl, ptr);
8197 direct = gfc_finish_block (&block);
8198
8199 /* Otherwise, allocate a string with the length of the destination
8200 and copy the source into it. */
8201 gfc_init_block (&block);
8202 tmp = gfc_get_pchar_type (expr->ts.kind);
8203 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
8204 gfc_add_modify (&block, tmpdecl,
8205 fold_convert (TREE_TYPE (ptr), tmp));
8206 tmp = build_call_expr_loc (input_location,
8207 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
8208 fold_convert (pvoid_type_node, tmpdecl),
8209 fold_convert (pvoid_type_node, ptr),
8210 fold_convert (size_type_node, extent));
8211 gfc_add_expr_to_block (&block, tmp);
8212 indirect = gfc_finish_block (&block);
8213
8214 /* Wrap it up with the condition. */
8215 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
8216 dest_word_len, source_bytes);
8217 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
8218 gfc_add_expr_to_block (&se->pre, tmp);
8219
8220 /* Free the temporary string, if necessary. */
8221 free = gfc_call_free (tmpdecl);
8222 tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
8223 dest_word_len, source_bytes);
8224 tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
8225 gfc_add_expr_to_block (&se->post, tmp);
8226
8227 se->expr = tmpdecl;
8228 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
8229 }
8230 else
8231 {
8232 tmpdecl = gfc_create_var (mold_type, "transfer");
8233
8234 ptr = convert (build_pointer_type (mold_type), source);
8235
8236 /* For CLASS results, allocate the needed memory first. */
8237 if (mold_expr->ts.type == BT_CLASS)
8238 {
8239 tree cdata;
8240 cdata = gfc_class_data_get (tmpdecl);
8241 tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
8242 gfc_add_modify (&se->pre, cdata, tmp);
8243 }
8244
8245 /* Use memcpy to do the transfer. */
8246 if (mold_expr->ts.type == BT_CLASS)
8247 tmp = gfc_class_data_get (tmpdecl);
8248 else
8249 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
8250
8251 tmp = build_call_expr_loc (input_location,
8252 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
8253 fold_convert (pvoid_type_node, tmp),
8254 fold_convert (pvoid_type_node, ptr),
8255 fold_convert (size_type_node, extent));
8256 gfc_add_expr_to_block (&se->pre, tmp);
8257
8258 /* For CLASS results, set the _vptr. */
8259 if (mold_expr->ts.type == BT_CLASS)
8260 {
8261 tree vptr;
8262 gfc_symbol *vtab;
8263 vptr = gfc_class_vptr_get (tmpdecl);
8264 vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
8265 gcc_assert (vtab);
8266 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
8267 gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
8268 }
8269
8270 se->expr = tmpdecl;
8271 }
8272 }
8273
8274
8275 /* Generate a call to caf_is_present. */
8276
8277 static tree
trans_caf_is_present(gfc_se * se,gfc_expr * expr)8278 trans_caf_is_present (gfc_se *se, gfc_expr *expr)
8279 {
8280 tree caf_reference, caf_decl, token, image_index;
8281
8282 /* Compile the reference chain. */
8283 caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr);
8284 gcc_assert (caf_reference != NULL_TREE);
8285
8286 caf_decl = gfc_get_tree_for_caf_expr (expr);
8287 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
8288 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
8289 image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl);
8290 gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
8291 expr);
8292
8293 return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present,
8294 3, token, image_index, caf_reference);
8295 }
8296
8297
8298 /* Test whether this ref-chain refs this image only. */
8299
8300 static bool
caf_this_image_ref(gfc_ref * ref)8301 caf_this_image_ref (gfc_ref *ref)
8302 {
8303 for ( ; ref; ref = ref->next)
8304 if (ref->type == REF_ARRAY && ref->u.ar.codimen)
8305 return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE;
8306
8307 return false;
8308 }
8309
8310
8311 /* Generate code for the ALLOCATED intrinsic.
8312 Generate inline code that directly check the address of the argument. */
8313
8314 static void
gfc_conv_allocated(gfc_se * se,gfc_expr * expr)8315 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
8316 {
8317 gfc_actual_arglist *arg1;
8318 gfc_se arg1se;
8319 tree tmp;
8320 symbol_attribute caf_attr;
8321
8322 gfc_init_se (&arg1se, NULL);
8323 arg1 = expr->value.function.actual;
8324
8325 if (arg1->expr->ts.type == BT_CLASS)
8326 {
8327 /* Make sure that class array expressions have both a _data
8328 component reference and an array reference.... */
8329 if (CLASS_DATA (arg1->expr)->attr.dimension)
8330 gfc_add_class_array_ref (arg1->expr);
8331 /* .... whilst scalars only need the _data component. */
8332 else
8333 gfc_add_data_component (arg1->expr);
8334 }
8335
8336 /* When arg1 references an allocatable component in a coarray, then call
8337 the caf-library function caf_is_present (). */
8338 if (flag_coarray == GFC_FCOARRAY_LIB && arg1->expr->expr_type == EXPR_FUNCTION
8339 && arg1->expr->value.function.isym
8340 && arg1->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
8341 caf_attr = gfc_caf_attr (arg1->expr->value.function.actual->expr);
8342 else
8343 gfc_clear_attr (&caf_attr);
8344 if (flag_coarray == GFC_FCOARRAY_LIB && caf_attr.codimension
8345 && !caf_this_image_ref (arg1->expr->value.function.actual->expr->ref))
8346 tmp = trans_caf_is_present (se, arg1->expr->value.function.actual->expr);
8347 else
8348 {
8349 if (arg1->expr->rank == 0)
8350 {
8351 /* Allocatable scalar. */
8352 arg1se.want_pointer = 1;
8353 gfc_conv_expr (&arg1se, arg1->expr);
8354 tmp = arg1se.expr;
8355 }
8356 else
8357 {
8358 /* Allocatable array. */
8359 arg1se.descriptor_only = 1;
8360 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
8361 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
8362 }
8363
8364 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
8365 fold_convert (TREE_TYPE (tmp), null_pointer_node));
8366 }
8367
8368 /* Components of pointer array references sometimes come back with a pre block. */
8369 if (arg1se.pre.head)
8370 gfc_add_block_to_block (&se->pre, &arg1se.pre);
8371
8372 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
8373 }
8374
8375
8376 /* Generate code for the ASSOCIATED intrinsic.
8377 If both POINTER and TARGET are arrays, generate a call to library function
8378 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
8379 In other cases, generate inline code that directly compare the address of
8380 POINTER with the address of TARGET. */
8381
8382 static void
gfc_conv_associated(gfc_se * se,gfc_expr * expr)8383 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
8384 {
8385 gfc_actual_arglist *arg1;
8386 gfc_actual_arglist *arg2;
8387 gfc_se arg1se;
8388 gfc_se arg2se;
8389 tree tmp2;
8390 tree tmp;
8391 tree nonzero_charlen;
8392 tree nonzero_arraylen;
8393 gfc_ss *ss;
8394 bool scalar;
8395
8396 gfc_init_se (&arg1se, NULL);
8397 gfc_init_se (&arg2se, NULL);
8398 arg1 = expr->value.function.actual;
8399 arg2 = arg1->next;
8400
8401 /* Check whether the expression is a scalar or not; we cannot use
8402 arg1->expr->rank as it can be nonzero for proc pointers. */
8403 ss = gfc_walk_expr (arg1->expr);
8404 scalar = ss == gfc_ss_terminator;
8405 if (!scalar)
8406 gfc_free_ss_chain (ss);
8407
8408 if (!arg2->expr)
8409 {
8410 /* No optional target. */
8411 if (scalar)
8412 {
8413 /* A pointer to a scalar. */
8414 arg1se.want_pointer = 1;
8415 gfc_conv_expr (&arg1se, arg1->expr);
8416 if (arg1->expr->symtree->n.sym->attr.proc_pointer
8417 && arg1->expr->symtree->n.sym->attr.dummy)
8418 arg1se.expr = build_fold_indirect_ref_loc (input_location,
8419 arg1se.expr);
8420 if (arg1->expr->ts.type == BT_CLASS)
8421 {
8422 tmp2 = gfc_class_data_get (arg1se.expr);
8423 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8424 tmp2 = gfc_conv_descriptor_data_get (tmp2);
8425 }
8426 else
8427 tmp2 = arg1se.expr;
8428 }
8429 else
8430 {
8431 /* A pointer to an array. */
8432 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
8433 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
8434 }
8435 gfc_add_block_to_block (&se->pre, &arg1se.pre);
8436 gfc_add_block_to_block (&se->post, &arg1se.post);
8437 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2,
8438 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
8439 se->expr = tmp;
8440 }
8441 else
8442 {
8443 /* An optional target. */
8444 if (arg2->expr->ts.type == BT_CLASS)
8445 gfc_add_data_component (arg2->expr);
8446
8447 nonzero_charlen = NULL_TREE;
8448 if (arg1->expr->ts.type == BT_CHARACTER)
8449 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
8450 logical_type_node,
8451 arg1->expr->ts.u.cl->backend_decl,
8452 build_zero_cst
8453 (TREE_TYPE (arg1->expr->ts.u.cl->backend_decl)));
8454 if (scalar)
8455 {
8456 /* A pointer to a scalar. */
8457 arg1se.want_pointer = 1;
8458 gfc_conv_expr (&arg1se, arg1->expr);
8459 if (arg1->expr->symtree->n.sym->attr.proc_pointer
8460 && arg1->expr->symtree->n.sym->attr.dummy)
8461 arg1se.expr = build_fold_indirect_ref_loc (input_location,
8462 arg1se.expr);
8463 if (arg1->expr->ts.type == BT_CLASS)
8464 arg1se.expr = gfc_class_data_get (arg1se.expr);
8465
8466 arg2se.want_pointer = 1;
8467 gfc_conv_expr (&arg2se, arg2->expr);
8468 if (arg2->expr->symtree->n.sym->attr.proc_pointer
8469 && arg2->expr->symtree->n.sym->attr.dummy)
8470 arg2se.expr = build_fold_indirect_ref_loc (input_location,
8471 arg2se.expr);
8472 gfc_add_block_to_block (&se->pre, &arg1se.pre);
8473 gfc_add_block_to_block (&se->post, &arg1se.post);
8474 gfc_add_block_to_block (&se->pre, &arg2se.pre);
8475 gfc_add_block_to_block (&se->post, &arg2se.post);
8476 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
8477 arg1se.expr, arg2se.expr);
8478 tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8479 arg1se.expr, null_pointer_node);
8480 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8481 logical_type_node, tmp, tmp2);
8482 }
8483 else
8484 {
8485 /* An array pointer of zero length is not associated if target is
8486 present. */
8487 arg1se.descriptor_only = 1;
8488 gfc_conv_expr_lhs (&arg1se, arg1->expr);
8489 if (arg1->expr->rank == -1)
8490 {
8491 tmp = gfc_conv_descriptor_rank (arg1se.expr);
8492 tmp = fold_build2_loc (input_location, MINUS_EXPR,
8493 TREE_TYPE (tmp), tmp, gfc_index_one_node);
8494 }
8495 else
8496 tmp = gfc_rank_cst[arg1->expr->rank - 1];
8497 tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
8498 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
8499 logical_type_node, tmp,
8500 build_int_cst (TREE_TYPE (tmp), 0));
8501
8502 /* A pointer to an array, call library function _gfor_associated. */
8503 arg1se.want_pointer = 1;
8504 gfc_conv_expr_descriptor (&arg1se, arg1->expr);
8505 gfc_add_block_to_block (&se->pre, &arg1se.pre);
8506 gfc_add_block_to_block (&se->post, &arg1se.post);
8507
8508 arg2se.want_pointer = 1;
8509 gfc_conv_expr_descriptor (&arg2se, arg2->expr);
8510 gfc_add_block_to_block (&se->pre, &arg2se.pre);
8511 gfc_add_block_to_block (&se->post, &arg2se.post);
8512 se->expr = build_call_expr_loc (input_location,
8513 gfor_fndecl_associated, 2,
8514 arg1se.expr, arg2se.expr);
8515 se->expr = convert (logical_type_node, se->expr);
8516 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8517 logical_type_node, se->expr,
8518 nonzero_arraylen);
8519 }
8520
8521 /* If target is present zero character length pointers cannot
8522 be associated. */
8523 if (nonzero_charlen != NULL_TREE)
8524 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8525 logical_type_node,
8526 se->expr, nonzero_charlen);
8527 }
8528
8529 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8530 }
8531
8532
8533 /* Generate code for the SAME_TYPE_AS intrinsic.
8534 Generate inline code that directly checks the vindices. */
8535
8536 static void
gfc_conv_same_type_as(gfc_se * se,gfc_expr * expr)8537 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
8538 {
8539 gfc_expr *a, *b;
8540 gfc_se se1, se2;
8541 tree tmp;
8542 tree conda = NULL_TREE, condb = NULL_TREE;
8543
8544 gfc_init_se (&se1, NULL);
8545 gfc_init_se (&se2, NULL);
8546
8547 a = expr->value.function.actual->expr;
8548 b = expr->value.function.actual->next->expr;
8549
8550 if (UNLIMITED_POLY (a))
8551 {
8552 tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
8553 conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8554 tmp, build_int_cst (TREE_TYPE (tmp), 0));
8555 }
8556
8557 if (UNLIMITED_POLY (b))
8558 {
8559 tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl);
8560 condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8561 tmp, build_int_cst (TREE_TYPE (tmp), 0));
8562 }
8563
8564 if (a->ts.type == BT_CLASS)
8565 {
8566 gfc_add_vptr_component (a);
8567 gfc_add_hash_component (a);
8568 }
8569 else if (a->ts.type == BT_DERIVED)
8570 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8571 a->ts.u.derived->hash_value);
8572
8573 if (b->ts.type == BT_CLASS)
8574 {
8575 gfc_add_vptr_component (b);
8576 gfc_add_hash_component (b);
8577 }
8578 else if (b->ts.type == BT_DERIVED)
8579 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
8580 b->ts.u.derived->hash_value);
8581
8582 gfc_conv_expr (&se1, a);
8583 gfc_conv_expr (&se2, b);
8584
8585 tmp = fold_build2_loc (input_location, EQ_EXPR,
8586 logical_type_node, se1.expr,
8587 fold_convert (TREE_TYPE (se1.expr), se2.expr));
8588
8589 if (conda)
8590 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
8591 logical_type_node, conda, tmp);
8592
8593 if (condb)
8594 tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
8595 logical_type_node, condb, tmp);
8596
8597 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
8598 }
8599
8600
8601 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
8602
8603 static void
gfc_conv_intrinsic_sc_kind(gfc_se * se,gfc_expr * expr)8604 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
8605 {
8606 tree args[2];
8607
8608 gfc_conv_intrinsic_function_args (se, expr, args, 2);
8609 se->expr = build_call_expr_loc (input_location,
8610 gfor_fndecl_sc_kind, 2, args[0], args[1]);
8611 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8612 }
8613
8614
8615 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
8616
8617 static void
gfc_conv_intrinsic_si_kind(gfc_se * se,gfc_expr * expr)8618 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
8619 {
8620 tree arg, type;
8621
8622 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8623
8624 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
8625 type = gfc_get_int_type (4);
8626 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
8627
8628 /* Convert it to the required type. */
8629 type = gfc_typenode_for_spec (&expr->ts);
8630 se->expr = build_call_expr_loc (input_location,
8631 gfor_fndecl_si_kind, 1, arg);
8632 se->expr = fold_convert (type, se->expr);
8633 }
8634
8635
8636 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
8637
8638 static void
gfc_conv_intrinsic_sr_kind(gfc_se * se,gfc_expr * expr)8639 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
8640 {
8641 gfc_actual_arglist *actual;
8642 tree type;
8643 gfc_se argse;
8644 vec<tree, va_gc> *args = NULL;
8645
8646 for (actual = expr->value.function.actual; actual; actual = actual->next)
8647 {
8648 gfc_init_se (&argse, se);
8649
8650 /* Pass a NULL pointer for an absent arg. */
8651 if (actual->expr == NULL)
8652 argse.expr = null_pointer_node;
8653 else
8654 {
8655 gfc_typespec ts;
8656 gfc_clear_ts (&ts);
8657
8658 if (actual->expr->ts.kind != gfc_c_int_kind)
8659 {
8660 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
8661 ts.type = BT_INTEGER;
8662 ts.kind = gfc_c_int_kind;
8663 gfc_convert_type (actual->expr, &ts, 2);
8664 }
8665 gfc_conv_expr_reference (&argse, actual->expr);
8666 }
8667
8668 gfc_add_block_to_block (&se->pre, &argse.pre);
8669 gfc_add_block_to_block (&se->post, &argse.post);
8670 vec_safe_push (args, argse.expr);
8671 }
8672
8673 /* Convert it to the required type. */
8674 type = gfc_typenode_for_spec (&expr->ts);
8675 se->expr = build_call_expr_loc_vec (input_location,
8676 gfor_fndecl_sr_kind, args);
8677 se->expr = fold_convert (type, se->expr);
8678 }
8679
8680
8681 /* Generate code for TRIM (A) intrinsic function. */
8682
8683 static void
gfc_conv_intrinsic_trim(gfc_se * se,gfc_expr * expr)8684 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
8685 {
8686 tree var;
8687 tree len;
8688 tree addr;
8689 tree tmp;
8690 tree cond;
8691 tree fndecl;
8692 tree function;
8693 tree *args;
8694 unsigned int num_args;
8695
8696 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
8697 args = XALLOCAVEC (tree, num_args);
8698
8699 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
8700 addr = gfc_build_addr_expr (ppvoid_type_node, var);
8701 len = gfc_create_var (gfc_charlen_type_node, "len");
8702
8703 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
8704 args[0] = gfc_build_addr_expr (NULL_TREE, len);
8705 args[1] = addr;
8706
8707 if (expr->ts.kind == 1)
8708 function = gfor_fndecl_string_trim;
8709 else if (expr->ts.kind == 4)
8710 function = gfor_fndecl_string_trim_char4;
8711 else
8712 gcc_unreachable ();
8713
8714 fndecl = build_addr (function);
8715 tmp = build_call_array_loc (input_location,
8716 TREE_TYPE (TREE_TYPE (function)), fndecl,
8717 num_args, args);
8718 gfc_add_expr_to_block (&se->pre, tmp);
8719
8720 /* Free the temporary afterwards, if necessary. */
8721 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
8722 len, build_int_cst (TREE_TYPE (len), 0));
8723 tmp = gfc_call_free (var);
8724 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
8725 gfc_add_expr_to_block (&se->post, tmp);
8726
8727 se->expr = var;
8728 se->string_length = len;
8729 }
8730
8731
8732 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
8733
8734 static void
gfc_conv_intrinsic_repeat(gfc_se * se,gfc_expr * expr)8735 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
8736 {
8737 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
8738 tree type, cond, tmp, count, exit_label, n, max, largest;
8739 tree size;
8740 stmtblock_t block, body;
8741 int i;
8742
8743 /* We store in charsize the size of a character. */
8744 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
8745 size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8);
8746
8747 /* Get the arguments. */
8748 gfc_conv_intrinsic_function_args (se, expr, args, 3);
8749 slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre));
8750 src = args[1];
8751 ncopies = gfc_evaluate_now (args[2], &se->pre);
8752 ncopies_type = TREE_TYPE (ncopies);
8753
8754 /* Check that NCOPIES is not negative. */
8755 cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies,
8756 build_int_cst (ncopies_type, 0));
8757 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
8758 "Argument NCOPIES of REPEAT intrinsic is negative "
8759 "(its value is %ld)",
8760 fold_convert (long_integer_type_node, ncopies));
8761
8762 /* If the source length is zero, any non negative value of NCOPIES
8763 is valid, and nothing happens. */
8764 n = gfc_create_var (ncopies_type, "ncopies");
8765 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
8766 size_zero_node);
8767 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
8768 build_int_cst (ncopies_type, 0), ncopies);
8769 gfc_add_modify (&se->pre, n, tmp);
8770 ncopies = n;
8771
8772 /* Check that ncopies is not too large: ncopies should be less than
8773 (or equal to) MAX / slen, where MAX is the maximal integer of
8774 the gfc_charlen_type_node type. If slen == 0, we need a special
8775 case to avoid the division by zero. */
8776 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype,
8777 fold_convert (sizetype,
8778 TYPE_MAX_VALUE (gfc_charlen_type_node)),
8779 slen);
8780 largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type)
8781 ? sizetype : ncopies_type;
8782 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
8783 fold_convert (largest, ncopies),
8784 fold_convert (largest, max));
8785 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen,
8786 size_zero_node);
8787 cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp,
8788 logical_false_node, cond);
8789 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
8790 "Argument NCOPIES of REPEAT intrinsic is too large");
8791
8792 /* Compute the destination length. */
8793 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
8794 fold_convert (gfc_charlen_type_node, slen),
8795 fold_convert (gfc_charlen_type_node, ncopies));
8796 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
8797 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
8798
8799 /* Generate the code to do the repeat operation:
8800 for (i = 0; i < ncopies; i++)
8801 memmove (dest + (i * slen * size), src, slen*size); */
8802 gfc_start_block (&block);
8803 count = gfc_create_var (sizetype, "count");
8804 gfc_add_modify (&block, count, size_zero_node);
8805 exit_label = gfc_build_label_decl (NULL_TREE);
8806
8807 /* Start the loop body. */
8808 gfc_start_block (&body);
8809
8810 /* Exit the loop if count >= ncopies. */
8811 cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count,
8812 fold_convert (sizetype, ncopies));
8813 tmp = build1_v (GOTO_EXPR, exit_label);
8814 TREE_USED (exit_label) = 1;
8815 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
8816 build_empty_stmt (input_location));
8817 gfc_add_expr_to_block (&body, tmp);
8818
8819 /* Call memmove (dest + (i*slen*size), src, slen*size). */
8820 tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen,
8821 count);
8822 tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp,
8823 size);
8824 tmp = fold_build_pointer_plus_loc (input_location,
8825 fold_convert (pvoid_type_node, dest), tmp);
8826 tmp = build_call_expr_loc (input_location,
8827 builtin_decl_explicit (BUILT_IN_MEMMOVE),
8828 3, tmp, src,
8829 fold_build2_loc (input_location, MULT_EXPR,
8830 size_type_node, slen, size));
8831 gfc_add_expr_to_block (&body, tmp);
8832
8833 /* Increment count. */
8834 tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype,
8835 count, size_one_node);
8836 gfc_add_modify (&body, count, tmp);
8837
8838 /* Build the loop. */
8839 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
8840 gfc_add_expr_to_block (&block, tmp);
8841
8842 /* Add the exit label. */
8843 tmp = build1_v (LABEL_EXPR, exit_label);
8844 gfc_add_expr_to_block (&block, tmp);
8845
8846 /* Finish the block. */
8847 tmp = gfc_finish_block (&block);
8848 gfc_add_expr_to_block (&se->pre, tmp);
8849
8850 /* Set the result value. */
8851 se->expr = dest;
8852 se->string_length = dlen;
8853 }
8854
8855
8856 /* Generate code for the IARGC intrinsic. */
8857
8858 static void
gfc_conv_intrinsic_iargc(gfc_se * se,gfc_expr * expr)8859 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
8860 {
8861 tree tmp;
8862 tree fndecl;
8863 tree type;
8864
8865 /* Call the library function. This always returns an INTEGER(4). */
8866 fndecl = gfor_fndecl_iargc;
8867 tmp = build_call_expr_loc (input_location,
8868 fndecl, 0);
8869
8870 /* Convert it to the required type. */
8871 type = gfc_typenode_for_spec (&expr->ts);
8872 tmp = fold_convert (type, tmp);
8873
8874 se->expr = tmp;
8875 }
8876
8877
8878 /* Generate code for the KILL intrinsic. */
8879
8880 static void
conv_intrinsic_kill(gfc_se * se,gfc_expr * expr)8881 conv_intrinsic_kill (gfc_se *se, gfc_expr *expr)
8882 {
8883 tree *args;
8884 tree int4_type_node = gfc_get_int_type (4);
8885 tree pid;
8886 tree sig;
8887 tree tmp;
8888 unsigned int num_args;
8889
8890 num_args = gfc_intrinsic_argument_list_length (expr);
8891 args = XALLOCAVEC (tree, num_args);
8892 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
8893
8894 /* Convert PID to a INTEGER(4) entity. */
8895 pid = convert (int4_type_node, args[0]);
8896
8897 /* Convert SIG to a INTEGER(4) entity. */
8898 sig = convert (int4_type_node, args[1]);
8899
8900 tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig);
8901
8902 se->expr = fold_convert (TREE_TYPE (args[0]), tmp);
8903 }
8904
8905
8906 static tree
conv_intrinsic_kill_sub(gfc_code * code)8907 conv_intrinsic_kill_sub (gfc_code *code)
8908 {
8909 stmtblock_t block;
8910 gfc_se se, se_stat;
8911 tree int4_type_node = gfc_get_int_type (4);
8912 tree pid;
8913 tree sig;
8914 tree statp;
8915 tree tmp;
8916
8917 /* Make the function call. */
8918 gfc_init_block (&block);
8919 gfc_init_se (&se, NULL);
8920
8921 /* Convert PID to a INTEGER(4) entity. */
8922 gfc_conv_expr (&se, code->ext.actual->expr);
8923 gfc_add_block_to_block (&block, &se.pre);
8924 pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
8925 gfc_add_block_to_block (&block, &se.post);
8926
8927 /* Convert SIG to a INTEGER(4) entity. */
8928 gfc_conv_expr (&se, code->ext.actual->next->expr);
8929 gfc_add_block_to_block (&block, &se.pre);
8930 sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
8931 gfc_add_block_to_block (&block, &se.post);
8932
8933 /* Deal with an optional STATUS. */
8934 if (code->ext.actual->next->next->expr)
8935 {
8936 gfc_init_se (&se_stat, NULL);
8937 gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr);
8938 statp = gfc_create_var (gfc_get_int_type (4), "_statp");
8939 }
8940 else
8941 statp = NULL_TREE;
8942
8943 tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig,
8944 statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node);
8945
8946 gfc_add_expr_to_block (&block, tmp);
8947
8948 if (statp && statp != se_stat.expr)
8949 gfc_add_modify (&block, se_stat.expr,
8950 fold_convert (TREE_TYPE (se_stat.expr), statp));
8951
8952 return gfc_finish_block (&block);
8953 }
8954
8955
8956
8957 /* The loc intrinsic returns the address of its argument as
8958 gfc_index_integer_kind integer. */
8959
8960 static void
gfc_conv_intrinsic_loc(gfc_se * se,gfc_expr * expr)8961 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
8962 {
8963 tree temp_var;
8964 gfc_expr *arg_expr;
8965
8966 gcc_assert (!se->ss);
8967
8968 arg_expr = expr->value.function.actual->expr;
8969 if (arg_expr->rank == 0)
8970 {
8971 if (arg_expr->ts.type == BT_CLASS)
8972 gfc_add_data_component (arg_expr);
8973 gfc_conv_expr_reference (se, arg_expr);
8974 }
8975 else
8976 gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
8977 se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
8978
8979 /* Create a temporary variable for loc return value. Without this,
8980 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
8981 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
8982 gfc_add_modify (&se->pre, temp_var, se->expr);
8983 se->expr = temp_var;
8984 }
8985
8986
8987 /* The following routine generates code for the intrinsic
8988 functions from the ISO_C_BINDING module:
8989 * C_LOC
8990 * C_FUNLOC
8991 * C_ASSOCIATED */
8992
8993 static void
conv_isocbinding_function(gfc_se * se,gfc_expr * expr)8994 conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
8995 {
8996 gfc_actual_arglist *arg = expr->value.function.actual;
8997
8998 if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
8999 {
9000 if (arg->expr->rank == 0)
9001 gfc_conv_expr_reference (se, arg->expr);
9002 else if (gfc_is_simply_contiguous (arg->expr, false, false))
9003 gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
9004 else
9005 {
9006 gfc_conv_expr_descriptor (se, arg->expr);
9007 se->expr = gfc_conv_descriptor_data_get (se->expr);
9008 }
9009
9010 /* TODO -- the following two lines shouldn't be necessary, but if
9011 they're removed, a bug is exposed later in the code path.
9012 This workaround was thus introduced, but will have to be
9013 removed; please see PR 35150 for details about the issue. */
9014 se->expr = convert (pvoid_type_node, se->expr);
9015 se->expr = gfc_evaluate_now (se->expr, &se->pre);
9016 }
9017 else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
9018 gfc_conv_expr_reference (se, arg->expr);
9019 else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
9020 {
9021 gfc_se arg1se;
9022 gfc_se arg2se;
9023
9024 /* Build the addr_expr for the first argument. The argument is
9025 already an *address* so we don't need to set want_pointer in
9026 the gfc_se. */
9027 gfc_init_se (&arg1se, NULL);
9028 gfc_conv_expr (&arg1se, arg->expr);
9029 gfc_add_block_to_block (&se->pre, &arg1se.pre);
9030 gfc_add_block_to_block (&se->post, &arg1se.post);
9031
9032 /* See if we were given two arguments. */
9033 if (arg->next->expr == NULL)
9034 /* Only given one arg so generate a null and do a
9035 not-equal comparison against the first arg. */
9036 se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9037 arg1se.expr,
9038 fold_convert (TREE_TYPE (arg1se.expr),
9039 null_pointer_node));
9040 else
9041 {
9042 tree eq_expr;
9043 tree not_null_expr;
9044
9045 /* Given two arguments so build the arg2se from second arg. */
9046 gfc_init_se (&arg2se, NULL);
9047 gfc_conv_expr (&arg2se, arg->next->expr);
9048 gfc_add_block_to_block (&se->pre, &arg2se.pre);
9049 gfc_add_block_to_block (&se->post, &arg2se.post);
9050
9051 /* Generate test to compare that the two args are equal. */
9052 eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9053 arg1se.expr, arg2se.expr);
9054 /* Generate test to ensure that the first arg is not null. */
9055 not_null_expr = fold_build2_loc (input_location, NE_EXPR,
9056 logical_type_node,
9057 arg1se.expr, null_pointer_node);
9058
9059 /* Finally, the generated test must check that both arg1 is not
9060 NULL and that it is equal to the second arg. */
9061 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9062 logical_type_node,
9063 not_null_expr, eq_expr);
9064 }
9065 }
9066 else
9067 gcc_unreachable ();
9068 }
9069
9070
9071 /* The following routine generates code for the intrinsic
9072 subroutines from the ISO_C_BINDING module:
9073 * C_F_POINTER
9074 * C_F_PROCPOINTER. */
9075
9076 static tree
conv_isocbinding_subroutine(gfc_code * code)9077 conv_isocbinding_subroutine (gfc_code *code)
9078 {
9079 gfc_se se;
9080 gfc_se cptrse;
9081 gfc_se fptrse;
9082 gfc_se shapese;
9083 gfc_ss *shape_ss;
9084 tree desc, dim, tmp, stride, offset;
9085 stmtblock_t body, block;
9086 gfc_loopinfo loop;
9087 gfc_actual_arglist *arg = code->ext.actual;
9088
9089 gfc_init_se (&se, NULL);
9090 gfc_init_se (&cptrse, NULL);
9091 gfc_conv_expr (&cptrse, arg->expr);
9092 gfc_add_block_to_block (&se.pre, &cptrse.pre);
9093 gfc_add_block_to_block (&se.post, &cptrse.post);
9094
9095 gfc_init_se (&fptrse, NULL);
9096 if (arg->next->expr->rank == 0)
9097 {
9098 fptrse.want_pointer = 1;
9099 gfc_conv_expr (&fptrse, arg->next->expr);
9100 gfc_add_block_to_block (&se.pre, &fptrse.pre);
9101 gfc_add_block_to_block (&se.post, &fptrse.post);
9102 if (arg->next->expr->symtree->n.sym->attr.proc_pointer
9103 && arg->next->expr->symtree->n.sym->attr.dummy)
9104 fptrse.expr = build_fold_indirect_ref_loc (input_location,
9105 fptrse.expr);
9106 se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
9107 TREE_TYPE (fptrse.expr),
9108 fptrse.expr,
9109 fold_convert (TREE_TYPE (fptrse.expr),
9110 cptrse.expr));
9111 gfc_add_expr_to_block (&se.pre, se.expr);
9112 gfc_add_block_to_block (&se.pre, &se.post);
9113 return gfc_finish_block (&se.pre);
9114 }
9115
9116 gfc_start_block (&block);
9117
9118 /* Get the descriptor of the Fortran pointer. */
9119 fptrse.descriptor_only = 1;
9120 gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
9121 gfc_add_block_to_block (&block, &fptrse.pre);
9122 desc = fptrse.expr;
9123
9124 /* Set the span field. */
9125 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
9126 tmp = fold_convert (gfc_array_index_type, tmp);
9127 gfc_conv_descriptor_span_set (&block, desc, tmp);
9128
9129 /* Set data value, dtype, and offset. */
9130 tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
9131 gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
9132 gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
9133 gfc_get_dtype (TREE_TYPE (desc)));
9134
9135 /* Start scalarization of the bounds, using the shape argument. */
9136
9137 shape_ss = gfc_walk_expr (arg->next->next->expr);
9138 gcc_assert (shape_ss != gfc_ss_terminator);
9139 gfc_init_se (&shapese, NULL);
9140
9141 gfc_init_loopinfo (&loop);
9142 gfc_add_ss_to_loop (&loop, shape_ss);
9143 gfc_conv_ss_startstride (&loop);
9144 gfc_conv_loop_setup (&loop, &arg->next->expr->where);
9145 gfc_mark_ss_chain_used (shape_ss, 1);
9146
9147 gfc_copy_loopinfo_to_se (&shapese, &loop);
9148 shapese.ss = shape_ss;
9149
9150 stride = gfc_create_var (gfc_array_index_type, "stride");
9151 offset = gfc_create_var (gfc_array_index_type, "offset");
9152 gfc_add_modify (&block, stride, gfc_index_one_node);
9153 gfc_add_modify (&block, offset, gfc_index_zero_node);
9154
9155 /* Loop body. */
9156 gfc_start_scalarized_body (&loop, &body);
9157
9158 dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9159 loop.loopvar[0], loop.from[0]);
9160
9161 /* Set bounds and stride. */
9162 gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
9163 gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
9164
9165 gfc_conv_expr (&shapese, arg->next->next->expr);
9166 gfc_add_block_to_block (&body, &shapese.pre);
9167 gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
9168 gfc_add_block_to_block (&body, &shapese.post);
9169
9170 /* Calculate offset. */
9171 gfc_add_modify (&body, offset,
9172 fold_build2_loc (input_location, PLUS_EXPR,
9173 gfc_array_index_type, offset, stride));
9174 /* Update stride. */
9175 gfc_add_modify (&body, stride,
9176 fold_build2_loc (input_location, MULT_EXPR,
9177 gfc_array_index_type, stride,
9178 fold_convert (gfc_array_index_type,
9179 shapese.expr)));
9180 /* Finish scalarization loop. */
9181 gfc_trans_scalarizing_loops (&loop, &body);
9182 gfc_add_block_to_block (&block, &loop.pre);
9183 gfc_add_block_to_block (&block, &loop.post);
9184 gfc_add_block_to_block (&block, &fptrse.post);
9185 gfc_cleanup_loop (&loop);
9186
9187 gfc_add_modify (&block, offset,
9188 fold_build1_loc (input_location, NEGATE_EXPR,
9189 gfc_array_index_type, offset));
9190 gfc_conv_descriptor_offset_set (&block, desc, offset);
9191
9192 gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
9193 gfc_add_block_to_block (&se.pre, &se.post);
9194 return gfc_finish_block (&se.pre);
9195 }
9196
9197
9198 /* Save and restore floating-point state. */
9199
9200 tree
gfc_save_fp_state(stmtblock_t * block)9201 gfc_save_fp_state (stmtblock_t *block)
9202 {
9203 tree type, fpstate, tmp;
9204
9205 type = build_array_type (char_type_node,
9206 build_range_type (size_type_node, size_zero_node,
9207 size_int (GFC_FPE_STATE_BUFFER_SIZE)));
9208 fpstate = gfc_create_var (type, "fpstate");
9209 fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
9210
9211 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
9212 1, fpstate);
9213 gfc_add_expr_to_block (block, tmp);
9214
9215 return fpstate;
9216 }
9217
9218
9219 void
gfc_restore_fp_state(stmtblock_t * block,tree fpstate)9220 gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
9221 {
9222 tree tmp;
9223
9224 tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
9225 1, fpstate);
9226 gfc_add_expr_to_block (block, tmp);
9227 }
9228
9229
9230 /* Generate code for arguments of IEEE functions. */
9231
9232 static void
conv_ieee_function_args(gfc_se * se,gfc_expr * expr,tree * argarray,int nargs)9233 conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
9234 int nargs)
9235 {
9236 gfc_actual_arglist *actual;
9237 gfc_expr *e;
9238 gfc_se argse;
9239 int arg;
9240
9241 actual = expr->value.function.actual;
9242 for (arg = 0; arg < nargs; arg++, actual = actual->next)
9243 {
9244 gcc_assert (actual);
9245 e = actual->expr;
9246
9247 gfc_init_se (&argse, se);
9248 gfc_conv_expr_val (&argse, e);
9249
9250 gfc_add_block_to_block (&se->pre, &argse.pre);
9251 gfc_add_block_to_block (&se->post, &argse.post);
9252 argarray[arg] = argse.expr;
9253 }
9254 }
9255
9256
9257 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
9258 and IEEE_UNORDERED, which translate directly to GCC type-generic
9259 built-ins. */
9260
9261 static void
conv_intrinsic_ieee_builtin(gfc_se * se,gfc_expr * expr,enum built_in_function code,int nargs)9262 conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
9263 enum built_in_function code, int nargs)
9264 {
9265 tree args[2];
9266 gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0]));
9267
9268 conv_ieee_function_args (se, expr, args, nargs);
9269 se->expr = build_call_expr_loc_array (input_location,
9270 builtin_decl_explicit (code),
9271 nargs, args);
9272 STRIP_TYPE_NOPS (se->expr);
9273 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9274 }
9275
9276
9277 /* Generate code for IEEE_IS_NORMAL intrinsic:
9278 IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */
9279
9280 static void
conv_intrinsic_ieee_is_normal(gfc_se * se,gfc_expr * expr)9281 conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
9282 {
9283 tree arg, isnormal, iszero;
9284
9285 /* Convert arg, evaluate it only once. */
9286 conv_ieee_function_args (se, expr, &arg, 1);
9287 arg = gfc_evaluate_now (arg, &se->pre);
9288
9289 isnormal = build_call_expr_loc (input_location,
9290 builtin_decl_explicit (BUILT_IN_ISNORMAL),
9291 1, arg);
9292 iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg,
9293 build_real_from_int_cst (TREE_TYPE (arg),
9294 integer_zero_node));
9295 se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9296 logical_type_node, isnormal, iszero);
9297 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9298 }
9299
9300
9301 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
9302 IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */
9303
9304 static void
conv_intrinsic_ieee_is_negative(gfc_se * se,gfc_expr * expr)9305 conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
9306 {
9307 tree arg, signbit, isnan;
9308
9309 /* Convert arg, evaluate it only once. */
9310 conv_ieee_function_args (se, expr, &arg, 1);
9311 arg = gfc_evaluate_now (arg, &se->pre);
9312
9313 isnan = build_call_expr_loc (input_location,
9314 builtin_decl_explicit (BUILT_IN_ISNAN),
9315 1, arg);
9316 STRIP_TYPE_NOPS (isnan);
9317
9318 signbit = build_call_expr_loc (input_location,
9319 builtin_decl_explicit (BUILT_IN_SIGNBIT),
9320 1, arg);
9321 signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9322 signbit, integer_zero_node);
9323
9324 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
9325 logical_type_node, signbit,
9326 fold_build1_loc (input_location, TRUTH_NOT_EXPR,
9327 TREE_TYPE(isnan), isnan));
9328
9329 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
9330 }
9331
9332
9333 /* Generate code for IEEE_LOGB and IEEE_RINT. */
9334
9335 static void
conv_intrinsic_ieee_logb_rint(gfc_se * se,gfc_expr * expr,enum built_in_function code)9336 conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
9337 enum built_in_function code)
9338 {
9339 tree arg, decl, call, fpstate;
9340 int argprec;
9341
9342 conv_ieee_function_args (se, expr, &arg, 1);
9343 argprec = TYPE_PRECISION (TREE_TYPE (arg));
9344 decl = builtin_decl_for_precision (code, argprec);
9345
9346 /* Save floating-point state. */
9347 fpstate = gfc_save_fp_state (&se->pre);
9348
9349 /* Make the function call. */
9350 call = build_call_expr_loc (input_location, decl, 1, arg);
9351 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
9352
9353 /* Restore floating-point state. */
9354 gfc_restore_fp_state (&se->post, fpstate);
9355 }
9356
9357
9358 /* Generate code for IEEE_REM. */
9359
9360 static void
conv_intrinsic_ieee_rem(gfc_se * se,gfc_expr * expr)9361 conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
9362 {
9363 tree args[2], decl, call, fpstate;
9364 int argprec;
9365
9366 conv_ieee_function_args (se, expr, args, 2);
9367
9368 /* If arguments have unequal size, convert them to the larger. */
9369 if (TYPE_PRECISION (TREE_TYPE (args[0]))
9370 > TYPE_PRECISION (TREE_TYPE (args[1])))
9371 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
9372 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
9373 > TYPE_PRECISION (TREE_TYPE (args[0])))
9374 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
9375
9376 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9377 decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
9378
9379 /* Save floating-point state. */
9380 fpstate = gfc_save_fp_state (&se->pre);
9381
9382 /* Make the function call. */
9383 call = build_call_expr_loc_array (input_location, decl, 2, args);
9384 se->expr = fold_convert (TREE_TYPE (args[0]), call);
9385
9386 /* Restore floating-point state. */
9387 gfc_restore_fp_state (&se->post, fpstate);
9388 }
9389
9390
9391 /* Generate code for IEEE_NEXT_AFTER. */
9392
9393 static void
conv_intrinsic_ieee_next_after(gfc_se * se,gfc_expr * expr)9394 conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
9395 {
9396 tree args[2], decl, call, fpstate;
9397 int argprec;
9398
9399 conv_ieee_function_args (se, expr, args, 2);
9400
9401 /* Result has the characteristics of first argument. */
9402 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
9403 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9404 decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
9405
9406 /* Save floating-point state. */
9407 fpstate = gfc_save_fp_state (&se->pre);
9408
9409 /* Make the function call. */
9410 call = build_call_expr_loc_array (input_location, decl, 2, args);
9411 se->expr = fold_convert (TREE_TYPE (args[0]), call);
9412
9413 /* Restore floating-point state. */
9414 gfc_restore_fp_state (&se->post, fpstate);
9415 }
9416
9417
9418 /* Generate code for IEEE_SCALB. */
9419
9420 static void
conv_intrinsic_ieee_scalb(gfc_se * se,gfc_expr * expr)9421 conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
9422 {
9423 tree args[2], decl, call, huge, type;
9424 int argprec, n;
9425
9426 conv_ieee_function_args (se, expr, args, 2);
9427
9428 /* Result has the characteristics of first argument. */
9429 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9430 decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
9431
9432 if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
9433 {
9434 /* We need to fold the integer into the range of a C int. */
9435 args[1] = gfc_evaluate_now (args[1], &se->pre);
9436 type = TREE_TYPE (args[1]);
9437
9438 n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
9439 huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
9440 gfc_c_int_kind);
9441 huge = fold_convert (type, huge);
9442 args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
9443 huge);
9444 args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
9445 fold_build1_loc (input_location, NEGATE_EXPR,
9446 type, huge));
9447 }
9448
9449 args[1] = fold_convert (integer_type_node, args[1]);
9450
9451 /* Make the function call. */
9452 call = build_call_expr_loc_array (input_location, decl, 2, args);
9453 se->expr = fold_convert (TREE_TYPE (args[0]), call);
9454 }
9455
9456
9457 /* Generate code for IEEE_COPY_SIGN. */
9458
9459 static void
conv_intrinsic_ieee_copy_sign(gfc_se * se,gfc_expr * expr)9460 conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
9461 {
9462 tree args[2], decl, sign;
9463 int argprec;
9464
9465 conv_ieee_function_args (se, expr, args, 2);
9466
9467 /* Get the sign of the second argument. */
9468 sign = build_call_expr_loc (input_location,
9469 builtin_decl_explicit (BUILT_IN_SIGNBIT),
9470 1, args[1]);
9471 sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9472 sign, integer_zero_node);
9473
9474 /* Create a value of one, with the right sign. */
9475 sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
9476 sign,
9477 fold_build1_loc (input_location, NEGATE_EXPR,
9478 integer_type_node,
9479 integer_one_node),
9480 integer_one_node);
9481 args[1] = fold_convert (TREE_TYPE (args[0]), sign);
9482
9483 argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
9484 decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
9485
9486 se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
9487 }
9488
9489
9490 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
9491 module. */
9492
9493 bool
gfc_conv_ieee_arithmetic_function(gfc_se * se,gfc_expr * expr)9494 gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
9495 {
9496 const char *name = expr->value.function.name;
9497
9498 if (gfc_str_startswith (name, "_gfortran_ieee_is_nan"))
9499 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
9500 else if (gfc_str_startswith (name, "_gfortran_ieee_is_finite"))
9501 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
9502 else if (gfc_str_startswith (name, "_gfortran_ieee_unordered"))
9503 conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
9504 else if (gfc_str_startswith (name, "_gfortran_ieee_is_normal"))
9505 conv_intrinsic_ieee_is_normal (se, expr);
9506 else if (gfc_str_startswith (name, "_gfortran_ieee_is_negative"))
9507 conv_intrinsic_ieee_is_negative (se, expr);
9508 else if (gfc_str_startswith (name, "_gfortran_ieee_copy_sign"))
9509 conv_intrinsic_ieee_copy_sign (se, expr);
9510 else if (gfc_str_startswith (name, "_gfortran_ieee_scalb"))
9511 conv_intrinsic_ieee_scalb (se, expr);
9512 else if (gfc_str_startswith (name, "_gfortran_ieee_next_after"))
9513 conv_intrinsic_ieee_next_after (se, expr);
9514 else if (gfc_str_startswith (name, "_gfortran_ieee_rem"))
9515 conv_intrinsic_ieee_rem (se, expr);
9516 else if (gfc_str_startswith (name, "_gfortran_ieee_logb"))
9517 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
9518 else if (gfc_str_startswith (name, "_gfortran_ieee_rint"))
9519 conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
9520 else
9521 /* It is not among the functions we translate directly. We return
9522 false, so a library function call is emitted. */
9523 return false;
9524
9525 return true;
9526 }
9527
9528
9529 /* Generate a direct call to malloc() for the MALLOC intrinsic. */
9530
9531 static void
gfc_conv_intrinsic_malloc(gfc_se * se,gfc_expr * expr)9532 gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
9533 {
9534 tree arg, res, restype;
9535
9536 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
9537 arg = fold_convert (size_type_node, arg);
9538 res = build_call_expr_loc (input_location,
9539 builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
9540 restype = gfc_typenode_for_spec (&expr->ts);
9541 se->expr = fold_convert (restype, res);
9542 }
9543
9544
9545 /* Generate code for an intrinsic function. Some map directly to library
9546 calls, others get special handling. In some cases the name of the function
9547 used depends on the type specifiers. */
9548
9549 void
gfc_conv_intrinsic_function(gfc_se * se,gfc_expr * expr)9550 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
9551 {
9552 const char *name;
9553 int lib, kind;
9554 tree fndecl;
9555
9556 name = &expr->value.function.name[2];
9557
9558 if (expr->rank > 0)
9559 {
9560 lib = gfc_is_intrinsic_libcall (expr);
9561 if (lib != 0)
9562 {
9563 if (lib == 1)
9564 se->ignore_optional = 1;
9565
9566 switch (expr->value.function.isym->id)
9567 {
9568 case GFC_ISYM_EOSHIFT:
9569 case GFC_ISYM_PACK:
9570 case GFC_ISYM_RESHAPE:
9571 /* For all of those the first argument specifies the type and the
9572 third is optional. */
9573 conv_generic_with_optional_char_arg (se, expr, 1, 3);
9574 break;
9575
9576 case GFC_ISYM_FINDLOC:
9577 gfc_conv_intrinsic_findloc (se, expr);
9578 break;
9579
9580 case GFC_ISYM_MINLOC:
9581 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
9582 break;
9583
9584 case GFC_ISYM_MAXLOC:
9585 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
9586 break;
9587
9588 case GFC_ISYM_SHAPE:
9589 gfc_conv_intrinsic_shape (se, expr);
9590 break;
9591
9592 default:
9593 gfc_conv_intrinsic_funcall (se, expr);
9594 break;
9595 }
9596
9597 return;
9598 }
9599 }
9600
9601 switch (expr->value.function.isym->id)
9602 {
9603 case GFC_ISYM_NONE:
9604 gcc_unreachable ();
9605
9606 case GFC_ISYM_REPEAT:
9607 gfc_conv_intrinsic_repeat (se, expr);
9608 break;
9609
9610 case GFC_ISYM_TRIM:
9611 gfc_conv_intrinsic_trim (se, expr);
9612 break;
9613
9614 case GFC_ISYM_SC_KIND:
9615 gfc_conv_intrinsic_sc_kind (se, expr);
9616 break;
9617
9618 case GFC_ISYM_SI_KIND:
9619 gfc_conv_intrinsic_si_kind (se, expr);
9620 break;
9621
9622 case GFC_ISYM_SR_KIND:
9623 gfc_conv_intrinsic_sr_kind (se, expr);
9624 break;
9625
9626 case GFC_ISYM_EXPONENT:
9627 gfc_conv_intrinsic_exponent (se, expr);
9628 break;
9629
9630 case GFC_ISYM_SCAN:
9631 kind = expr->value.function.actual->expr->ts.kind;
9632 if (kind == 1)
9633 fndecl = gfor_fndecl_string_scan;
9634 else if (kind == 4)
9635 fndecl = gfor_fndecl_string_scan_char4;
9636 else
9637 gcc_unreachable ();
9638
9639 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
9640 break;
9641
9642 case GFC_ISYM_VERIFY:
9643 kind = expr->value.function.actual->expr->ts.kind;
9644 if (kind == 1)
9645 fndecl = gfor_fndecl_string_verify;
9646 else if (kind == 4)
9647 fndecl = gfor_fndecl_string_verify_char4;
9648 else
9649 gcc_unreachable ();
9650
9651 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
9652 break;
9653
9654 case GFC_ISYM_ALLOCATED:
9655 gfc_conv_allocated (se, expr);
9656 break;
9657
9658 case GFC_ISYM_ASSOCIATED:
9659 gfc_conv_associated(se, expr);
9660 break;
9661
9662 case GFC_ISYM_SAME_TYPE_AS:
9663 gfc_conv_same_type_as (se, expr);
9664 break;
9665
9666 case GFC_ISYM_ABS:
9667 gfc_conv_intrinsic_abs (se, expr);
9668 break;
9669
9670 case GFC_ISYM_ADJUSTL:
9671 if (expr->ts.kind == 1)
9672 fndecl = gfor_fndecl_adjustl;
9673 else if (expr->ts.kind == 4)
9674 fndecl = gfor_fndecl_adjustl_char4;
9675 else
9676 gcc_unreachable ();
9677
9678 gfc_conv_intrinsic_adjust (se, expr, fndecl);
9679 break;
9680
9681 case GFC_ISYM_ADJUSTR:
9682 if (expr->ts.kind == 1)
9683 fndecl = gfor_fndecl_adjustr;
9684 else if (expr->ts.kind == 4)
9685 fndecl = gfor_fndecl_adjustr_char4;
9686 else
9687 gcc_unreachable ();
9688
9689 gfc_conv_intrinsic_adjust (se, expr, fndecl);
9690 break;
9691
9692 case GFC_ISYM_AIMAG:
9693 gfc_conv_intrinsic_imagpart (se, expr);
9694 break;
9695
9696 case GFC_ISYM_AINT:
9697 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
9698 break;
9699
9700 case GFC_ISYM_ALL:
9701 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
9702 break;
9703
9704 case GFC_ISYM_ANINT:
9705 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
9706 break;
9707
9708 case GFC_ISYM_AND:
9709 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
9710 break;
9711
9712 case GFC_ISYM_ANY:
9713 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
9714 break;
9715
9716 case GFC_ISYM_BTEST:
9717 gfc_conv_intrinsic_btest (se, expr);
9718 break;
9719
9720 case GFC_ISYM_BGE:
9721 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
9722 break;
9723
9724 case GFC_ISYM_BGT:
9725 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
9726 break;
9727
9728 case GFC_ISYM_BLE:
9729 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
9730 break;
9731
9732 case GFC_ISYM_BLT:
9733 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
9734 break;
9735
9736 case GFC_ISYM_C_ASSOCIATED:
9737 case GFC_ISYM_C_FUNLOC:
9738 case GFC_ISYM_C_LOC:
9739 conv_isocbinding_function (se, expr);
9740 break;
9741
9742 case GFC_ISYM_ACHAR:
9743 case GFC_ISYM_CHAR:
9744 gfc_conv_intrinsic_char (se, expr);
9745 break;
9746
9747 case GFC_ISYM_CONVERSION:
9748 case GFC_ISYM_REAL:
9749 case GFC_ISYM_LOGICAL:
9750 case GFC_ISYM_DBLE:
9751 gfc_conv_intrinsic_conversion (se, expr);
9752 break;
9753
9754 /* Integer conversions are handled separately to make sure we get the
9755 correct rounding mode. */
9756 case GFC_ISYM_INT:
9757 case GFC_ISYM_INT2:
9758 case GFC_ISYM_INT8:
9759 case GFC_ISYM_LONG:
9760 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
9761 break;
9762
9763 case GFC_ISYM_NINT:
9764 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
9765 break;
9766
9767 case GFC_ISYM_CEILING:
9768 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
9769 break;
9770
9771 case GFC_ISYM_FLOOR:
9772 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
9773 break;
9774
9775 case GFC_ISYM_MOD:
9776 gfc_conv_intrinsic_mod (se, expr, 0);
9777 break;
9778
9779 case GFC_ISYM_MODULO:
9780 gfc_conv_intrinsic_mod (se, expr, 1);
9781 break;
9782
9783 case GFC_ISYM_CAF_GET:
9784 gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE,
9785 false, NULL);
9786 break;
9787
9788 case GFC_ISYM_CMPLX:
9789 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
9790 break;
9791
9792 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
9793 gfc_conv_intrinsic_iargc (se, expr);
9794 break;
9795
9796 case GFC_ISYM_COMPLEX:
9797 gfc_conv_intrinsic_cmplx (se, expr, 1);
9798 break;
9799
9800 case GFC_ISYM_CONJG:
9801 gfc_conv_intrinsic_conjg (se, expr);
9802 break;
9803
9804 case GFC_ISYM_COUNT:
9805 gfc_conv_intrinsic_count (se, expr);
9806 break;
9807
9808 case GFC_ISYM_CTIME:
9809 gfc_conv_intrinsic_ctime (se, expr);
9810 break;
9811
9812 case GFC_ISYM_DIM:
9813 gfc_conv_intrinsic_dim (se, expr);
9814 break;
9815
9816 case GFC_ISYM_DOT_PRODUCT:
9817 gfc_conv_intrinsic_dot_product (se, expr);
9818 break;
9819
9820 case GFC_ISYM_DPROD:
9821 gfc_conv_intrinsic_dprod (se, expr);
9822 break;
9823
9824 case GFC_ISYM_DSHIFTL:
9825 gfc_conv_intrinsic_dshift (se, expr, true);
9826 break;
9827
9828 case GFC_ISYM_DSHIFTR:
9829 gfc_conv_intrinsic_dshift (se, expr, false);
9830 break;
9831
9832 case GFC_ISYM_FDATE:
9833 gfc_conv_intrinsic_fdate (se, expr);
9834 break;
9835
9836 case GFC_ISYM_FRACTION:
9837 gfc_conv_intrinsic_fraction (se, expr);
9838 break;
9839
9840 case GFC_ISYM_IALL:
9841 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
9842 break;
9843
9844 case GFC_ISYM_IAND:
9845 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
9846 break;
9847
9848 case GFC_ISYM_IANY:
9849 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
9850 break;
9851
9852 case GFC_ISYM_IBCLR:
9853 gfc_conv_intrinsic_singlebitop (se, expr, 0);
9854 break;
9855
9856 case GFC_ISYM_IBITS:
9857 gfc_conv_intrinsic_ibits (se, expr);
9858 break;
9859
9860 case GFC_ISYM_IBSET:
9861 gfc_conv_intrinsic_singlebitop (se, expr, 1);
9862 break;
9863
9864 case GFC_ISYM_IACHAR:
9865 case GFC_ISYM_ICHAR:
9866 /* We assume ASCII character sequence. */
9867 gfc_conv_intrinsic_ichar (se, expr);
9868 break;
9869
9870 case GFC_ISYM_IARGC:
9871 gfc_conv_intrinsic_iargc (se, expr);
9872 break;
9873
9874 case GFC_ISYM_IEOR:
9875 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
9876 break;
9877
9878 case GFC_ISYM_INDEX:
9879 kind = expr->value.function.actual->expr->ts.kind;
9880 if (kind == 1)
9881 fndecl = gfor_fndecl_string_index;
9882 else if (kind == 4)
9883 fndecl = gfor_fndecl_string_index_char4;
9884 else
9885 gcc_unreachable ();
9886
9887 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
9888 break;
9889
9890 case GFC_ISYM_IOR:
9891 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
9892 break;
9893
9894 case GFC_ISYM_IPARITY:
9895 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
9896 break;
9897
9898 case GFC_ISYM_IS_IOSTAT_END:
9899 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
9900 break;
9901
9902 case GFC_ISYM_IS_IOSTAT_EOR:
9903 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
9904 break;
9905
9906 case GFC_ISYM_IS_CONTIGUOUS:
9907 gfc_conv_intrinsic_is_contiguous (se, expr);
9908 break;
9909
9910 case GFC_ISYM_ISNAN:
9911 gfc_conv_intrinsic_isnan (se, expr);
9912 break;
9913
9914 case GFC_ISYM_KILL:
9915 conv_intrinsic_kill (se, expr);
9916 break;
9917
9918 case GFC_ISYM_LSHIFT:
9919 gfc_conv_intrinsic_shift (se, expr, false, false);
9920 break;
9921
9922 case GFC_ISYM_RSHIFT:
9923 gfc_conv_intrinsic_shift (se, expr, true, true);
9924 break;
9925
9926 case GFC_ISYM_SHIFTA:
9927 gfc_conv_intrinsic_shift (se, expr, true, true);
9928 break;
9929
9930 case GFC_ISYM_SHIFTL:
9931 gfc_conv_intrinsic_shift (se, expr, false, false);
9932 break;
9933
9934 case GFC_ISYM_SHIFTR:
9935 gfc_conv_intrinsic_shift (se, expr, true, false);
9936 break;
9937
9938 case GFC_ISYM_ISHFT:
9939 gfc_conv_intrinsic_ishft (se, expr);
9940 break;
9941
9942 case GFC_ISYM_ISHFTC:
9943 gfc_conv_intrinsic_ishftc (se, expr);
9944 break;
9945
9946 case GFC_ISYM_LEADZ:
9947 gfc_conv_intrinsic_leadz (se, expr);
9948 break;
9949
9950 case GFC_ISYM_TRAILZ:
9951 gfc_conv_intrinsic_trailz (se, expr);
9952 break;
9953
9954 case GFC_ISYM_POPCNT:
9955 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
9956 break;
9957
9958 case GFC_ISYM_POPPAR:
9959 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
9960 break;
9961
9962 case GFC_ISYM_LBOUND:
9963 gfc_conv_intrinsic_bound (se, expr, 0);
9964 break;
9965
9966 case GFC_ISYM_LCOBOUND:
9967 conv_intrinsic_cobound (se, expr);
9968 break;
9969
9970 case GFC_ISYM_TRANSPOSE:
9971 /* The scalarizer has already been set up for reversed dimension access
9972 order ; now we just get the argument value normally. */
9973 gfc_conv_expr (se, expr->value.function.actual->expr);
9974 break;
9975
9976 case GFC_ISYM_LEN:
9977 gfc_conv_intrinsic_len (se, expr);
9978 break;
9979
9980 case GFC_ISYM_LEN_TRIM:
9981 gfc_conv_intrinsic_len_trim (se, expr);
9982 break;
9983
9984 case GFC_ISYM_LGE:
9985 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
9986 break;
9987
9988 case GFC_ISYM_LGT:
9989 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
9990 break;
9991
9992 case GFC_ISYM_LLE:
9993 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
9994 break;
9995
9996 case GFC_ISYM_LLT:
9997 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
9998 break;
9999
10000 case GFC_ISYM_MALLOC:
10001 gfc_conv_intrinsic_malloc (se, expr);
10002 break;
10003
10004 case GFC_ISYM_MASKL:
10005 gfc_conv_intrinsic_mask (se, expr, 1);
10006 break;
10007
10008 case GFC_ISYM_MASKR:
10009 gfc_conv_intrinsic_mask (se, expr, 0);
10010 break;
10011
10012 case GFC_ISYM_MAX:
10013 if (expr->ts.type == BT_CHARACTER)
10014 gfc_conv_intrinsic_minmax_char (se, expr, 1);
10015 else
10016 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
10017 break;
10018
10019 case GFC_ISYM_MAXLOC:
10020 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
10021 break;
10022
10023 case GFC_ISYM_FINDLOC:
10024 gfc_conv_intrinsic_findloc (se, expr);
10025 break;
10026
10027 case GFC_ISYM_MAXVAL:
10028 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
10029 break;
10030
10031 case GFC_ISYM_MERGE:
10032 gfc_conv_intrinsic_merge (se, expr);
10033 break;
10034
10035 case GFC_ISYM_MERGE_BITS:
10036 gfc_conv_intrinsic_merge_bits (se, expr);
10037 break;
10038
10039 case GFC_ISYM_MIN:
10040 if (expr->ts.type == BT_CHARACTER)
10041 gfc_conv_intrinsic_minmax_char (se, expr, -1);
10042 else
10043 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
10044 break;
10045
10046 case GFC_ISYM_MINLOC:
10047 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
10048 break;
10049
10050 case GFC_ISYM_MINVAL:
10051 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
10052 break;
10053
10054 case GFC_ISYM_NEAREST:
10055 gfc_conv_intrinsic_nearest (se, expr);
10056 break;
10057
10058 case GFC_ISYM_NORM2:
10059 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
10060 break;
10061
10062 case GFC_ISYM_NOT:
10063 gfc_conv_intrinsic_not (se, expr);
10064 break;
10065
10066 case GFC_ISYM_OR:
10067 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
10068 break;
10069
10070 case GFC_ISYM_PARITY:
10071 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
10072 break;
10073
10074 case GFC_ISYM_PRESENT:
10075 gfc_conv_intrinsic_present (se, expr);
10076 break;
10077
10078 case GFC_ISYM_PRODUCT:
10079 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
10080 break;
10081
10082 case GFC_ISYM_RANK:
10083 gfc_conv_intrinsic_rank (se, expr);
10084 break;
10085
10086 case GFC_ISYM_RRSPACING:
10087 gfc_conv_intrinsic_rrspacing (se, expr);
10088 break;
10089
10090 case GFC_ISYM_SET_EXPONENT:
10091 gfc_conv_intrinsic_set_exponent (se, expr);
10092 break;
10093
10094 case GFC_ISYM_SCALE:
10095 gfc_conv_intrinsic_scale (se, expr);
10096 break;
10097
10098 case GFC_ISYM_SIGN:
10099 gfc_conv_intrinsic_sign (se, expr);
10100 break;
10101
10102 case GFC_ISYM_SIZE:
10103 gfc_conv_intrinsic_size (se, expr);
10104 break;
10105
10106 case GFC_ISYM_SIZEOF:
10107 case GFC_ISYM_C_SIZEOF:
10108 gfc_conv_intrinsic_sizeof (se, expr);
10109 break;
10110
10111 case GFC_ISYM_STORAGE_SIZE:
10112 gfc_conv_intrinsic_storage_size (se, expr);
10113 break;
10114
10115 case GFC_ISYM_SPACING:
10116 gfc_conv_intrinsic_spacing (se, expr);
10117 break;
10118
10119 case GFC_ISYM_STRIDE:
10120 conv_intrinsic_stride (se, expr);
10121 break;
10122
10123 case GFC_ISYM_SUM:
10124 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
10125 break;
10126
10127 case GFC_ISYM_TEAM_NUMBER:
10128 conv_intrinsic_team_number (se, expr);
10129 break;
10130
10131 case GFC_ISYM_TRANSFER:
10132 if (se->ss && se->ss->info->useflags)
10133 /* Access the previously obtained result. */
10134 gfc_conv_tmp_array_ref (se);
10135 else
10136 gfc_conv_intrinsic_transfer (se, expr);
10137 break;
10138
10139 case GFC_ISYM_TTYNAM:
10140 gfc_conv_intrinsic_ttynam (se, expr);
10141 break;
10142
10143 case GFC_ISYM_UBOUND:
10144 gfc_conv_intrinsic_bound (se, expr, 1);
10145 break;
10146
10147 case GFC_ISYM_UCOBOUND:
10148 conv_intrinsic_cobound (se, expr);
10149 break;
10150
10151 case GFC_ISYM_XOR:
10152 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
10153 break;
10154
10155 case GFC_ISYM_LOC:
10156 gfc_conv_intrinsic_loc (se, expr);
10157 break;
10158
10159 case GFC_ISYM_THIS_IMAGE:
10160 /* For num_images() == 1, handle as LCOBOUND. */
10161 if (expr->value.function.actual->expr
10162 && flag_coarray == GFC_FCOARRAY_SINGLE)
10163 conv_intrinsic_cobound (se, expr);
10164 else
10165 trans_this_image (se, expr);
10166 break;
10167
10168 case GFC_ISYM_IMAGE_INDEX:
10169 trans_image_index (se, expr);
10170 break;
10171
10172 case GFC_ISYM_IMAGE_STATUS:
10173 conv_intrinsic_image_status (se, expr);
10174 break;
10175
10176 case GFC_ISYM_NUM_IMAGES:
10177 trans_num_images (se, expr);
10178 break;
10179
10180 case GFC_ISYM_ACCESS:
10181 case GFC_ISYM_CHDIR:
10182 case GFC_ISYM_CHMOD:
10183 case GFC_ISYM_DTIME:
10184 case GFC_ISYM_ETIME:
10185 case GFC_ISYM_EXTENDS_TYPE_OF:
10186 case GFC_ISYM_FGET:
10187 case GFC_ISYM_FGETC:
10188 case GFC_ISYM_FNUM:
10189 case GFC_ISYM_FPUT:
10190 case GFC_ISYM_FPUTC:
10191 case GFC_ISYM_FSTAT:
10192 case GFC_ISYM_FTELL:
10193 case GFC_ISYM_GETCWD:
10194 case GFC_ISYM_GETGID:
10195 case GFC_ISYM_GETPID:
10196 case GFC_ISYM_GETUID:
10197 case GFC_ISYM_HOSTNM:
10198 case GFC_ISYM_IERRNO:
10199 case GFC_ISYM_IRAND:
10200 case GFC_ISYM_ISATTY:
10201 case GFC_ISYM_JN2:
10202 case GFC_ISYM_LINK:
10203 case GFC_ISYM_LSTAT:
10204 case GFC_ISYM_MATMUL:
10205 case GFC_ISYM_MCLOCK:
10206 case GFC_ISYM_MCLOCK8:
10207 case GFC_ISYM_RAND:
10208 case GFC_ISYM_RENAME:
10209 case GFC_ISYM_SECOND:
10210 case GFC_ISYM_SECNDS:
10211 case GFC_ISYM_SIGNAL:
10212 case GFC_ISYM_STAT:
10213 case GFC_ISYM_SYMLNK:
10214 case GFC_ISYM_SYSTEM:
10215 case GFC_ISYM_TIME:
10216 case GFC_ISYM_TIME8:
10217 case GFC_ISYM_UMASK:
10218 case GFC_ISYM_UNLINK:
10219 case GFC_ISYM_YN2:
10220 gfc_conv_intrinsic_funcall (se, expr);
10221 break;
10222
10223 case GFC_ISYM_EOSHIFT:
10224 case GFC_ISYM_PACK:
10225 case GFC_ISYM_RESHAPE:
10226 /* For those, expr->rank should always be >0 and thus the if above the
10227 switch should have matched. */
10228 gcc_unreachable ();
10229 break;
10230
10231 default:
10232 gfc_conv_intrinsic_lib_function (se, expr);
10233 break;
10234 }
10235 }
10236
10237
10238 static gfc_ss *
walk_inline_intrinsic_transpose(gfc_ss * ss,gfc_expr * expr)10239 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
10240 {
10241 gfc_ss *arg_ss, *tmp_ss;
10242 gfc_actual_arglist *arg;
10243
10244 arg = expr->value.function.actual;
10245
10246 gcc_assert (arg->expr);
10247
10248 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
10249 gcc_assert (arg_ss != gfc_ss_terminator);
10250
10251 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
10252 {
10253 if (tmp_ss->info->type != GFC_SS_SCALAR
10254 && tmp_ss->info->type != GFC_SS_REFERENCE)
10255 {
10256 gcc_assert (tmp_ss->dimen == 2);
10257
10258 /* We just invert dimensions. */
10259 std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
10260 }
10261
10262 /* Stop when tmp_ss points to the last valid element of the chain... */
10263 if (tmp_ss->next == gfc_ss_terminator)
10264 break;
10265 }
10266
10267 /* ... so that we can attach the rest of the chain to it. */
10268 tmp_ss->next = ss;
10269
10270 return arg_ss;
10271 }
10272
10273
10274 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
10275 This has the side effect of reversing the nested list, so there is no
10276 need to call gfc_reverse_ss on it (the given list is assumed not to be
10277 reversed yet). */
10278
10279 static gfc_ss *
nest_loop_dimension(gfc_ss * ss,int dim)10280 nest_loop_dimension (gfc_ss *ss, int dim)
10281 {
10282 int ss_dim, i;
10283 gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
10284 gfc_loopinfo *new_loop;
10285
10286 gcc_assert (ss != gfc_ss_terminator);
10287
10288 for (; ss != gfc_ss_terminator; ss = ss->next)
10289 {
10290 new_ss = gfc_get_ss ();
10291 new_ss->next = prev_ss;
10292 new_ss->parent = ss;
10293 new_ss->info = ss->info;
10294 new_ss->info->refcount++;
10295 if (ss->dimen != 0)
10296 {
10297 gcc_assert (ss->info->type != GFC_SS_SCALAR
10298 && ss->info->type != GFC_SS_REFERENCE);
10299
10300 new_ss->dimen = 1;
10301 new_ss->dim[0] = ss->dim[dim];
10302
10303 gcc_assert (dim < ss->dimen);
10304
10305 ss_dim = --ss->dimen;
10306 for (i = dim; i < ss_dim; i++)
10307 ss->dim[i] = ss->dim[i + 1];
10308
10309 ss->dim[ss_dim] = 0;
10310 }
10311 prev_ss = new_ss;
10312
10313 if (ss->nested_ss)
10314 {
10315 ss->nested_ss->parent = new_ss;
10316 new_ss->nested_ss = ss->nested_ss;
10317 }
10318 ss->nested_ss = new_ss;
10319 }
10320
10321 new_loop = gfc_get_loopinfo ();
10322 gfc_init_loopinfo (new_loop);
10323
10324 gcc_assert (prev_ss != NULL);
10325 gcc_assert (prev_ss != gfc_ss_terminator);
10326 gfc_add_ss_to_loop (new_loop, prev_ss);
10327 return new_ss->parent;
10328 }
10329
10330
10331 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
10332 is to be inlined. */
10333
10334 static gfc_ss *
walk_inline_intrinsic_arith(gfc_ss * ss,gfc_expr * expr)10335 walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
10336 {
10337 gfc_ss *tmp_ss, *tail, *array_ss;
10338 gfc_actual_arglist *arg1, *arg2, *arg3;
10339 int sum_dim;
10340 bool scalar_mask = false;
10341
10342 /* The rank of the result will be determined later. */
10343 arg1 = expr->value.function.actual;
10344 arg2 = arg1->next;
10345 arg3 = arg2->next;
10346 gcc_assert (arg3 != NULL);
10347
10348 if (expr->rank == 0)
10349 return ss;
10350
10351 tmp_ss = gfc_ss_terminator;
10352
10353 if (arg3->expr)
10354 {
10355 gfc_ss *mask_ss;
10356
10357 mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
10358 if (mask_ss == tmp_ss)
10359 scalar_mask = 1;
10360
10361 tmp_ss = mask_ss;
10362 }
10363
10364 array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
10365 gcc_assert (array_ss != tmp_ss);
10366
10367 /* Odd thing: If the mask is scalar, it is used by the frontend after
10368 the array (to make an if around the nested loop). Thus it shall
10369 be after array_ss once the gfc_ss list is reversed. */
10370 if (scalar_mask)
10371 tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
10372 else
10373 tmp_ss = array_ss;
10374
10375 /* "Hide" the dimension on which we will sum in the first arg's scalarization
10376 chain. */
10377 sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
10378 tail = nest_loop_dimension (tmp_ss, sum_dim);
10379 tail->next = ss;
10380
10381 return tmp_ss;
10382 }
10383
10384
10385 static gfc_ss *
walk_inline_intrinsic_function(gfc_ss * ss,gfc_expr * expr)10386 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
10387 {
10388
10389 switch (expr->value.function.isym->id)
10390 {
10391 case GFC_ISYM_PRODUCT:
10392 case GFC_ISYM_SUM:
10393 return walk_inline_intrinsic_arith (ss, expr);
10394
10395 case GFC_ISYM_TRANSPOSE:
10396 return walk_inline_intrinsic_transpose (ss, expr);
10397
10398 default:
10399 gcc_unreachable ();
10400 }
10401 gcc_unreachable ();
10402 }
10403
10404
10405 /* This generates code to execute before entering the scalarization loop.
10406 Currently does nothing. */
10407
10408 void
gfc_add_intrinsic_ss_code(gfc_loopinfo * loop ATTRIBUTE_UNUSED,gfc_ss * ss)10409 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
10410 {
10411 switch (ss->info->expr->value.function.isym->id)
10412 {
10413 case GFC_ISYM_UBOUND:
10414 case GFC_ISYM_LBOUND:
10415 case GFC_ISYM_UCOBOUND:
10416 case GFC_ISYM_LCOBOUND:
10417 case GFC_ISYM_THIS_IMAGE:
10418 break;
10419
10420 default:
10421 gcc_unreachable ();
10422 }
10423 }
10424
10425
10426 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
10427 are expanded into code inside the scalarization loop. */
10428
10429 static gfc_ss *
gfc_walk_intrinsic_bound(gfc_ss * ss,gfc_expr * expr)10430 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
10431 {
10432 if (expr->value.function.actual->expr->ts.type == BT_CLASS)
10433 gfc_add_class_array_ref (expr->value.function.actual->expr);
10434
10435 /* The two argument version returns a scalar. */
10436 if (expr->value.function.actual->next->expr)
10437 return ss;
10438
10439 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
10440 }
10441
10442
10443 /* Walk an intrinsic array libcall. */
10444
10445 static gfc_ss *
gfc_walk_intrinsic_libfunc(gfc_ss * ss,gfc_expr * expr)10446 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
10447 {
10448 gcc_assert (expr->rank > 0);
10449 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
10450 }
10451
10452
10453 /* Return whether the function call expression EXPR will be expanded
10454 inline by gfc_conv_intrinsic_function. */
10455
10456 bool
gfc_inline_intrinsic_function_p(gfc_expr * expr)10457 gfc_inline_intrinsic_function_p (gfc_expr *expr)
10458 {
10459 gfc_actual_arglist *args, *dim_arg, *mask_arg;
10460 gfc_expr *maskexpr;
10461
10462 if (!expr->value.function.isym)
10463 return false;
10464
10465 switch (expr->value.function.isym->id)
10466 {
10467 case GFC_ISYM_PRODUCT:
10468 case GFC_ISYM_SUM:
10469 /* Disable inline expansion if code size matters. */
10470 if (optimize_size)
10471 return false;
10472
10473 args = expr->value.function.actual;
10474 dim_arg = args->next;
10475
10476 /* We need to be able to subset the SUM argument at compile-time. */
10477 if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT)
10478 return false;
10479
10480 /* FIXME: If MASK is optional for a more than two-dimensional
10481 argument, the scalarizer gets confused if the mask is
10482 absent. See PR 82995. For now, fall back to the library
10483 function. */
10484
10485 mask_arg = dim_arg->next;
10486 maskexpr = mask_arg->expr;
10487
10488 if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE
10489 && maskexpr->symtree->n.sym->attr.dummy
10490 && maskexpr->symtree->n.sym->attr.optional)
10491 return false;
10492
10493 return true;
10494
10495 case GFC_ISYM_TRANSPOSE:
10496 return true;
10497
10498 default:
10499 return false;
10500 }
10501 }
10502
10503
10504 /* Returns nonzero if the specified intrinsic function call maps directly to
10505 an external library call. Should only be used for functions that return
10506 arrays. */
10507
10508 int
gfc_is_intrinsic_libcall(gfc_expr * expr)10509 gfc_is_intrinsic_libcall (gfc_expr * expr)
10510 {
10511 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
10512 gcc_assert (expr->rank > 0);
10513
10514 if (gfc_inline_intrinsic_function_p (expr))
10515 return 0;
10516
10517 switch (expr->value.function.isym->id)
10518 {
10519 case GFC_ISYM_ALL:
10520 case GFC_ISYM_ANY:
10521 case GFC_ISYM_COUNT:
10522 case GFC_ISYM_FINDLOC:
10523 case GFC_ISYM_JN2:
10524 case GFC_ISYM_IANY:
10525 case GFC_ISYM_IALL:
10526 case GFC_ISYM_IPARITY:
10527 case GFC_ISYM_MATMUL:
10528 case GFC_ISYM_MAXLOC:
10529 case GFC_ISYM_MAXVAL:
10530 case GFC_ISYM_MINLOC:
10531 case GFC_ISYM_MINVAL:
10532 case GFC_ISYM_NORM2:
10533 case GFC_ISYM_PARITY:
10534 case GFC_ISYM_PRODUCT:
10535 case GFC_ISYM_SUM:
10536 case GFC_ISYM_SHAPE:
10537 case GFC_ISYM_SPREAD:
10538 case GFC_ISYM_YN2:
10539 /* Ignore absent optional parameters. */
10540 return 1;
10541
10542 case GFC_ISYM_CSHIFT:
10543 case GFC_ISYM_EOSHIFT:
10544 case GFC_ISYM_GET_TEAM:
10545 case GFC_ISYM_FAILED_IMAGES:
10546 case GFC_ISYM_STOPPED_IMAGES:
10547 case GFC_ISYM_PACK:
10548 case GFC_ISYM_RESHAPE:
10549 case GFC_ISYM_UNPACK:
10550 /* Pass absent optional parameters. */
10551 return 2;
10552
10553 default:
10554 return 0;
10555 }
10556 }
10557
10558 /* Walk an intrinsic function. */
10559 gfc_ss *
gfc_walk_intrinsic_function(gfc_ss * ss,gfc_expr * expr,gfc_intrinsic_sym * isym)10560 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
10561 gfc_intrinsic_sym * isym)
10562 {
10563 gcc_assert (isym);
10564
10565 if (isym->elemental)
10566 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
10567 NULL, GFC_SS_SCALAR);
10568
10569 if (expr->rank == 0)
10570 return ss;
10571
10572 if (gfc_inline_intrinsic_function_p (expr))
10573 return walk_inline_intrinsic_function (ss, expr);
10574
10575 if (gfc_is_intrinsic_libcall (expr))
10576 return gfc_walk_intrinsic_libfunc (ss, expr);
10577
10578 /* Special cases. */
10579 switch (isym->id)
10580 {
10581 case GFC_ISYM_LBOUND:
10582 case GFC_ISYM_LCOBOUND:
10583 case GFC_ISYM_UBOUND:
10584 case GFC_ISYM_UCOBOUND:
10585 case GFC_ISYM_THIS_IMAGE:
10586 return gfc_walk_intrinsic_bound (ss, expr);
10587
10588 case GFC_ISYM_TRANSFER:
10589 case GFC_ISYM_CAF_GET:
10590 return gfc_walk_intrinsic_libfunc (ss, expr);
10591
10592 default:
10593 /* This probably meant someone forgot to add an intrinsic to the above
10594 list(s) when they implemented it, or something's gone horribly
10595 wrong. */
10596 gcc_unreachable ();
10597 }
10598 }
10599
10600
10601 static tree
conv_co_collective(gfc_code * code)10602 conv_co_collective (gfc_code *code)
10603 {
10604 gfc_se argse;
10605 stmtblock_t block, post_block;
10606 tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
10607 gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
10608
10609 gfc_start_block (&block);
10610 gfc_init_block (&post_block);
10611
10612 if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
10613 {
10614 opr_expr = code->ext.actual->next->expr;
10615 image_idx_expr = code->ext.actual->next->next->expr;
10616 stat_expr = code->ext.actual->next->next->next->expr;
10617 errmsg_expr = code->ext.actual->next->next->next->next->expr;
10618 }
10619 else
10620 {
10621 opr_expr = NULL;
10622 image_idx_expr = code->ext.actual->next->expr;
10623 stat_expr = code->ext.actual->next->next->expr;
10624 errmsg_expr = code->ext.actual->next->next->next->expr;
10625 }
10626
10627 /* stat. */
10628 if (stat_expr)
10629 {
10630 gfc_init_se (&argse, NULL);
10631 gfc_conv_expr (&argse, stat_expr);
10632 gfc_add_block_to_block (&block, &argse.pre);
10633 gfc_add_block_to_block (&post_block, &argse.post);
10634 stat = argse.expr;
10635 if (flag_coarray != GFC_FCOARRAY_SINGLE)
10636 stat = gfc_build_addr_expr (NULL_TREE, stat);
10637 }
10638 else if (flag_coarray == GFC_FCOARRAY_SINGLE)
10639 stat = NULL_TREE;
10640 else
10641 stat = null_pointer_node;
10642
10643 /* Early exit for GFC_FCOARRAY_SINGLE. */
10644 if (flag_coarray == GFC_FCOARRAY_SINGLE)
10645 {
10646 if (stat != NULL_TREE)
10647 gfc_add_modify (&block, stat,
10648 fold_convert (TREE_TYPE (stat), integer_zero_node));
10649 return gfc_finish_block (&block);
10650 }
10651
10652 /* Handle the array. */
10653 gfc_init_se (&argse, NULL);
10654 if (code->ext.actual->expr->rank == 0)
10655 {
10656 symbol_attribute attr;
10657 gfc_clear_attr (&attr);
10658 gfc_init_se (&argse, NULL);
10659 gfc_conv_expr (&argse, code->ext.actual->expr);
10660 gfc_add_block_to_block (&block, &argse.pre);
10661 gfc_add_block_to_block (&post_block, &argse.post);
10662 array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
10663 array = gfc_build_addr_expr (NULL_TREE, array);
10664 }
10665 else
10666 {
10667 argse.want_pointer = 1;
10668 gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
10669 array = argse.expr;
10670 }
10671 gfc_add_block_to_block (&block, &argse.pre);
10672 gfc_add_block_to_block (&post_block, &argse.post);
10673
10674 if (code->ext.actual->expr->ts.type == BT_CHARACTER)
10675 strlen = argse.string_length;
10676 else
10677 strlen = integer_zero_node;
10678
10679 /* image_index. */
10680 if (image_idx_expr)
10681 {
10682 gfc_init_se (&argse, NULL);
10683 gfc_conv_expr (&argse, image_idx_expr);
10684 gfc_add_block_to_block (&block, &argse.pre);
10685 gfc_add_block_to_block (&post_block, &argse.post);
10686 image_index = fold_convert (integer_type_node, argse.expr);
10687 }
10688 else
10689 image_index = integer_zero_node;
10690
10691 /* errmsg. */
10692 if (errmsg_expr)
10693 {
10694 gfc_init_se (&argse, NULL);
10695 gfc_conv_expr (&argse, errmsg_expr);
10696 gfc_add_block_to_block (&block, &argse.pre);
10697 gfc_add_block_to_block (&post_block, &argse.post);
10698 errmsg = argse.expr;
10699 errmsg_len = fold_convert (size_type_node, argse.string_length);
10700 }
10701 else
10702 {
10703 errmsg = null_pointer_node;
10704 errmsg_len = build_zero_cst (size_type_node);
10705 }
10706
10707 /* Generate the function call. */
10708 switch (code->resolved_isym->id)
10709 {
10710 case GFC_ISYM_CO_BROADCAST:
10711 fndecl = gfor_fndecl_co_broadcast;
10712 break;
10713 case GFC_ISYM_CO_MAX:
10714 fndecl = gfor_fndecl_co_max;
10715 break;
10716 case GFC_ISYM_CO_MIN:
10717 fndecl = gfor_fndecl_co_min;
10718 break;
10719 case GFC_ISYM_CO_REDUCE:
10720 fndecl = gfor_fndecl_co_reduce;
10721 break;
10722 case GFC_ISYM_CO_SUM:
10723 fndecl = gfor_fndecl_co_sum;
10724 break;
10725 default:
10726 gcc_unreachable ();
10727 }
10728
10729 if (code->resolved_isym->id == GFC_ISYM_CO_SUM
10730 || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
10731 fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
10732 image_index, stat, errmsg, errmsg_len);
10733 else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
10734 fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index,
10735 stat, errmsg, strlen, errmsg_len);
10736 else
10737 {
10738 tree opr, opr_flags;
10739
10740 // FIXME: Handle TS29113's bind(C) strings with descriptor.
10741 int opr_flag_int;
10742 if (gfc_is_proc_ptr_comp (opr_expr))
10743 {
10744 gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
10745 opr_flag_int = sym->attr.dimension
10746 || (sym->ts.type == BT_CHARACTER
10747 && !sym->attr.is_bind_c)
10748 ? GFC_CAF_BYREF : 0;
10749 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
10750 && !sym->attr.is_bind_c
10751 ? GFC_CAF_HIDDENLEN : 0;
10752 opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0;
10753 }
10754 else
10755 {
10756 opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
10757 ? GFC_CAF_BYREF : 0;
10758 opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
10759 && !opr_expr->symtree->n.sym->attr.is_bind_c
10760 ? GFC_CAF_HIDDENLEN : 0;
10761 opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
10762 ? GFC_CAF_ARG_VALUE : 0;
10763 }
10764 opr_flags = build_int_cst (integer_type_node, opr_flag_int);
10765 gfc_conv_expr (&argse, opr_expr);
10766 opr = argse.expr;
10767 fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags,
10768 image_index, stat, errmsg, strlen, errmsg_len);
10769 }
10770
10771 gfc_add_expr_to_block (&block, fndecl);
10772 gfc_add_block_to_block (&block, &post_block);
10773
10774 return gfc_finish_block (&block);
10775 }
10776
10777
10778 static tree
conv_intrinsic_atomic_op(gfc_code * code)10779 conv_intrinsic_atomic_op (gfc_code *code)
10780 {
10781 gfc_se argse;
10782 tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
10783 stmtblock_t block, post_block;
10784 gfc_expr *atom_expr = code->ext.actual->expr;
10785 gfc_expr *stat_expr;
10786 built_in_function fn;
10787
10788 if (atom_expr->expr_type == EXPR_FUNCTION
10789 && atom_expr->value.function.isym
10790 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10791 atom_expr = atom_expr->value.function.actual->expr;
10792
10793 gfc_start_block (&block);
10794 gfc_init_block (&post_block);
10795
10796 gfc_init_se (&argse, NULL);
10797 argse.want_pointer = 1;
10798 gfc_conv_expr (&argse, atom_expr);
10799 gfc_add_block_to_block (&block, &argse.pre);
10800 gfc_add_block_to_block (&post_block, &argse.post);
10801 atom = argse.expr;
10802
10803 gfc_init_se (&argse, NULL);
10804 if (flag_coarray == GFC_FCOARRAY_LIB
10805 && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
10806 argse.want_pointer = 1;
10807 gfc_conv_expr (&argse, code->ext.actual->next->expr);
10808 gfc_add_block_to_block (&block, &argse.pre);
10809 gfc_add_block_to_block (&post_block, &argse.post);
10810 value = argse.expr;
10811
10812 switch (code->resolved_isym->id)
10813 {
10814 case GFC_ISYM_ATOMIC_ADD:
10815 case GFC_ISYM_ATOMIC_AND:
10816 case GFC_ISYM_ATOMIC_DEF:
10817 case GFC_ISYM_ATOMIC_OR:
10818 case GFC_ISYM_ATOMIC_XOR:
10819 stat_expr = code->ext.actual->next->next->expr;
10820 if (flag_coarray == GFC_FCOARRAY_LIB)
10821 old = null_pointer_node;
10822 break;
10823 default:
10824 gfc_init_se (&argse, NULL);
10825 if (flag_coarray == GFC_FCOARRAY_LIB)
10826 argse.want_pointer = 1;
10827 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
10828 gfc_add_block_to_block (&block, &argse.pre);
10829 gfc_add_block_to_block (&post_block, &argse.post);
10830 old = argse.expr;
10831 stat_expr = code->ext.actual->next->next->next->expr;
10832 }
10833
10834 /* STAT= */
10835 if (stat_expr != NULL)
10836 {
10837 gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
10838 gfc_init_se (&argse, NULL);
10839 if (flag_coarray == GFC_FCOARRAY_LIB)
10840 argse.want_pointer = 1;
10841 gfc_conv_expr_val (&argse, stat_expr);
10842 gfc_add_block_to_block (&block, &argse.pre);
10843 gfc_add_block_to_block (&post_block, &argse.post);
10844 stat = argse.expr;
10845 }
10846 else if (flag_coarray == GFC_FCOARRAY_LIB)
10847 stat = null_pointer_node;
10848
10849 if (flag_coarray == GFC_FCOARRAY_LIB)
10850 {
10851 tree image_index, caf_decl, offset, token;
10852 int op;
10853
10854 switch (code->resolved_isym->id)
10855 {
10856 case GFC_ISYM_ATOMIC_ADD:
10857 case GFC_ISYM_ATOMIC_FETCH_ADD:
10858 op = (int) GFC_CAF_ATOMIC_ADD;
10859 break;
10860 case GFC_ISYM_ATOMIC_AND:
10861 case GFC_ISYM_ATOMIC_FETCH_AND:
10862 op = (int) GFC_CAF_ATOMIC_AND;
10863 break;
10864 case GFC_ISYM_ATOMIC_OR:
10865 case GFC_ISYM_ATOMIC_FETCH_OR:
10866 op = (int) GFC_CAF_ATOMIC_OR;
10867 break;
10868 case GFC_ISYM_ATOMIC_XOR:
10869 case GFC_ISYM_ATOMIC_FETCH_XOR:
10870 op = (int) GFC_CAF_ATOMIC_XOR;
10871 break;
10872 case GFC_ISYM_ATOMIC_DEF:
10873 op = 0; /* Unused. */
10874 break;
10875 default:
10876 gcc_unreachable ();
10877 }
10878
10879 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
10880 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
10881 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
10882
10883 if (gfc_is_coindexed (atom_expr))
10884 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
10885 else
10886 image_index = integer_zero_node;
10887
10888 if (!POINTER_TYPE_P (TREE_TYPE (value)))
10889 {
10890 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
10891 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
10892 value = gfc_build_addr_expr (NULL_TREE, tmp);
10893 }
10894
10895 gfc_init_se (&argse, NULL);
10896 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
10897 atom_expr);
10898
10899 gfc_add_block_to_block (&block, &argse.pre);
10900 if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
10901 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
10902 token, offset, image_index, value, stat,
10903 build_int_cst (integer_type_node,
10904 (int) atom_expr->ts.type),
10905 build_int_cst (integer_type_node,
10906 (int) atom_expr->ts.kind));
10907 else
10908 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
10909 build_int_cst (integer_type_node, op),
10910 token, offset, image_index, value, old, stat,
10911 build_int_cst (integer_type_node,
10912 (int) atom_expr->ts.type),
10913 build_int_cst (integer_type_node,
10914 (int) atom_expr->ts.kind));
10915
10916 gfc_add_expr_to_block (&block, tmp);
10917 gfc_add_block_to_block (&block, &argse.post);
10918 gfc_add_block_to_block (&block, &post_block);
10919 return gfc_finish_block (&block);
10920 }
10921
10922
10923 switch (code->resolved_isym->id)
10924 {
10925 case GFC_ISYM_ATOMIC_ADD:
10926 case GFC_ISYM_ATOMIC_FETCH_ADD:
10927 fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
10928 break;
10929 case GFC_ISYM_ATOMIC_AND:
10930 case GFC_ISYM_ATOMIC_FETCH_AND:
10931 fn = BUILT_IN_ATOMIC_FETCH_AND_N;
10932 break;
10933 case GFC_ISYM_ATOMIC_DEF:
10934 fn = BUILT_IN_ATOMIC_STORE_N;
10935 break;
10936 case GFC_ISYM_ATOMIC_OR:
10937 case GFC_ISYM_ATOMIC_FETCH_OR:
10938 fn = BUILT_IN_ATOMIC_FETCH_OR_N;
10939 break;
10940 case GFC_ISYM_ATOMIC_XOR:
10941 case GFC_ISYM_ATOMIC_FETCH_XOR:
10942 fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
10943 break;
10944 default:
10945 gcc_unreachable ();
10946 }
10947
10948 tmp = TREE_TYPE (TREE_TYPE (atom));
10949 fn = (built_in_function) ((int) fn
10950 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
10951 + 1);
10952 tmp = builtin_decl_explicit (fn);
10953 tree itype = TREE_TYPE (TREE_TYPE (atom));
10954 tmp = builtin_decl_explicit (fn);
10955
10956 switch (code->resolved_isym->id)
10957 {
10958 case GFC_ISYM_ATOMIC_ADD:
10959 case GFC_ISYM_ATOMIC_AND:
10960 case GFC_ISYM_ATOMIC_DEF:
10961 case GFC_ISYM_ATOMIC_OR:
10962 case GFC_ISYM_ATOMIC_XOR:
10963 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
10964 fold_convert (itype, value),
10965 build_int_cst (NULL, MEMMODEL_RELAXED));
10966 gfc_add_expr_to_block (&block, tmp);
10967 break;
10968 default:
10969 tmp = build_call_expr_loc (input_location, tmp, 3, atom,
10970 fold_convert (itype, value),
10971 build_int_cst (NULL, MEMMODEL_RELAXED));
10972 gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
10973 break;
10974 }
10975
10976 if (stat != NULL_TREE)
10977 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
10978 gfc_add_block_to_block (&block, &post_block);
10979 return gfc_finish_block (&block);
10980 }
10981
10982
10983 static tree
conv_intrinsic_atomic_ref(gfc_code * code)10984 conv_intrinsic_atomic_ref (gfc_code *code)
10985 {
10986 gfc_se argse;
10987 tree tmp, atom, value, stat = NULL_TREE;
10988 stmtblock_t block, post_block;
10989 built_in_function fn;
10990 gfc_expr *atom_expr = code->ext.actual->next->expr;
10991
10992 if (atom_expr->expr_type == EXPR_FUNCTION
10993 && atom_expr->value.function.isym
10994 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10995 atom_expr = atom_expr->value.function.actual->expr;
10996
10997 gfc_start_block (&block);
10998 gfc_init_block (&post_block);
10999 gfc_init_se (&argse, NULL);
11000 argse.want_pointer = 1;
11001 gfc_conv_expr (&argse, atom_expr);
11002 gfc_add_block_to_block (&block, &argse.pre);
11003 gfc_add_block_to_block (&post_block, &argse.post);
11004 atom = argse.expr;
11005
11006 gfc_init_se (&argse, NULL);
11007 if (flag_coarray == GFC_FCOARRAY_LIB
11008 && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
11009 argse.want_pointer = 1;
11010 gfc_conv_expr (&argse, code->ext.actual->expr);
11011 gfc_add_block_to_block (&block, &argse.pre);
11012 gfc_add_block_to_block (&post_block, &argse.post);
11013 value = argse.expr;
11014
11015 /* STAT= */
11016 if (code->ext.actual->next->next->expr != NULL)
11017 {
11018 gcc_assert (code->ext.actual->next->next->expr->expr_type
11019 == EXPR_VARIABLE);
11020 gfc_init_se (&argse, NULL);
11021 if (flag_coarray == GFC_FCOARRAY_LIB)
11022 argse.want_pointer = 1;
11023 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
11024 gfc_add_block_to_block (&block, &argse.pre);
11025 gfc_add_block_to_block (&post_block, &argse.post);
11026 stat = argse.expr;
11027 }
11028 else if (flag_coarray == GFC_FCOARRAY_LIB)
11029 stat = null_pointer_node;
11030
11031 if (flag_coarray == GFC_FCOARRAY_LIB)
11032 {
11033 tree image_index, caf_decl, offset, token;
11034 tree orig_value = NULL_TREE, vardecl = NULL_TREE;
11035
11036 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
11037 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
11038 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
11039
11040 if (gfc_is_coindexed (atom_expr))
11041 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
11042 else
11043 image_index = integer_zero_node;
11044
11045 gfc_init_se (&argse, NULL);
11046 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
11047 atom_expr);
11048 gfc_add_block_to_block (&block, &argse.pre);
11049
11050 /* Different type, need type conversion. */
11051 if (!POINTER_TYPE_P (TREE_TYPE (value)))
11052 {
11053 vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
11054 orig_value = value;
11055 value = gfc_build_addr_expr (NULL_TREE, vardecl);
11056 }
11057
11058 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
11059 token, offset, image_index, value, stat,
11060 build_int_cst (integer_type_node,
11061 (int) atom_expr->ts.type),
11062 build_int_cst (integer_type_node,
11063 (int) atom_expr->ts.kind));
11064 gfc_add_expr_to_block (&block, tmp);
11065 if (vardecl != NULL_TREE)
11066 gfc_add_modify (&block, orig_value,
11067 fold_convert (TREE_TYPE (orig_value), vardecl));
11068 gfc_add_block_to_block (&block, &argse.post);
11069 gfc_add_block_to_block (&block, &post_block);
11070 return gfc_finish_block (&block);
11071 }
11072
11073 tmp = TREE_TYPE (TREE_TYPE (atom));
11074 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
11075 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
11076 + 1);
11077 tmp = builtin_decl_explicit (fn);
11078 tmp = build_call_expr_loc (input_location, tmp, 2, atom,
11079 build_int_cst (integer_type_node,
11080 MEMMODEL_RELAXED));
11081 gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
11082
11083 if (stat != NULL_TREE)
11084 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
11085 gfc_add_block_to_block (&block, &post_block);
11086 return gfc_finish_block (&block);
11087 }
11088
11089
11090 static tree
conv_intrinsic_atomic_cas(gfc_code * code)11091 conv_intrinsic_atomic_cas (gfc_code *code)
11092 {
11093 gfc_se argse;
11094 tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
11095 stmtblock_t block, post_block;
11096 built_in_function fn;
11097 gfc_expr *atom_expr = code->ext.actual->expr;
11098
11099 if (atom_expr->expr_type == EXPR_FUNCTION
11100 && atom_expr->value.function.isym
11101 && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
11102 atom_expr = atom_expr->value.function.actual->expr;
11103
11104 gfc_init_block (&block);
11105 gfc_init_block (&post_block);
11106 gfc_init_se (&argse, NULL);
11107 argse.want_pointer = 1;
11108 gfc_conv_expr (&argse, atom_expr);
11109 atom = argse.expr;
11110
11111 gfc_init_se (&argse, NULL);
11112 if (flag_coarray == GFC_FCOARRAY_LIB)
11113 argse.want_pointer = 1;
11114 gfc_conv_expr (&argse, code->ext.actual->next->expr);
11115 gfc_add_block_to_block (&block, &argse.pre);
11116 gfc_add_block_to_block (&post_block, &argse.post);
11117 old = argse.expr;
11118
11119 gfc_init_se (&argse, NULL);
11120 if (flag_coarray == GFC_FCOARRAY_LIB)
11121 argse.want_pointer = 1;
11122 gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
11123 gfc_add_block_to_block (&block, &argse.pre);
11124 gfc_add_block_to_block (&post_block, &argse.post);
11125 comp = argse.expr;
11126
11127 gfc_init_se (&argse, NULL);
11128 if (flag_coarray == GFC_FCOARRAY_LIB
11129 && code->ext.actual->next->next->next->expr->ts.kind
11130 == atom_expr->ts.kind)
11131 argse.want_pointer = 1;
11132 gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
11133 gfc_add_block_to_block (&block, &argse.pre);
11134 gfc_add_block_to_block (&post_block, &argse.post);
11135 new_val = argse.expr;
11136
11137 /* STAT= */
11138 if (code->ext.actual->next->next->next->next->expr != NULL)
11139 {
11140 gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
11141 == EXPR_VARIABLE);
11142 gfc_init_se (&argse, NULL);
11143 if (flag_coarray == GFC_FCOARRAY_LIB)
11144 argse.want_pointer = 1;
11145 gfc_conv_expr_val (&argse,
11146 code->ext.actual->next->next->next->next->expr);
11147 gfc_add_block_to_block (&block, &argse.pre);
11148 gfc_add_block_to_block (&post_block, &argse.post);
11149 stat = argse.expr;
11150 }
11151 else if (flag_coarray == GFC_FCOARRAY_LIB)
11152 stat = null_pointer_node;
11153
11154 if (flag_coarray == GFC_FCOARRAY_LIB)
11155 {
11156 tree image_index, caf_decl, offset, token;
11157
11158 caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
11159 if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
11160 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
11161
11162 if (gfc_is_coindexed (atom_expr))
11163 image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
11164 else
11165 image_index = integer_zero_node;
11166
11167 if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
11168 {
11169 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
11170 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
11171 new_val = gfc_build_addr_expr (NULL_TREE, tmp);
11172 }
11173
11174 /* Convert a constant to a pointer. */
11175 if (!POINTER_TYPE_P (TREE_TYPE (comp)))
11176 {
11177 tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
11178 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
11179 comp = gfc_build_addr_expr (NULL_TREE, tmp);
11180 }
11181
11182 gfc_init_se (&argse, NULL);
11183 gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
11184 atom_expr);
11185 gfc_add_block_to_block (&block, &argse.pre);
11186
11187 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
11188 token, offset, image_index, old, comp, new_val,
11189 stat, build_int_cst (integer_type_node,
11190 (int) atom_expr->ts.type),
11191 build_int_cst (integer_type_node,
11192 (int) atom_expr->ts.kind));
11193 gfc_add_expr_to_block (&block, tmp);
11194 gfc_add_block_to_block (&block, &argse.post);
11195 gfc_add_block_to_block (&block, &post_block);
11196 return gfc_finish_block (&block);
11197 }
11198
11199 tmp = TREE_TYPE (TREE_TYPE (atom));
11200 fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
11201 + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
11202 + 1);
11203 tmp = builtin_decl_explicit (fn);
11204
11205 gfc_add_modify (&block, old, comp);
11206 tmp = build_call_expr_loc (input_location, tmp, 6, atom,
11207 gfc_build_addr_expr (NULL, old),
11208 fold_convert (TREE_TYPE (old), new_val),
11209 boolean_false_node,
11210 build_int_cst (NULL, MEMMODEL_RELAXED),
11211 build_int_cst (NULL, MEMMODEL_RELAXED));
11212 gfc_add_expr_to_block (&block, tmp);
11213
11214 if (stat != NULL_TREE)
11215 gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
11216 gfc_add_block_to_block (&block, &post_block);
11217 return gfc_finish_block (&block);
11218 }
11219
11220 static tree
conv_intrinsic_event_query(gfc_code * code)11221 conv_intrinsic_event_query (gfc_code *code)
11222 {
11223 gfc_se se, argse;
11224 tree stat = NULL_TREE, stat2 = NULL_TREE;
11225 tree count = NULL_TREE, count2 = NULL_TREE;
11226
11227 gfc_expr *event_expr = code->ext.actual->expr;
11228
11229 if (code->ext.actual->next->next->expr)
11230 {
11231 gcc_assert (code->ext.actual->next->next->expr->expr_type
11232 == EXPR_VARIABLE);
11233 gfc_init_se (&argse, NULL);
11234 gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
11235 stat = argse.expr;
11236 }
11237 else if (flag_coarray == GFC_FCOARRAY_LIB)
11238 stat = null_pointer_node;
11239
11240 if (code->ext.actual->next->expr)
11241 {
11242 gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
11243 gfc_init_se (&argse, NULL);
11244 gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
11245 count = argse.expr;
11246 }
11247
11248 gfc_start_block (&se.pre);
11249 if (flag_coarray == GFC_FCOARRAY_LIB)
11250 {
11251 tree tmp, token, image_index;
11252 tree index = build_zero_cst (gfc_array_index_type);
11253
11254 if (event_expr->expr_type == EXPR_FUNCTION
11255 && event_expr->value.function.isym
11256 && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
11257 event_expr = event_expr->value.function.actual->expr;
11258
11259 tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
11260
11261 if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
11262 || event_expr->symtree->n.sym->ts.u.derived->from_intmod
11263 != INTMOD_ISO_FORTRAN_ENV
11264 || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
11265 != ISOFORTRAN_EVENT_TYPE)
11266 {
11267 gfc_error ("Sorry, the event component of derived type at %L is not "
11268 "yet supported", &event_expr->where);
11269 return NULL_TREE;
11270 }
11271
11272 if (gfc_is_coindexed (event_expr))
11273 {
11274 gfc_error ("The event variable at %L shall not be coindexed",
11275 &event_expr->where);
11276 return NULL_TREE;
11277 }
11278
11279 image_index = integer_zero_node;
11280
11281 gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
11282 event_expr);
11283
11284 /* For arrays, obtain the array index. */
11285 if (gfc_expr_attr (event_expr).dimension)
11286 {
11287 tree desc, tmp, extent, lbound, ubound;
11288 gfc_array_ref *ar, ar2;
11289 int i;
11290
11291 /* TODO: Extend this, once DT components are supported. */
11292 ar = &event_expr->ref->u.ar;
11293 ar2 = *ar;
11294 memset (ar, '\0', sizeof (*ar));
11295 ar->as = ar2.as;
11296 ar->type = AR_FULL;
11297
11298 gfc_init_se (&argse, NULL);
11299 argse.descriptor_only = 1;
11300 gfc_conv_expr_descriptor (&argse, event_expr);
11301 gfc_add_block_to_block (&se.pre, &argse.pre);
11302 desc = argse.expr;
11303 *ar = ar2;
11304
11305 extent = build_one_cst (gfc_array_index_type);
11306 for (i = 0; i < ar->dimen; i++)
11307 {
11308 gfc_init_se (&argse, NULL);
11309 gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
11310 gfc_add_block_to_block (&argse.pre, &argse.pre);
11311 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
11312 tmp = fold_build2_loc (input_location, MINUS_EXPR,
11313 TREE_TYPE (lbound), argse.expr, lbound);
11314 tmp = fold_build2_loc (input_location, MULT_EXPR,
11315 TREE_TYPE (tmp), extent, tmp);
11316 index = fold_build2_loc (input_location, PLUS_EXPR,
11317 TREE_TYPE (tmp), index, tmp);
11318 if (i < ar->dimen - 1)
11319 {
11320 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
11321 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
11322 extent = fold_build2_loc (input_location, MULT_EXPR,
11323 TREE_TYPE (tmp), extent, tmp);
11324 }
11325 }
11326 }
11327
11328 if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
11329 {
11330 count2 = count;
11331 count = gfc_create_var (integer_type_node, "count");
11332 }
11333
11334 if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
11335 {
11336 stat2 = stat;
11337 stat = gfc_create_var (integer_type_node, "stat");
11338 }
11339
11340 index = fold_convert (size_type_node, index);
11341 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
11342 token, index, image_index, count
11343 ? gfc_build_addr_expr (NULL, count) : count,
11344 stat != null_pointer_node
11345 ? gfc_build_addr_expr (NULL, stat) : stat);
11346 gfc_add_expr_to_block (&se.pre, tmp);
11347
11348 if (count2 != NULL_TREE)
11349 gfc_add_modify (&se.pre, count2,
11350 fold_convert (TREE_TYPE (count2), count));
11351
11352 if (stat2 != NULL_TREE)
11353 gfc_add_modify (&se.pre, stat2,
11354 fold_convert (TREE_TYPE (stat2), stat));
11355
11356 return gfc_finish_block (&se.pre);
11357 }
11358
11359 gfc_init_se (&argse, NULL);
11360 gfc_conv_expr_val (&argse, code->ext.actual->expr);
11361 gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
11362
11363 if (stat != NULL_TREE)
11364 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
11365
11366 return gfc_finish_block (&se.pre);
11367 }
11368
11369 static tree
conv_intrinsic_move_alloc(gfc_code * code)11370 conv_intrinsic_move_alloc (gfc_code *code)
11371 {
11372 stmtblock_t block;
11373 gfc_expr *from_expr, *to_expr;
11374 gfc_expr *to_expr2, *from_expr2 = NULL;
11375 gfc_se from_se, to_se;
11376 tree tmp;
11377 bool coarray;
11378
11379 gfc_start_block (&block);
11380
11381 from_expr = code->ext.actual->expr;
11382 to_expr = code->ext.actual->next->expr;
11383
11384 gfc_init_se (&from_se, NULL);
11385 gfc_init_se (&to_se, NULL);
11386
11387 gcc_assert (from_expr->ts.type != BT_CLASS
11388 || to_expr->ts.type == BT_CLASS);
11389 coarray = gfc_get_corank (from_expr) != 0;
11390
11391 if (from_expr->rank == 0 && !coarray)
11392 {
11393 if (from_expr->ts.type != BT_CLASS)
11394 from_expr2 = from_expr;
11395 else
11396 {
11397 from_expr2 = gfc_copy_expr (from_expr);
11398 gfc_add_data_component (from_expr2);
11399 }
11400
11401 if (to_expr->ts.type != BT_CLASS)
11402 to_expr2 = to_expr;
11403 else
11404 {
11405 to_expr2 = gfc_copy_expr (to_expr);
11406 gfc_add_data_component (to_expr2);
11407 }
11408
11409 from_se.want_pointer = 1;
11410 to_se.want_pointer = 1;
11411 gfc_conv_expr (&from_se, from_expr2);
11412 gfc_conv_expr (&to_se, to_expr2);
11413 gfc_add_block_to_block (&block, &from_se.pre);
11414 gfc_add_block_to_block (&block, &to_se.pre);
11415
11416 /* Deallocate "to". */
11417 tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
11418 true, to_expr, to_expr->ts);
11419 gfc_add_expr_to_block (&block, tmp);
11420
11421 /* Assign (_data) pointers. */
11422 gfc_add_modify_loc (input_location, &block, to_se.expr,
11423 fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
11424
11425 /* Set "from" to NULL. */
11426 gfc_add_modify_loc (input_location, &block, from_se.expr,
11427 fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
11428
11429 gfc_add_block_to_block (&block, &from_se.post);
11430 gfc_add_block_to_block (&block, &to_se.post);
11431
11432 /* Set _vptr. */
11433 if (to_expr->ts.type == BT_CLASS)
11434 {
11435 gfc_symbol *vtab;
11436
11437 gfc_free_expr (to_expr2);
11438 gfc_init_se (&to_se, NULL);
11439 to_se.want_pointer = 1;
11440 gfc_add_vptr_component (to_expr);
11441 gfc_conv_expr (&to_se, to_expr);
11442
11443 if (from_expr->ts.type == BT_CLASS)
11444 {
11445 if (UNLIMITED_POLY (from_expr))
11446 vtab = NULL;
11447 else
11448 {
11449 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
11450 gcc_assert (vtab);
11451 }
11452
11453 gfc_free_expr (from_expr2);
11454 gfc_init_se (&from_se, NULL);
11455 from_se.want_pointer = 1;
11456 gfc_add_vptr_component (from_expr);
11457 gfc_conv_expr (&from_se, from_expr);
11458 gfc_add_modify_loc (input_location, &block, to_se.expr,
11459 fold_convert (TREE_TYPE (to_se.expr),
11460 from_se.expr));
11461
11462 /* Reset _vptr component to declared type. */
11463 if (vtab == NULL)
11464 /* Unlimited polymorphic. */
11465 gfc_add_modify_loc (input_location, &block, from_se.expr,
11466 fold_convert (TREE_TYPE (from_se.expr),
11467 null_pointer_node));
11468 else
11469 {
11470 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
11471 gfc_add_modify_loc (input_location, &block, from_se.expr,
11472 fold_convert (TREE_TYPE (from_se.expr), tmp));
11473 }
11474 }
11475 else
11476 {
11477 vtab = gfc_find_vtab (&from_expr->ts);
11478 gcc_assert (vtab);
11479 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
11480 gfc_add_modify_loc (input_location, &block, to_se.expr,
11481 fold_convert (TREE_TYPE (to_se.expr), tmp));
11482 }
11483 }
11484
11485 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
11486 {
11487 gfc_add_modify_loc (input_location, &block, to_se.string_length,
11488 fold_convert (TREE_TYPE (to_se.string_length),
11489 from_se.string_length));
11490 if (from_expr->ts.deferred)
11491 gfc_add_modify_loc (input_location, &block, from_se.string_length,
11492 build_int_cst (TREE_TYPE (from_se.string_length), 0));
11493 }
11494
11495 return gfc_finish_block (&block);
11496 }
11497
11498 /* Update _vptr component. */
11499 if (to_expr->ts.type == BT_CLASS)
11500 {
11501 gfc_symbol *vtab;
11502
11503 to_se.want_pointer = 1;
11504 to_expr2 = gfc_copy_expr (to_expr);
11505 gfc_add_vptr_component (to_expr2);
11506 gfc_conv_expr (&to_se, to_expr2);
11507
11508 if (from_expr->ts.type == BT_CLASS)
11509 {
11510 if (UNLIMITED_POLY (from_expr))
11511 vtab = NULL;
11512 else
11513 {
11514 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
11515 gcc_assert (vtab);
11516 }
11517
11518 from_se.want_pointer = 1;
11519 from_expr2 = gfc_copy_expr (from_expr);
11520 gfc_add_vptr_component (from_expr2);
11521 gfc_conv_expr (&from_se, from_expr2);
11522 gfc_add_modify_loc (input_location, &block, to_se.expr,
11523 fold_convert (TREE_TYPE (to_se.expr),
11524 from_se.expr));
11525
11526 /* Reset _vptr component to declared type. */
11527 if (vtab == NULL)
11528 /* Unlimited polymorphic. */
11529 gfc_add_modify_loc (input_location, &block, from_se.expr,
11530 fold_convert (TREE_TYPE (from_se.expr),
11531 null_pointer_node));
11532 else
11533 {
11534 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
11535 gfc_add_modify_loc (input_location, &block, from_se.expr,
11536 fold_convert (TREE_TYPE (from_se.expr), tmp));
11537 }
11538 }
11539 else
11540 {
11541 vtab = gfc_find_vtab (&from_expr->ts);
11542 gcc_assert (vtab);
11543 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
11544 gfc_add_modify_loc (input_location, &block, to_se.expr,
11545 fold_convert (TREE_TYPE (to_se.expr), tmp));
11546 }
11547
11548 gfc_free_expr (to_expr2);
11549 gfc_init_se (&to_se, NULL);
11550
11551 if (from_expr->ts.type == BT_CLASS)
11552 {
11553 gfc_free_expr (from_expr2);
11554 gfc_init_se (&from_se, NULL);
11555 }
11556 }
11557
11558
11559 /* Deallocate "to". */
11560 if (from_expr->rank == 0)
11561 {
11562 to_se.want_coarray = 1;
11563 from_se.want_coarray = 1;
11564 }
11565 gfc_conv_expr_descriptor (&to_se, to_expr);
11566 gfc_conv_expr_descriptor (&from_se, from_expr);
11567
11568 /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
11569 is an image control "statement", cf. IR F08/0040 in 12-006A. */
11570 if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
11571 {
11572 tree cond;
11573
11574 tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
11575 NULL_TREE, NULL_TREE, true, to_expr,
11576 GFC_CAF_COARRAY_DEALLOCATE_ONLY);
11577 gfc_add_expr_to_block (&block, tmp);
11578
11579 tmp = gfc_conv_descriptor_data_get (to_se.expr);
11580 cond = fold_build2_loc (input_location, EQ_EXPR,
11581 logical_type_node, tmp,
11582 fold_convert (TREE_TYPE (tmp),
11583 null_pointer_node));
11584 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
11585 3, null_pointer_node, null_pointer_node,
11586 build_int_cst (integer_type_node, 0));
11587
11588 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
11589 tmp, build_empty_stmt (input_location));
11590 gfc_add_expr_to_block (&block, tmp);
11591 }
11592 else
11593 {
11594 if (to_expr->ts.type == BT_DERIVED
11595 && to_expr->ts.u.derived->attr.alloc_comp)
11596 {
11597 tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
11598 to_se.expr, to_expr->rank);
11599 gfc_add_expr_to_block (&block, tmp);
11600 }
11601
11602 tmp = gfc_conv_descriptor_data_get (to_se.expr);
11603 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
11604 NULL_TREE, true, to_expr,
11605 GFC_CAF_COARRAY_NOCOARRAY);
11606 gfc_add_expr_to_block (&block, tmp);
11607 }
11608
11609 /* Move the pointer and update the array descriptor data. */
11610 gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
11611
11612 /* Set "from" to NULL. */
11613 tmp = gfc_conv_descriptor_data_get (from_se.expr);
11614 gfc_add_modify_loc (input_location, &block, tmp,
11615 fold_convert (TREE_TYPE (tmp), null_pointer_node));
11616
11617
11618 if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
11619 {
11620 gfc_add_modify_loc (input_location, &block, to_se.string_length,
11621 fold_convert (TREE_TYPE (to_se.string_length),
11622 from_se.string_length));
11623 if (from_expr->ts.deferred)
11624 gfc_add_modify_loc (input_location, &block, from_se.string_length,
11625 build_int_cst (TREE_TYPE (from_se.string_length), 0));
11626 }
11627
11628 return gfc_finish_block (&block);
11629 }
11630
11631
11632 tree
gfc_conv_intrinsic_subroutine(gfc_code * code)11633 gfc_conv_intrinsic_subroutine (gfc_code *code)
11634 {
11635 tree res;
11636
11637 gcc_assert (code->resolved_isym);
11638
11639 switch (code->resolved_isym->id)
11640 {
11641 case GFC_ISYM_MOVE_ALLOC:
11642 res = conv_intrinsic_move_alloc (code);
11643 break;
11644
11645 case GFC_ISYM_ATOMIC_CAS:
11646 res = conv_intrinsic_atomic_cas (code);
11647 break;
11648
11649 case GFC_ISYM_ATOMIC_ADD:
11650 case GFC_ISYM_ATOMIC_AND:
11651 case GFC_ISYM_ATOMIC_DEF:
11652 case GFC_ISYM_ATOMIC_OR:
11653 case GFC_ISYM_ATOMIC_XOR:
11654 case GFC_ISYM_ATOMIC_FETCH_ADD:
11655 case GFC_ISYM_ATOMIC_FETCH_AND:
11656 case GFC_ISYM_ATOMIC_FETCH_OR:
11657 case GFC_ISYM_ATOMIC_FETCH_XOR:
11658 res = conv_intrinsic_atomic_op (code);
11659 break;
11660
11661 case GFC_ISYM_ATOMIC_REF:
11662 res = conv_intrinsic_atomic_ref (code);
11663 break;
11664
11665 case GFC_ISYM_EVENT_QUERY:
11666 res = conv_intrinsic_event_query (code);
11667 break;
11668
11669 case GFC_ISYM_C_F_POINTER:
11670 case GFC_ISYM_C_F_PROCPOINTER:
11671 res = conv_isocbinding_subroutine (code);
11672 break;
11673
11674 case GFC_ISYM_CAF_SEND:
11675 res = conv_caf_send (code);
11676 break;
11677
11678 case GFC_ISYM_CO_BROADCAST:
11679 case GFC_ISYM_CO_MIN:
11680 case GFC_ISYM_CO_MAX:
11681 case GFC_ISYM_CO_REDUCE:
11682 case GFC_ISYM_CO_SUM:
11683 res = conv_co_collective (code);
11684 break;
11685
11686 case GFC_ISYM_FREE:
11687 res = conv_intrinsic_free (code);
11688 break;
11689
11690 case GFC_ISYM_RANDOM_INIT:
11691 res = conv_intrinsic_random_init (code);
11692 break;
11693
11694 case GFC_ISYM_KILL:
11695 res = conv_intrinsic_kill_sub (code);
11696 break;
11697
11698 case GFC_ISYM_SYSTEM_CLOCK:
11699 res = conv_intrinsic_system_clock (code);
11700 break;
11701
11702 default:
11703 res = NULL_TREE;
11704 break;
11705 }
11706
11707 return res;
11708 }
11709
11710 #include "gt-fortran-trans-intrinsic.h"
11711