1 /* Code translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "tree.h"
25 #include "gimple-expr.h" /* For create_tmp_var_raw. */
26 #include "stringpool.h"
27 #include "tree-iterator.h"
28 #include "diagnostic-core.h" /* For internal_error. */
29 #include "flags.h"
30 #include "gfortran.h"
31 #include "trans.h"
32 #include "trans-stmt.h"
33 #include "trans-array.h"
34 #include "trans-types.h"
35 #include "trans-const.h"
36
37 /* Naming convention for backend interface code:
38
39 gfc_trans_* translate gfc_code into STMT trees.
40
41 gfc_conv_* expression conversion
42
43 gfc_get_* get a backend tree representation of a decl or type */
44
45 static gfc_file *gfc_current_backend_file;
46
47 const char gfc_msg_fault[] = N_("Array reference out of bounds");
48 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
49
50
51 /* Advance along TREE_CHAIN n times. */
52
53 tree
gfc_advance_chain(tree t,int n)54 gfc_advance_chain (tree t, int n)
55 {
56 for (; n > 0; n--)
57 {
58 gcc_assert (t != NULL_TREE);
59 t = DECL_CHAIN (t);
60 }
61 return t;
62 }
63
64
65 /* Strip off a legitimate source ending from the input
66 string NAME of length LEN. */
67
68 static inline void
remove_suffix(char * name,int len)69 remove_suffix (char *name, int len)
70 {
71 int i;
72
73 for (i = 2; i < 8 && len > i; i++)
74 {
75 if (name[len - i] == '.')
76 {
77 name[len - i] = '\0';
78 break;
79 }
80 }
81 }
82
83
84 /* Creates a variable declaration with a given TYPE. */
85
86 tree
gfc_create_var_np(tree type,const char * prefix)87 gfc_create_var_np (tree type, const char *prefix)
88 {
89 tree t;
90
91 t = create_tmp_var_raw (type, prefix);
92
93 /* No warnings for anonymous variables. */
94 if (prefix == NULL)
95 TREE_NO_WARNING (t) = 1;
96
97 return t;
98 }
99
100
101 /* Like above, but also adds it to the current scope. */
102
103 tree
gfc_create_var(tree type,const char * prefix)104 gfc_create_var (tree type, const char *prefix)
105 {
106 tree tmp;
107
108 tmp = gfc_create_var_np (type, prefix);
109
110 pushdecl (tmp);
111
112 return tmp;
113 }
114
115
116 /* If the expression is not constant, evaluate it now. We assign the
117 result of the expression to an artificially created variable VAR, and
118 return a pointer to the VAR_DECL node for this variable. */
119
120 tree
gfc_evaluate_now_loc(location_t loc,tree expr,stmtblock_t * pblock)121 gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
122 {
123 tree var;
124
125 if (CONSTANT_CLASS_P (expr))
126 return expr;
127
128 var = gfc_create_var (TREE_TYPE (expr), NULL);
129 gfc_add_modify_loc (loc, pblock, var, expr);
130
131 return var;
132 }
133
134
135 tree
gfc_evaluate_now(tree expr,stmtblock_t * pblock)136 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
137 {
138 return gfc_evaluate_now_loc (input_location, expr, pblock);
139 }
140
141
142 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
143 A MODIFY_EXPR is an assignment:
144 LHS <- RHS. */
145
146 void
gfc_add_modify_loc(location_t loc,stmtblock_t * pblock,tree lhs,tree rhs)147 gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
148 {
149 tree tmp;
150
151 #ifdef ENABLE_CHECKING
152 tree t1, t2;
153 t1 = TREE_TYPE (rhs);
154 t2 = TREE_TYPE (lhs);
155 /* Make sure that the types of the rhs and the lhs are the same
156 for scalar assignments. We should probably have something
157 similar for aggregates, but right now removing that check just
158 breaks everything. */
159 gcc_assert (t1 == t2
160 || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
161 #endif
162
163 tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
164 rhs);
165 gfc_add_expr_to_block (pblock, tmp);
166 }
167
168
169 void
gfc_add_modify(stmtblock_t * pblock,tree lhs,tree rhs)170 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
171 {
172 gfc_add_modify_loc (input_location, pblock, lhs, rhs);
173 }
174
175
176 /* Create a new scope/binding level and initialize a block. Care must be
177 taken when translating expressions as any temporaries will be placed in
178 the innermost scope. */
179
180 void
gfc_start_block(stmtblock_t * block)181 gfc_start_block (stmtblock_t * block)
182 {
183 /* Start a new binding level. */
184 pushlevel ();
185 block->has_scope = 1;
186
187 /* The block is empty. */
188 block->head = NULL_TREE;
189 }
190
191
192 /* Initialize a block without creating a new scope. */
193
194 void
gfc_init_block(stmtblock_t * block)195 gfc_init_block (stmtblock_t * block)
196 {
197 block->head = NULL_TREE;
198 block->has_scope = 0;
199 }
200
201
202 /* Sometimes we create a scope but it turns out that we don't actually
203 need it. This function merges the scope of BLOCK with its parent.
204 Only variable decls will be merged, you still need to add the code. */
205
206 void
gfc_merge_block_scope(stmtblock_t * block)207 gfc_merge_block_scope (stmtblock_t * block)
208 {
209 tree decl;
210 tree next;
211
212 gcc_assert (block->has_scope);
213 block->has_scope = 0;
214
215 /* Remember the decls in this scope. */
216 decl = getdecls ();
217 poplevel (0, 0);
218
219 /* Add them to the parent scope. */
220 while (decl != NULL_TREE)
221 {
222 next = DECL_CHAIN (decl);
223 DECL_CHAIN (decl) = NULL_TREE;
224
225 pushdecl (decl);
226 decl = next;
227 }
228 }
229
230
231 /* Finish a scope containing a block of statements. */
232
233 tree
gfc_finish_block(stmtblock_t * stmtblock)234 gfc_finish_block (stmtblock_t * stmtblock)
235 {
236 tree decl;
237 tree expr;
238 tree block;
239
240 expr = stmtblock->head;
241 if (!expr)
242 expr = build_empty_stmt (input_location);
243
244 stmtblock->head = NULL_TREE;
245
246 if (stmtblock->has_scope)
247 {
248 decl = getdecls ();
249
250 if (decl)
251 {
252 block = poplevel (1, 0);
253 expr = build3_v (BIND_EXPR, decl, expr, block);
254 }
255 else
256 poplevel (0, 0);
257 }
258
259 return expr;
260 }
261
262
263 /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the
264 natural type is used. */
265
266 tree
gfc_build_addr_expr(tree type,tree t)267 gfc_build_addr_expr (tree type, tree t)
268 {
269 tree base_type = TREE_TYPE (t);
270 tree natural_type;
271
272 if (type && POINTER_TYPE_P (type)
273 && TREE_CODE (base_type) == ARRAY_TYPE
274 && TYPE_MAIN_VARIANT (TREE_TYPE (type))
275 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
276 {
277 tree min_val = size_zero_node;
278 tree type_domain = TYPE_DOMAIN (base_type);
279 if (type_domain && TYPE_MIN_VALUE (type_domain))
280 min_val = TYPE_MIN_VALUE (type_domain);
281 t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type),
282 t, min_val, NULL_TREE, NULL_TREE));
283 natural_type = type;
284 }
285 else
286 natural_type = build_pointer_type (base_type);
287
288 if (TREE_CODE (t) == INDIRECT_REF)
289 {
290 if (!type)
291 type = natural_type;
292 t = TREE_OPERAND (t, 0);
293 natural_type = TREE_TYPE (t);
294 }
295 else
296 {
297 tree base = get_base_address (t);
298 if (base && DECL_P (base))
299 TREE_ADDRESSABLE (base) = 1;
300 t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
301 }
302
303 if (type && natural_type != type)
304 t = convert (type, t);
305
306 return t;
307 }
308
309
310 /* Build an ARRAY_REF with its natural type. */
311
312 tree
gfc_build_array_ref(tree base,tree offset,tree decl)313 gfc_build_array_ref (tree base, tree offset, tree decl)
314 {
315 tree type = TREE_TYPE (base);
316 tree tmp;
317 tree span;
318
319 if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
320 {
321 gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
322
323 return fold_convert (TYPE_MAIN_VARIANT (type), base);
324 }
325
326 /* Scalar coarray, there is nothing to do. */
327 if (TREE_CODE (type) != ARRAY_TYPE)
328 {
329 gcc_assert (decl == NULL_TREE);
330 gcc_assert (integer_zerop (offset));
331 return base;
332 }
333
334 type = TREE_TYPE (type);
335
336 if (DECL_P (base))
337 TREE_ADDRESSABLE (base) = 1;
338
339 /* Strip NON_LVALUE_EXPR nodes. */
340 STRIP_TYPE_NOPS (offset);
341
342 /* If the array reference is to a pointer, whose target contains a
343 subreference, use the span that is stored with the backend decl
344 and reference the element with pointer arithmetic. */
345 if (decl && (TREE_CODE (decl) == FIELD_DECL
346 || TREE_CODE (decl) == VAR_DECL
347 || TREE_CODE (decl) == PARM_DECL)
348 && ((GFC_DECL_SUBREF_ARRAY_P (decl)
349 && !integer_zerop (GFC_DECL_SPAN(decl)))
350 || GFC_DECL_CLASS (decl)))
351 {
352 if (GFC_DECL_CLASS (decl))
353 {
354 /* Allow for dummy arguments and other good things. */
355 if (POINTER_TYPE_P (TREE_TYPE (decl)))
356 decl = build_fold_indirect_ref_loc (input_location, decl);
357
358 /* Check if '_data' is an array descriptor. If it is not,
359 the array must be one of the components of the class object,
360 so return a normal array reference. */
361 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl))))
362 return build4_loc (input_location, ARRAY_REF, type, base,
363 offset, NULL_TREE, NULL_TREE);
364
365 span = gfc_vtable_size_get (decl);
366 }
367 else if (GFC_DECL_SUBREF_ARRAY_P (decl))
368 span = GFC_DECL_SPAN(decl);
369 else
370 gcc_unreachable ();
371
372 offset = fold_build2_loc (input_location, MULT_EXPR,
373 gfc_array_index_type,
374 offset, span);
375 tmp = gfc_build_addr_expr (pvoid_type_node, base);
376 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
377 tmp = fold_convert (build_pointer_type (type), tmp);
378 if (!TYPE_STRING_FLAG (type))
379 tmp = build_fold_indirect_ref_loc (input_location, tmp);
380 return tmp;
381 }
382 else
383 /* Otherwise use a straightforward array reference. */
384 return build4_loc (input_location, ARRAY_REF, type, base, offset,
385 NULL_TREE, NULL_TREE);
386 }
387
388
389 /* Generate a call to print a runtime error possibly including multiple
390 arguments and a locus. */
391
392 static tree
trans_runtime_error_vararg(bool error,locus * where,const char * msgid,va_list ap)393 trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
394 va_list ap)
395 {
396 stmtblock_t block;
397 tree tmp;
398 tree arg, arg2;
399 tree *argarray;
400 tree fntype;
401 char *message;
402 const char *p;
403 int line, nargs, i;
404 location_t loc;
405
406 /* Compute the number of extra arguments from the format string. */
407 for (p = msgid, nargs = 0; *p; p++)
408 if (*p == '%')
409 {
410 p++;
411 if (*p != '%')
412 nargs++;
413 }
414
415 /* The code to generate the error. */
416 gfc_start_block (&block);
417
418 if (where)
419 {
420 line = LOCATION_LINE (where->lb->location);
421 asprintf (&message, "At line %d of file %s", line,
422 where->lb->file->filename);
423 }
424 else
425 asprintf (&message, "In file '%s', around line %d",
426 gfc_source_file, LOCATION_LINE (input_location) + 1);
427
428 arg = gfc_build_addr_expr (pchar_type_node,
429 gfc_build_localized_cstring_const (message));
430 free (message);
431
432 asprintf (&message, "%s", _(msgid));
433 arg2 = gfc_build_addr_expr (pchar_type_node,
434 gfc_build_localized_cstring_const (message));
435 free (message);
436
437 /* Build the argument array. */
438 argarray = XALLOCAVEC (tree, nargs + 2);
439 argarray[0] = arg;
440 argarray[1] = arg2;
441 for (i = 0; i < nargs; i++)
442 argarray[2 + i] = va_arg (ap, tree);
443
444 /* Build the function call to runtime_(warning,error)_at; because of the
445 variable number of arguments, we can't use build_call_expr_loc dinput_location,
446 irectly. */
447 if (error)
448 fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
449 else
450 fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
451
452 loc = where ? where->lb->location : input_location;
453 tmp = fold_builtin_call_array (loc, TREE_TYPE (fntype),
454 fold_build1_loc (loc, ADDR_EXPR,
455 build_pointer_type (fntype),
456 error
457 ? gfor_fndecl_runtime_error_at
458 : gfor_fndecl_runtime_warning_at),
459 nargs + 2, argarray);
460 gfc_add_expr_to_block (&block, tmp);
461
462 return gfc_finish_block (&block);
463 }
464
465
466 tree
gfc_trans_runtime_error(bool error,locus * where,const char * msgid,...)467 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
468 {
469 va_list ap;
470 tree result;
471
472 va_start (ap, msgid);
473 result = trans_runtime_error_vararg (error, where, msgid, ap);
474 va_end (ap);
475 return result;
476 }
477
478
479 /* Generate a runtime error if COND is true. */
480
481 void
gfc_trans_runtime_check(bool error,bool once,tree cond,stmtblock_t * pblock,locus * where,const char * msgid,...)482 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
483 locus * where, const char * msgid, ...)
484 {
485 va_list ap;
486 stmtblock_t block;
487 tree body;
488 tree tmp;
489 tree tmpvar = NULL;
490
491 if (integer_zerop (cond))
492 return;
493
494 if (once)
495 {
496 tmpvar = gfc_create_var (boolean_type_node, "print_warning");
497 TREE_STATIC (tmpvar) = 1;
498 DECL_INITIAL (tmpvar) = boolean_true_node;
499 gfc_add_expr_to_block (pblock, tmpvar);
500 }
501
502 gfc_start_block (&block);
503
504 /* For error, runtime_error_at already implies PRED_NORETURN. */
505 if (!error && once)
506 gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE,
507 NOT_TAKEN));
508
509 /* The code to generate the error. */
510 va_start (ap, msgid);
511 gfc_add_expr_to_block (&block,
512 trans_runtime_error_vararg (error, where,
513 msgid, ap));
514 va_end (ap);
515
516 if (once)
517 gfc_add_modify (&block, tmpvar, boolean_false_node);
518
519 body = gfc_finish_block (&block);
520
521 if (integer_onep (cond))
522 {
523 gfc_add_expr_to_block (pblock, body);
524 }
525 else
526 {
527 if (once)
528 cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
529 long_integer_type_node, tmpvar, cond);
530 else
531 cond = fold_convert (long_integer_type_node, cond);
532
533 tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
534 cond, body,
535 build_empty_stmt (where->lb->location));
536 gfc_add_expr_to_block (pblock, tmp);
537 }
538 }
539
540
541 /* Call malloc to allocate size bytes of memory, with special conditions:
542 + if size == 0, return a malloced area of size 1,
543 + if malloc returns NULL, issue a runtime error. */
544 tree
gfc_call_malloc(stmtblock_t * block,tree type,tree size)545 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
546 {
547 tree tmp, msg, malloc_result, null_result, res, malloc_tree;
548 stmtblock_t block2;
549
550 size = gfc_evaluate_now (size, block);
551
552 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
553 size = fold_convert (size_type_node, size);
554
555 /* Create a variable to hold the result. */
556 res = gfc_create_var (prvoid_type_node, NULL);
557
558 /* Call malloc. */
559 gfc_start_block (&block2);
560
561 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
562 build_int_cst (size_type_node, 1));
563
564 malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
565 gfc_add_modify (&block2, res,
566 fold_convert (prvoid_type_node,
567 build_call_expr_loc (input_location,
568 malloc_tree, 1, size)));
569
570 /* Optionally check whether malloc was successful. */
571 if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
572 {
573 null_result = fold_build2_loc (input_location, EQ_EXPR,
574 boolean_type_node, res,
575 build_int_cst (pvoid_type_node, 0));
576 msg = gfc_build_addr_expr (pchar_type_node,
577 gfc_build_localized_cstring_const ("Memory allocation failed"));
578 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
579 null_result,
580 build_call_expr_loc (input_location,
581 gfor_fndecl_os_error, 1, msg),
582 build_empty_stmt (input_location));
583 gfc_add_expr_to_block (&block2, tmp);
584 }
585
586 malloc_result = gfc_finish_block (&block2);
587
588 gfc_add_expr_to_block (block, malloc_result);
589
590 if (type != NULL)
591 res = fold_convert (type, res);
592 return res;
593 }
594
595
596 /* Allocate memory, using an optional status argument.
597
598 This function follows the following pseudo-code:
599
600 void *
601 allocate (size_t size, integer_type stat)
602 {
603 void *newmem;
604
605 if (stat requested)
606 stat = 0;
607
608 newmem = malloc (MAX (size, 1));
609 if (newmem == NULL)
610 {
611 if (stat)
612 *stat = LIBERROR_ALLOCATION;
613 else
614 runtime_error ("Allocation would exceed memory limit");
615 }
616 return newmem;
617 } */
618 void
gfc_allocate_using_malloc(stmtblock_t * block,tree pointer,tree size,tree status)619 gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
620 tree size, tree status)
621 {
622 tree tmp, error_cond;
623 stmtblock_t on_error;
624 tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
625
626 /* Evaluate size only once, and make sure it has the right type. */
627 size = gfc_evaluate_now (size, block);
628 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
629 size = fold_convert (size_type_node, size);
630
631 /* If successful and stat= is given, set status to 0. */
632 if (status != NULL_TREE)
633 gfc_add_expr_to_block (block,
634 fold_build2_loc (input_location, MODIFY_EXPR, status_type,
635 status, build_int_cst (status_type, 0)));
636
637 /* The allocation itself. */
638 gfc_add_modify (block, pointer,
639 fold_convert (TREE_TYPE (pointer),
640 build_call_expr_loc (input_location,
641 builtin_decl_explicit (BUILT_IN_MALLOC), 1,
642 fold_build2_loc (input_location,
643 MAX_EXPR, size_type_node, size,
644 build_int_cst (size_type_node, 1)))));
645
646 /* What to do in case of error. */
647 gfc_start_block (&on_error);
648 if (status != NULL_TREE)
649 {
650 gfc_add_expr_to_block (&on_error,
651 build_predict_expr (PRED_FORTRAN_FAIL_ALLOC,
652 NOT_TAKEN));
653 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status,
654 build_int_cst (status_type, LIBERROR_ALLOCATION));
655 gfc_add_expr_to_block (&on_error, tmp);
656 }
657 else
658 {
659 /* Here, os_error already implies PRED_NORETURN. */
660 tmp = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
661 gfc_build_addr_expr (pchar_type_node,
662 gfc_build_localized_cstring_const
663 ("Allocation would exceed memory limit")));
664 gfc_add_expr_to_block (&on_error, tmp);
665 }
666
667 error_cond = fold_build2_loc (input_location, EQ_EXPR,
668 boolean_type_node, pointer,
669 build_int_cst (prvoid_type_node, 0));
670 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
671 error_cond, gfc_finish_block (&on_error),
672 build_empty_stmt (input_location));
673
674 gfc_add_expr_to_block (block, tmp);
675 }
676
677
678 /* Allocate memory, using an optional status argument.
679
680 This function follows the following pseudo-code:
681
682 void *
683 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
684 {
685 void *newmem;
686
687 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
688 return newmem;
689 } */
690 static void
gfc_allocate_using_lib(stmtblock_t * block,tree pointer,tree size,tree token,tree status,tree errmsg,tree errlen)691 gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
692 tree token, tree status, tree errmsg, tree errlen)
693 {
694 tree tmp, pstat;
695
696 gcc_assert (token != NULL_TREE);
697
698 /* Evaluate size only once, and make sure it has the right type. */
699 size = gfc_evaluate_now (size, block);
700 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
701 size = fold_convert (size_type_node, size);
702
703 /* The allocation itself. */
704 if (status == NULL_TREE)
705 pstat = null_pointer_node;
706 else
707 pstat = gfc_build_addr_expr (NULL_TREE, status);
708
709 if (errmsg == NULL_TREE)
710 {
711 gcc_assert(errlen == NULL_TREE);
712 errmsg = null_pointer_node;
713 errlen = build_int_cst (integer_type_node, 0);
714 }
715
716 tmp = build_call_expr_loc (input_location,
717 gfor_fndecl_caf_register, 6,
718 fold_build2_loc (input_location,
719 MAX_EXPR, size_type_node, size,
720 build_int_cst (size_type_node, 1)),
721 build_int_cst (integer_type_node,
722 GFC_CAF_COARRAY_ALLOC),
723 token, pstat, errmsg, errlen);
724
725 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
726 TREE_TYPE (pointer), pointer,
727 fold_convert ( TREE_TYPE (pointer), tmp));
728 gfc_add_expr_to_block (block, tmp);
729 }
730
731
732 /* Generate code for an ALLOCATE statement when the argument is an
733 allocatable variable. If the variable is currently allocated, it is an
734 error to allocate it again.
735
736 This function follows the following pseudo-code:
737
738 void *
739 allocate_allocatable (void *mem, size_t size, integer_type stat)
740 {
741 if (mem == NULL)
742 return allocate (size, stat);
743 else
744 {
745 if (stat)
746 stat = LIBERROR_ALLOCATION;
747 else
748 runtime_error ("Attempting to allocate already allocated variable");
749 }
750 }
751
752 expr must be set to the original expression being allocated for its locus
753 and variable name in case a runtime error has to be printed. */
754 void
gfc_allocate_allocatable(stmtblock_t * block,tree mem,tree size,tree token,tree status,tree errmsg,tree errlen,tree label_finish,gfc_expr * expr)755 gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
756 tree status, tree errmsg, tree errlen, tree label_finish,
757 gfc_expr* expr)
758 {
759 stmtblock_t alloc_block;
760 tree tmp, null_mem, alloc, error;
761 tree type = TREE_TYPE (mem);
762
763 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
764 size = fold_convert (size_type_node, size);
765
766 null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
767 boolean_type_node, mem,
768 build_int_cst (type, 0)),
769 PRED_FORTRAN_FAIL_ALLOC);
770
771 /* If mem is NULL, we call gfc_allocate_using_malloc or
772 gfc_allocate_using_lib. */
773 gfc_start_block (&alloc_block);
774
775 if (gfc_option.coarray == GFC_FCOARRAY_LIB
776 && gfc_expr_attr (expr).codimension)
777 {
778 tree cond;
779
780 gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
781 errmsg, errlen);
782 if (status != NULL_TREE)
783 {
784 TREE_USED (label_finish) = 1;
785 tmp = build1_v (GOTO_EXPR, label_finish);
786 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
787 status, build_zero_cst (TREE_TYPE (status)));
788 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
789 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
790 tmp, build_empty_stmt (input_location));
791 gfc_add_expr_to_block (&alloc_block, tmp);
792 }
793 }
794 else
795 gfc_allocate_using_malloc (&alloc_block, mem, size, status);
796
797 alloc = gfc_finish_block (&alloc_block);
798
799 /* If mem is not NULL, we issue a runtime error or set the
800 status variable. */
801 if (expr)
802 {
803 tree varname;
804
805 gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
806 varname = gfc_build_cstring_const (expr->symtree->name);
807 varname = gfc_build_addr_expr (pchar_type_node, varname);
808
809 error = gfc_trans_runtime_error (true, &expr->where,
810 "Attempting to allocate already"
811 " allocated variable '%s'",
812 varname);
813 }
814 else
815 error = gfc_trans_runtime_error (true, NULL,
816 "Attempting to allocate already allocated"
817 " variable");
818
819 if (status != NULL_TREE)
820 {
821 tree status_type = TREE_TYPE (status);
822
823 error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
824 status, build_int_cst (status_type, LIBERROR_ALLOCATION));
825 }
826
827 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
828 error, alloc);
829 gfc_add_expr_to_block (block, tmp);
830 }
831
832
833 /* Free a given variable, if it's not NULL. */
834 tree
gfc_call_free(tree var)835 gfc_call_free (tree var)
836 {
837 stmtblock_t block;
838 tree tmp, cond, call;
839
840 if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
841 var = fold_convert (pvoid_type_node, var);
842
843 gfc_start_block (&block);
844 var = gfc_evaluate_now (var, &block);
845 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
846 build_int_cst (pvoid_type_node, 0));
847 call = build_call_expr_loc (input_location,
848 builtin_decl_explicit (BUILT_IN_FREE),
849 1, var);
850 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
851 build_empty_stmt (input_location));
852 gfc_add_expr_to_block (&block, tmp);
853
854 return gfc_finish_block (&block);
855 }
856
857
858 /* Build a call to a FINAL procedure, which finalizes "var". */
859
860 static tree
gfc_build_final_call(gfc_typespec ts,gfc_expr * final_wrapper,gfc_expr * var,bool fini_coarray,gfc_expr * class_size)861 gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
862 bool fini_coarray, gfc_expr *class_size)
863 {
864 stmtblock_t block;
865 gfc_se se;
866 tree final_fndecl, array, size, tmp;
867 symbol_attribute attr;
868
869 gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
870 gcc_assert (var);
871
872 gfc_start_block (&block);
873 gfc_init_se (&se, NULL);
874 gfc_conv_expr (&se, final_wrapper);
875 final_fndecl = se.expr;
876 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
877 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
878
879 if (ts.type == BT_DERIVED)
880 {
881 tree elem_size;
882
883 gcc_assert (!class_size);
884 elem_size = gfc_typenode_for_spec (&ts);
885 elem_size = TYPE_SIZE_UNIT (elem_size);
886 size = fold_convert (gfc_array_index_type, elem_size);
887
888 gfc_init_se (&se, NULL);
889 se.want_pointer = 1;
890 if (var->rank)
891 {
892 se.descriptor_only = 1;
893 gfc_conv_expr_descriptor (&se, var);
894 array = se.expr;
895 }
896 else
897 {
898 gfc_conv_expr (&se, var);
899 gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
900 array = se.expr;
901
902 /* No copy back needed, hence set attr's allocatable/pointer
903 to zero. */
904 gfc_clear_attr (&attr);
905 gfc_init_se (&se, NULL);
906 array = gfc_conv_scalar_to_descriptor (&se, array, attr);
907 gcc_assert (se.post.head == NULL_TREE);
908 }
909 }
910 else
911 {
912 gfc_expr *array_expr;
913 gcc_assert (class_size);
914 gfc_init_se (&se, NULL);
915 gfc_conv_expr (&se, class_size);
916 gfc_add_block_to_block (&block, &se.pre);
917 gcc_assert (se.post.head == NULL_TREE);
918 size = se.expr;
919
920 array_expr = gfc_copy_expr (var);
921 gfc_init_se (&se, NULL);
922 se.want_pointer = 1;
923 if (array_expr->rank)
924 {
925 gfc_add_class_array_ref (array_expr);
926 se.descriptor_only = 1;
927 gfc_conv_expr_descriptor (&se, array_expr);
928 array = se.expr;
929 }
930 else
931 {
932 gfc_add_data_component (array_expr);
933 gfc_conv_expr (&se, array_expr);
934 gfc_add_block_to_block (&block, &se.pre);
935 gcc_assert (se.post.head == NULL_TREE);
936 array = se.expr;
937 if (TREE_CODE (array) == ADDR_EXPR
938 && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
939 tmp = TREE_OPERAND (array, 0);
940
941 if (!gfc_is_coarray (array_expr))
942 {
943 /* No copy back needed, hence set attr's allocatable/pointer
944 to zero. */
945 gfc_clear_attr (&attr);
946 gfc_init_se (&se, NULL);
947 array = gfc_conv_scalar_to_descriptor (&se, array, attr);
948 }
949 gcc_assert (se.post.head == NULL_TREE);
950 }
951 gfc_free_expr (array_expr);
952 }
953
954 if (!POINTER_TYPE_P (TREE_TYPE (array)))
955 array = gfc_build_addr_expr (NULL, array);
956
957 gfc_add_block_to_block (&block, &se.pre);
958 tmp = build_call_expr_loc (input_location,
959 final_fndecl, 3, array,
960 size, fini_coarray ? boolean_true_node
961 : boolean_false_node);
962 gfc_add_block_to_block (&block, &se.post);
963 gfc_add_expr_to_block (&block, tmp);
964 return gfc_finish_block (&block);
965 }
966
967
968 bool
gfc_add_comp_finalizer_call(stmtblock_t * block,tree decl,gfc_component * comp,bool fini_coarray)969 gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
970 bool fini_coarray)
971 {
972 gfc_se se;
973 stmtblock_t block2;
974 tree final_fndecl, size, array, tmp, cond;
975 symbol_attribute attr;
976 gfc_expr *final_expr = NULL;
977
978 if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
979 return false;
980
981 gfc_init_block (&block2);
982
983 if (comp->ts.type == BT_DERIVED)
984 {
985 if (comp->attr.pointer)
986 return false;
987
988 gfc_is_finalizable (comp->ts.u.derived, &final_expr);
989 if (!final_expr)
990 return false;
991
992 gfc_init_se (&se, NULL);
993 gfc_conv_expr (&se, final_expr);
994 final_fndecl = se.expr;
995 size = gfc_typenode_for_spec (&comp->ts);
996 size = TYPE_SIZE_UNIT (size);
997 size = fold_convert (gfc_array_index_type, size);
998
999 array = decl;
1000 }
1001 else /* comp->ts.type == BT_CLASS. */
1002 {
1003 if (CLASS_DATA (comp)->attr.class_pointer)
1004 return false;
1005
1006 gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
1007 final_fndecl = gfc_vtable_final_get (decl);
1008 size = gfc_vtable_size_get (decl);
1009 array = gfc_class_data_get (decl);
1010 }
1011
1012 if (comp->attr.allocatable
1013 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
1014 {
1015 tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
1016 ? gfc_conv_descriptor_data_get (array) : array;
1017 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1018 tmp, fold_convert (TREE_TYPE (tmp),
1019 null_pointer_node));
1020 }
1021 else
1022 cond = boolean_true_node;
1023
1024 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
1025 {
1026 gfc_clear_attr (&attr);
1027 gfc_init_se (&se, NULL);
1028 array = gfc_conv_scalar_to_descriptor (&se, array, attr);
1029 gfc_add_block_to_block (&block2, &se.pre);
1030 gcc_assert (se.post.head == NULL_TREE);
1031 }
1032
1033 if (!POINTER_TYPE_P (TREE_TYPE (array)))
1034 array = gfc_build_addr_expr (NULL, array);
1035
1036 if (!final_expr)
1037 {
1038 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1039 final_fndecl,
1040 fold_convert (TREE_TYPE (final_fndecl),
1041 null_pointer_node));
1042 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1043 boolean_type_node, cond, tmp);
1044 }
1045
1046 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
1047 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
1048
1049 tmp = build_call_expr_loc (input_location,
1050 final_fndecl, 3, array,
1051 size, fini_coarray ? boolean_true_node
1052 : boolean_false_node);
1053 gfc_add_expr_to_block (&block2, tmp);
1054 tmp = gfc_finish_block (&block2);
1055
1056 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1057 build_empty_stmt (input_location));
1058 gfc_add_expr_to_block (block, tmp);
1059
1060 return true;
1061 }
1062
1063
1064 /* Add a call to the finalizer, using the passed *expr. Returns
1065 true when a finalizer call has been inserted. */
1066
1067 bool
gfc_add_finalizer_call(stmtblock_t * block,gfc_expr * expr2)1068 gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
1069 {
1070 tree tmp;
1071 gfc_ref *ref;
1072 gfc_expr *expr;
1073 gfc_expr *final_expr = NULL;
1074 gfc_expr *elem_size = NULL;
1075 bool has_finalizer = false;
1076
1077 if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
1078 return false;
1079
1080 if (expr2->ts.type == BT_DERIVED)
1081 {
1082 gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
1083 if (!final_expr)
1084 return false;
1085 }
1086
1087 /* If we have a class array, we need go back to the class
1088 container. */
1089 expr = gfc_copy_expr (expr2);
1090
1091 if (expr->ref && expr->ref->next && !expr->ref->next->next
1092 && expr->ref->next->type == REF_ARRAY
1093 && expr->ref->type == REF_COMPONENT
1094 && strcmp (expr->ref->u.c.component->name, "_data") == 0)
1095 {
1096 gfc_free_ref_list (expr->ref);
1097 expr->ref = NULL;
1098 }
1099 else
1100 for (ref = expr->ref; ref; ref = ref->next)
1101 if (ref->next && ref->next->next && !ref->next->next->next
1102 && ref->next->next->type == REF_ARRAY
1103 && ref->next->type == REF_COMPONENT
1104 && strcmp (ref->next->u.c.component->name, "_data") == 0)
1105 {
1106 gfc_free_ref_list (ref->next);
1107 ref->next = NULL;
1108 }
1109
1110 if (expr->ts.type == BT_CLASS)
1111 {
1112 has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
1113
1114 if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
1115 expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
1116
1117 final_expr = gfc_copy_expr (expr);
1118 gfc_add_vptr_component (final_expr);
1119 gfc_add_component_ref (final_expr, "_final");
1120
1121 elem_size = gfc_copy_expr (expr);
1122 gfc_add_vptr_component (elem_size);
1123 gfc_add_component_ref (elem_size, "_size");
1124 }
1125
1126 gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
1127
1128 tmp = gfc_build_final_call (expr->ts, final_expr, expr,
1129 false, elem_size);
1130
1131 if (expr->ts.type == BT_CLASS && !has_finalizer)
1132 {
1133 tree cond;
1134 gfc_se se;
1135
1136 gfc_init_se (&se, NULL);
1137 se.want_pointer = 1;
1138 gfc_conv_expr (&se, final_expr);
1139 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1140 se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
1141
1142 /* For CLASS(*) not only sym->_vtab->_final can be NULL
1143 but already sym->_vtab itself. */
1144 if (UNLIMITED_POLY (expr))
1145 {
1146 tree cond2;
1147 gfc_expr *vptr_expr;
1148
1149 vptr_expr = gfc_copy_expr (expr);
1150 gfc_add_vptr_component (vptr_expr);
1151
1152 gfc_init_se (&se, NULL);
1153 se.want_pointer = 1;
1154 gfc_conv_expr (&se, vptr_expr);
1155 gfc_free_expr (vptr_expr);
1156
1157 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1158 se.expr,
1159 build_int_cst (TREE_TYPE (se.expr), 0));
1160 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1161 boolean_type_node, cond2, cond);
1162 }
1163
1164 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1165 cond, tmp, build_empty_stmt (input_location));
1166 }
1167
1168 gfc_add_expr_to_block (block, tmp);
1169
1170 return true;
1171 }
1172
1173
1174 /* User-deallocate; we emit the code directly from the front-end, and the
1175 logic is the same as the previous library function:
1176
1177 void
1178 deallocate (void *pointer, GFC_INTEGER_4 * stat)
1179 {
1180 if (!pointer)
1181 {
1182 if (stat)
1183 *stat = 1;
1184 else
1185 runtime_error ("Attempt to DEALLOCATE unallocated memory.");
1186 }
1187 else
1188 {
1189 free (pointer);
1190 if (stat)
1191 *stat = 0;
1192 }
1193 }
1194
1195 In this front-end version, status doesn't have to be GFC_INTEGER_4.
1196 Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
1197 even when no status variable is passed to us (this is used for
1198 unconditional deallocation generated by the front-end at end of
1199 each procedure).
1200
1201 If a runtime-message is possible, `expr' must point to the original
1202 expression being deallocated for its locus and variable name.
1203
1204 For coarrays, "pointer" must be the array descriptor and not its
1205 "data" component. */
1206 tree
gfc_deallocate_with_status(tree pointer,tree status,tree errmsg,tree errlen,tree label_finish,bool can_fail,gfc_expr * expr,bool coarray)1207 gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
1208 tree errlen, tree label_finish,
1209 bool can_fail, gfc_expr* expr, bool coarray)
1210 {
1211 stmtblock_t null, non_null;
1212 tree cond, tmp, error;
1213 tree status_type = NULL_TREE;
1214 tree caf_decl = NULL_TREE;
1215
1216 if (coarray)
1217 {
1218 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
1219 caf_decl = pointer;
1220 pointer = gfc_conv_descriptor_data_get (caf_decl);
1221 STRIP_NOPS (pointer);
1222 }
1223
1224 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
1225 build_int_cst (TREE_TYPE (pointer), 0));
1226
1227 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1228 we emit a runtime error. */
1229 gfc_start_block (&null);
1230 if (!can_fail)
1231 {
1232 tree varname;
1233
1234 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1235
1236 varname = gfc_build_cstring_const (expr->symtree->name);
1237 varname = gfc_build_addr_expr (pchar_type_node, varname);
1238
1239 error = gfc_trans_runtime_error (true, &expr->where,
1240 "Attempt to DEALLOCATE unallocated '%s'",
1241 varname);
1242 }
1243 else
1244 error = build_empty_stmt (input_location);
1245
1246 if (status != NULL_TREE && !integer_zerop (status))
1247 {
1248 tree cond2;
1249
1250 status_type = TREE_TYPE (TREE_TYPE (status));
1251 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1252 status, build_int_cst (TREE_TYPE (status), 0));
1253 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1254 fold_build1_loc (input_location, INDIRECT_REF,
1255 status_type, status),
1256 build_int_cst (status_type, 1));
1257 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1258 cond2, tmp, error);
1259 }
1260
1261 gfc_add_expr_to_block (&null, error);
1262
1263 /* When POINTER is not NULL, we free it. */
1264 gfc_start_block (&non_null);
1265 gfc_add_finalizer_call (&non_null, expr);
1266 if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
1267 {
1268 tmp = build_call_expr_loc (input_location,
1269 builtin_decl_explicit (BUILT_IN_FREE), 1,
1270 fold_convert (pvoid_type_node, pointer));
1271 gfc_add_expr_to_block (&non_null, tmp);
1272
1273 if (status != NULL_TREE && !integer_zerop (status))
1274 {
1275 /* We set STATUS to zero if it is present. */
1276 tree status_type = TREE_TYPE (TREE_TYPE (status));
1277 tree cond2;
1278
1279 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1280 status,
1281 build_int_cst (TREE_TYPE (status), 0));
1282 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1283 fold_build1_loc (input_location, INDIRECT_REF,
1284 status_type, status),
1285 build_int_cst (status_type, 0));
1286 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1287 gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1288 tmp, build_empty_stmt (input_location));
1289 gfc_add_expr_to_block (&non_null, tmp);
1290 }
1291 }
1292 else
1293 {
1294 tree caf_type, token, cond2;
1295 tree pstat = null_pointer_node;
1296
1297 if (errmsg == NULL_TREE)
1298 {
1299 gcc_assert (errlen == NULL_TREE);
1300 errmsg = null_pointer_node;
1301 errlen = build_zero_cst (integer_type_node);
1302 }
1303 else
1304 {
1305 gcc_assert (errlen != NULL_TREE);
1306 if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
1307 errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
1308 }
1309
1310 caf_type = TREE_TYPE (caf_decl);
1311
1312 if (status != NULL_TREE && !integer_zerop (status))
1313 {
1314 gcc_assert (status_type == integer_type_node);
1315 pstat = status;
1316 }
1317
1318 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
1319 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
1320 token = gfc_conv_descriptor_token (caf_decl);
1321 else if (DECL_LANG_SPECIFIC (caf_decl)
1322 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1323 token = GFC_DECL_TOKEN (caf_decl);
1324 else
1325 {
1326 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
1327 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
1328 token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
1329 }
1330
1331 token = gfc_build_addr_expr (NULL_TREE, token);
1332 tmp = build_call_expr_loc (input_location,
1333 gfor_fndecl_caf_deregister, 4,
1334 token, pstat, errmsg, errlen);
1335 gfc_add_expr_to_block (&non_null, tmp);
1336
1337 if (status != NULL_TREE)
1338 {
1339 tree stat = build_fold_indirect_ref_loc (input_location, status);
1340
1341 TREE_USED (label_finish) = 1;
1342 tmp = build1_v (GOTO_EXPR, label_finish);
1343 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1344 stat, build_zero_cst (TREE_TYPE (stat)));
1345 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1346 gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC),
1347 tmp, build_empty_stmt (input_location));
1348 gfc_add_expr_to_block (&non_null, tmp);
1349 }
1350 }
1351
1352 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1353 gfc_finish_block (&null),
1354 gfc_finish_block (&non_null));
1355 }
1356
1357
1358 /* Generate code for deallocation of allocatable scalars (variables or
1359 components). Before the object itself is freed, any allocatable
1360 subcomponents are being deallocated. */
1361
1362 tree
gfc_deallocate_scalar_with_status(tree pointer,tree status,bool can_fail,gfc_expr * expr,gfc_typespec ts)1363 gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
1364 gfc_expr* expr, gfc_typespec ts)
1365 {
1366 stmtblock_t null, non_null;
1367 tree cond, tmp, error;
1368 bool finalizable;
1369
1370 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
1371 build_int_cst (TREE_TYPE (pointer), 0));
1372
1373 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
1374 we emit a runtime error. */
1375 gfc_start_block (&null);
1376 if (!can_fail)
1377 {
1378 tree varname;
1379
1380 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
1381
1382 varname = gfc_build_cstring_const (expr->symtree->name);
1383 varname = gfc_build_addr_expr (pchar_type_node, varname);
1384
1385 error = gfc_trans_runtime_error (true, &expr->where,
1386 "Attempt to DEALLOCATE unallocated '%s'",
1387 varname);
1388 }
1389 else
1390 error = build_empty_stmt (input_location);
1391
1392 if (status != NULL_TREE && !integer_zerop (status))
1393 {
1394 tree status_type = TREE_TYPE (TREE_TYPE (status));
1395 tree cond2;
1396
1397 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1398 status, build_int_cst (TREE_TYPE (status), 0));
1399 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1400 fold_build1_loc (input_location, INDIRECT_REF,
1401 status_type, status),
1402 build_int_cst (status_type, 1));
1403 error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1404 cond2, tmp, error);
1405 }
1406
1407 gfc_add_expr_to_block (&null, error);
1408
1409 /* When POINTER is not NULL, we free it. */
1410 gfc_start_block (&non_null);
1411
1412 /* Free allocatable components. */
1413 finalizable = gfc_add_finalizer_call (&non_null, expr);
1414 if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
1415 {
1416 tmp = build_fold_indirect_ref_loc (input_location, pointer);
1417 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
1418 gfc_add_expr_to_block (&non_null, tmp);
1419 }
1420
1421 tmp = build_call_expr_loc (input_location,
1422 builtin_decl_explicit (BUILT_IN_FREE), 1,
1423 fold_convert (pvoid_type_node, pointer));
1424 gfc_add_expr_to_block (&non_null, tmp);
1425
1426 if (status != NULL_TREE && !integer_zerop (status))
1427 {
1428 /* We set STATUS to zero if it is present. */
1429 tree status_type = TREE_TYPE (TREE_TYPE (status));
1430 tree cond2;
1431
1432 cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1433 status, build_int_cst (TREE_TYPE (status), 0));
1434 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1435 fold_build1_loc (input_location, INDIRECT_REF,
1436 status_type, status),
1437 build_int_cst (status_type, 0));
1438 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
1439 tmp, build_empty_stmt (input_location));
1440 gfc_add_expr_to_block (&non_null, tmp);
1441 }
1442
1443 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1444 gfc_finish_block (&null),
1445 gfc_finish_block (&non_null));
1446 }
1447
1448
1449 /* Reallocate MEM so it has SIZE bytes of data. This behaves like the
1450 following pseudo-code:
1451
1452 void *
1453 internal_realloc (void *mem, size_t size)
1454 {
1455 res = realloc (mem, size);
1456 if (!res && size != 0)
1457 _gfortran_os_error ("Allocation would exceed memory limit");
1458
1459 return res;
1460 } */
1461 tree
gfc_call_realloc(stmtblock_t * block,tree mem,tree size)1462 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
1463 {
1464 tree msg, res, nonzero, null_result, tmp;
1465 tree type = TREE_TYPE (mem);
1466
1467 size = gfc_evaluate_now (size, block);
1468
1469 if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
1470 size = fold_convert (size_type_node, size);
1471
1472 /* Create a variable to hold the result. */
1473 res = gfc_create_var (type, NULL);
1474
1475 /* Call realloc and check the result. */
1476 tmp = build_call_expr_loc (input_location,
1477 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
1478 fold_convert (pvoid_type_node, mem), size);
1479 gfc_add_modify (block, res, fold_convert (type, tmp));
1480 null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1481 res, build_int_cst (pvoid_type_node, 0));
1482 nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
1483 build_int_cst (size_type_node, 0));
1484 null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
1485 null_result, nonzero);
1486 msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1487 ("Allocation would exceed memory limit"));
1488 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1489 null_result,
1490 build_call_expr_loc (input_location,
1491 gfor_fndecl_os_error, 1, msg),
1492 build_empty_stmt (input_location));
1493 gfc_add_expr_to_block (block, tmp);
1494
1495 return res;
1496 }
1497
1498
1499 /* Add an expression to another one, either at the front or the back. */
1500
1501 static void
add_expr_to_chain(tree * chain,tree expr,bool front)1502 add_expr_to_chain (tree* chain, tree expr, bool front)
1503 {
1504 if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1505 return;
1506
1507 if (*chain)
1508 {
1509 if (TREE_CODE (*chain) != STATEMENT_LIST)
1510 {
1511 tree tmp;
1512
1513 tmp = *chain;
1514 *chain = NULL_TREE;
1515 append_to_statement_list (tmp, chain);
1516 }
1517
1518 if (front)
1519 {
1520 tree_stmt_iterator i;
1521
1522 i = tsi_start (*chain);
1523 tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
1524 }
1525 else
1526 append_to_statement_list (expr, chain);
1527 }
1528 else
1529 *chain = expr;
1530 }
1531
1532
1533 /* Add a statement at the end of a block. */
1534
1535 void
gfc_add_expr_to_block(stmtblock_t * block,tree expr)1536 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
1537 {
1538 gcc_assert (block);
1539 add_expr_to_chain (&block->head, expr, false);
1540 }
1541
1542
1543 /* Add a statement at the beginning of a block. */
1544
1545 void
gfc_prepend_expr_to_block(stmtblock_t * block,tree expr)1546 gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
1547 {
1548 gcc_assert (block);
1549 add_expr_to_chain (&block->head, expr, true);
1550 }
1551
1552
1553 /* Add a block the end of a block. */
1554
1555 void
gfc_add_block_to_block(stmtblock_t * block,stmtblock_t * append)1556 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1557 {
1558 gcc_assert (append);
1559 gcc_assert (!append->has_scope);
1560
1561 gfc_add_expr_to_block (block, append->head);
1562 append->head = NULL_TREE;
1563 }
1564
1565
1566 /* Save the current locus. The structure may not be complete, and should
1567 only be used with gfc_restore_backend_locus. */
1568
1569 void
gfc_save_backend_locus(locus * loc)1570 gfc_save_backend_locus (locus * loc)
1571 {
1572 loc->lb = XCNEW (gfc_linebuf);
1573 loc->lb->location = input_location;
1574 loc->lb->file = gfc_current_backend_file;
1575 }
1576
1577
1578 /* Set the current locus. */
1579
1580 void
gfc_set_backend_locus(locus * loc)1581 gfc_set_backend_locus (locus * loc)
1582 {
1583 gfc_current_backend_file = loc->lb->file;
1584 input_location = loc->lb->location;
1585 }
1586
1587
1588 /* Restore the saved locus. Only used in conjunction with
1589 gfc_save_backend_locus, to free the memory when we are done. */
1590
1591 void
gfc_restore_backend_locus(locus * loc)1592 gfc_restore_backend_locus (locus * loc)
1593 {
1594 gfc_set_backend_locus (loc);
1595 free (loc->lb);
1596 }
1597
1598
1599 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1600 This static function is wrapped by gfc_trans_code_cond and
1601 gfc_trans_code. */
1602
1603 static tree
trans_code(gfc_code * code,tree cond)1604 trans_code (gfc_code * code, tree cond)
1605 {
1606 stmtblock_t block;
1607 tree res;
1608
1609 if (!code)
1610 return build_empty_stmt (input_location);
1611
1612 gfc_start_block (&block);
1613
1614 /* Translate statements one by one into GENERIC trees until we reach
1615 the end of this gfc_code branch. */
1616 for (; code; code = code->next)
1617 {
1618 if (code->here != 0)
1619 {
1620 res = gfc_trans_label_here (code);
1621 gfc_add_expr_to_block (&block, res);
1622 }
1623
1624 gfc_set_backend_locus (&code->loc);
1625
1626 switch (code->op)
1627 {
1628 case EXEC_NOP:
1629 case EXEC_END_BLOCK:
1630 case EXEC_END_NESTED_BLOCK:
1631 case EXEC_END_PROCEDURE:
1632 res = NULL_TREE;
1633 break;
1634
1635 case EXEC_ASSIGN:
1636 if (code->expr1->ts.type == BT_CLASS)
1637 res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1638 else
1639 res = gfc_trans_assign (code);
1640 break;
1641
1642 case EXEC_LABEL_ASSIGN:
1643 res = gfc_trans_label_assign (code);
1644 break;
1645
1646 case EXEC_POINTER_ASSIGN:
1647 if (code->expr1->ts.type == BT_CLASS)
1648 res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1649 else if (UNLIMITED_POLY (code->expr2)
1650 && code->expr1->ts.type == BT_DERIVED
1651 && (code->expr1->ts.u.derived->attr.sequence
1652 || code->expr1->ts.u.derived->attr.is_bind_c))
1653 /* F2003: C717 */
1654 res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1655 else
1656 res = gfc_trans_pointer_assign (code);
1657 break;
1658
1659 case EXEC_INIT_ASSIGN:
1660 if (code->expr1->ts.type == BT_CLASS)
1661 res = gfc_trans_class_init_assign (code);
1662 else
1663 res = gfc_trans_init_assign (code);
1664 break;
1665
1666 case EXEC_CONTINUE:
1667 res = NULL_TREE;
1668 break;
1669
1670 case EXEC_CRITICAL:
1671 res = gfc_trans_critical (code);
1672 break;
1673
1674 case EXEC_CYCLE:
1675 res = gfc_trans_cycle (code);
1676 break;
1677
1678 case EXEC_EXIT:
1679 res = gfc_trans_exit (code);
1680 break;
1681
1682 case EXEC_GOTO:
1683 res = gfc_trans_goto (code);
1684 break;
1685
1686 case EXEC_ENTRY:
1687 res = gfc_trans_entry (code);
1688 break;
1689
1690 case EXEC_PAUSE:
1691 res = gfc_trans_pause (code);
1692 break;
1693
1694 case EXEC_STOP:
1695 case EXEC_ERROR_STOP:
1696 res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1697 break;
1698
1699 case EXEC_CALL:
1700 /* For MVBITS we've got the special exception that we need a
1701 dependency check, too. */
1702 {
1703 bool is_mvbits = false;
1704
1705 if (code->resolved_isym)
1706 {
1707 res = gfc_conv_intrinsic_subroutine (code);
1708 if (res != NULL_TREE)
1709 break;
1710 }
1711
1712 if (code->resolved_isym
1713 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1714 is_mvbits = true;
1715
1716 res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1717 NULL_TREE, false);
1718 }
1719 break;
1720
1721 case EXEC_CALL_PPC:
1722 res = gfc_trans_call (code, false, NULL_TREE,
1723 NULL_TREE, false);
1724 break;
1725
1726 case EXEC_ASSIGN_CALL:
1727 res = gfc_trans_call (code, true, NULL_TREE,
1728 NULL_TREE, false);
1729 break;
1730
1731 case EXEC_RETURN:
1732 res = gfc_trans_return (code);
1733 break;
1734
1735 case EXEC_IF:
1736 res = gfc_trans_if (code);
1737 break;
1738
1739 case EXEC_ARITHMETIC_IF:
1740 res = gfc_trans_arithmetic_if (code);
1741 break;
1742
1743 case EXEC_BLOCK:
1744 res = gfc_trans_block_construct (code);
1745 break;
1746
1747 case EXEC_DO:
1748 res = gfc_trans_do (code, cond);
1749 break;
1750
1751 case EXEC_DO_CONCURRENT:
1752 res = gfc_trans_do_concurrent (code);
1753 break;
1754
1755 case EXEC_DO_WHILE:
1756 res = gfc_trans_do_while (code);
1757 break;
1758
1759 case EXEC_SELECT:
1760 res = gfc_trans_select (code);
1761 break;
1762
1763 case EXEC_SELECT_TYPE:
1764 /* Do nothing. SELECT TYPE statements should be transformed into
1765 an ordinary SELECT CASE at resolution stage.
1766 TODO: Add an error message here once this is done. */
1767 res = NULL_TREE;
1768 break;
1769
1770 case EXEC_FLUSH:
1771 res = gfc_trans_flush (code);
1772 break;
1773
1774 case EXEC_SYNC_ALL:
1775 case EXEC_SYNC_IMAGES:
1776 case EXEC_SYNC_MEMORY:
1777 res = gfc_trans_sync (code, code->op);
1778 break;
1779
1780 case EXEC_LOCK:
1781 case EXEC_UNLOCK:
1782 res = gfc_trans_lock_unlock (code, code->op);
1783 break;
1784
1785 case EXEC_FORALL:
1786 res = gfc_trans_forall (code);
1787 break;
1788
1789 case EXEC_WHERE:
1790 res = gfc_trans_where (code);
1791 break;
1792
1793 case EXEC_ALLOCATE:
1794 res = gfc_trans_allocate (code);
1795 break;
1796
1797 case EXEC_DEALLOCATE:
1798 res = gfc_trans_deallocate (code);
1799 break;
1800
1801 case EXEC_OPEN:
1802 res = gfc_trans_open (code);
1803 break;
1804
1805 case EXEC_CLOSE:
1806 res = gfc_trans_close (code);
1807 break;
1808
1809 case EXEC_READ:
1810 res = gfc_trans_read (code);
1811 break;
1812
1813 case EXEC_WRITE:
1814 res = gfc_trans_write (code);
1815 break;
1816
1817 case EXEC_IOLENGTH:
1818 res = gfc_trans_iolength (code);
1819 break;
1820
1821 case EXEC_BACKSPACE:
1822 res = gfc_trans_backspace (code);
1823 break;
1824
1825 case EXEC_ENDFILE:
1826 res = gfc_trans_endfile (code);
1827 break;
1828
1829 case EXEC_INQUIRE:
1830 res = gfc_trans_inquire (code);
1831 break;
1832
1833 case EXEC_WAIT:
1834 res = gfc_trans_wait (code);
1835 break;
1836
1837 case EXEC_REWIND:
1838 res = gfc_trans_rewind (code);
1839 break;
1840
1841 case EXEC_TRANSFER:
1842 res = gfc_trans_transfer (code);
1843 break;
1844
1845 case EXEC_DT_END:
1846 res = gfc_trans_dt_end (code);
1847 break;
1848
1849 case EXEC_OMP_ATOMIC:
1850 case EXEC_OMP_BARRIER:
1851 case EXEC_OMP_CANCEL:
1852 case EXEC_OMP_CANCELLATION_POINT:
1853 case EXEC_OMP_CRITICAL:
1854 case EXEC_OMP_DISTRIBUTE:
1855 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
1856 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
1857 case EXEC_OMP_DISTRIBUTE_SIMD:
1858 case EXEC_OMP_DO:
1859 case EXEC_OMP_DO_SIMD:
1860 case EXEC_OMP_FLUSH:
1861 case EXEC_OMP_MASTER:
1862 case EXEC_OMP_ORDERED:
1863 case EXEC_OMP_PARALLEL:
1864 case EXEC_OMP_PARALLEL_DO:
1865 case EXEC_OMP_PARALLEL_DO_SIMD:
1866 case EXEC_OMP_PARALLEL_SECTIONS:
1867 case EXEC_OMP_PARALLEL_WORKSHARE:
1868 case EXEC_OMP_SECTIONS:
1869 case EXEC_OMP_SIMD:
1870 case EXEC_OMP_SINGLE:
1871 case EXEC_OMP_TARGET:
1872 case EXEC_OMP_TARGET_DATA:
1873 case EXEC_OMP_TARGET_TEAMS:
1874 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
1875 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1876 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1877 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1878 case EXEC_OMP_TARGET_UPDATE:
1879 case EXEC_OMP_TASK:
1880 case EXEC_OMP_TASKGROUP:
1881 case EXEC_OMP_TASKWAIT:
1882 case EXEC_OMP_TASKYIELD:
1883 case EXEC_OMP_TEAMS:
1884 case EXEC_OMP_TEAMS_DISTRIBUTE:
1885 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
1886 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1887 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
1888 case EXEC_OMP_WORKSHARE:
1889 res = gfc_trans_omp_directive (code);
1890 break;
1891
1892 default:
1893 internal_error ("gfc_trans_code(): Bad statement code");
1894 }
1895
1896 gfc_set_backend_locus (&code->loc);
1897
1898 if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1899 {
1900 if (TREE_CODE (res) != STATEMENT_LIST)
1901 SET_EXPR_LOCATION (res, input_location);
1902
1903 /* Add the new statement to the block. */
1904 gfc_add_expr_to_block (&block, res);
1905 }
1906 }
1907
1908 /* Return the finished block. */
1909 return gfc_finish_block (&block);
1910 }
1911
1912
1913 /* Translate an executable statement with condition, cond. The condition is
1914 used by gfc_trans_do to test for IO result conditions inside implied
1915 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
1916
1917 tree
gfc_trans_code_cond(gfc_code * code,tree cond)1918 gfc_trans_code_cond (gfc_code * code, tree cond)
1919 {
1920 return trans_code (code, cond);
1921 }
1922
1923 /* Translate an executable statement without condition. */
1924
1925 tree
gfc_trans_code(gfc_code * code)1926 gfc_trans_code (gfc_code * code)
1927 {
1928 return trans_code (code, NULL_TREE);
1929 }
1930
1931
1932 /* This function is called after a complete program unit has been parsed
1933 and resolved. */
1934
1935 void
gfc_generate_code(gfc_namespace * ns)1936 gfc_generate_code (gfc_namespace * ns)
1937 {
1938 ompws_flags = 0;
1939 if (ns->is_block_data)
1940 {
1941 gfc_generate_block_data (ns);
1942 return;
1943 }
1944
1945 gfc_generate_function_code (ns);
1946 }
1947
1948
1949 /* This function is called after a complete module has been parsed
1950 and resolved. */
1951
1952 void
gfc_generate_module_code(gfc_namespace * ns)1953 gfc_generate_module_code (gfc_namespace * ns)
1954 {
1955 gfc_namespace *n;
1956 struct module_htab_entry *entry;
1957
1958 gcc_assert (ns->proc_name->backend_decl == NULL);
1959 ns->proc_name->backend_decl
1960 = build_decl (ns->proc_name->declared_at.lb->location,
1961 NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1962 void_type_node);
1963 entry = gfc_find_module (ns->proc_name->name);
1964 if (entry->namespace_decl)
1965 /* Buggy sourcecode, using a module before defining it? */
1966 htab_empty (entry->decls);
1967 entry->namespace_decl = ns->proc_name->backend_decl;
1968
1969 gfc_generate_module_vars (ns);
1970
1971 /* We need to generate all module function prototypes first, to allow
1972 sibling calls. */
1973 for (n = ns->contained; n; n = n->sibling)
1974 {
1975 gfc_entry_list *el;
1976
1977 if (!n->proc_name)
1978 continue;
1979
1980 gfc_create_function_decl (n, false);
1981 DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1982 gfc_module_add_decl (entry, n->proc_name->backend_decl);
1983 for (el = ns->entries; el; el = el->next)
1984 {
1985 DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1986 gfc_module_add_decl (entry, el->sym->backend_decl);
1987 }
1988 }
1989
1990 for (n = ns->contained; n; n = n->sibling)
1991 {
1992 if (!n->proc_name)
1993 continue;
1994
1995 gfc_generate_function_code (n);
1996 }
1997 }
1998
1999
2000 /* Initialize an init/cleanup block with existing code. */
2001
2002 void
gfc_start_wrapped_block(gfc_wrapped_block * block,tree code)2003 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
2004 {
2005 gcc_assert (block);
2006
2007 block->init = NULL_TREE;
2008 block->code = code;
2009 block->cleanup = NULL_TREE;
2010 }
2011
2012
2013 /* Add a new pair of initializers/clean-up code. */
2014
2015 void
gfc_add_init_cleanup(gfc_wrapped_block * block,tree init,tree cleanup)2016 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
2017 {
2018 gcc_assert (block);
2019
2020 /* The new pair of init/cleanup should be "wrapped around" the existing
2021 block of code, thus the initialization is added to the front and the
2022 cleanup to the back. */
2023 add_expr_to_chain (&block->init, init, true);
2024 add_expr_to_chain (&block->cleanup, cleanup, false);
2025 }
2026
2027
2028 /* Finish up a wrapped block by building a corresponding try-finally expr. */
2029
2030 tree
gfc_finish_wrapped_block(gfc_wrapped_block * block)2031 gfc_finish_wrapped_block (gfc_wrapped_block* block)
2032 {
2033 tree result;
2034
2035 gcc_assert (block);
2036
2037 /* Build the final expression. For this, just add init and body together,
2038 and put clean-up with that into a TRY_FINALLY_EXPR. */
2039 result = block->init;
2040 add_expr_to_chain (&result, block->code, false);
2041 if (block->cleanup)
2042 result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
2043 result, block->cleanup);
2044
2045 /* Clear the block. */
2046 block->init = NULL_TREE;
2047 block->code = NULL_TREE;
2048 block->cleanup = NULL_TREE;
2049
2050 return result;
2051 }
2052
2053
2054 /* Helper function for marking a boolean expression tree as unlikely. */
2055
2056 tree
gfc_unlikely(tree cond,enum br_predictor predictor)2057 gfc_unlikely (tree cond, enum br_predictor predictor)
2058 {
2059 tree tmp;
2060
2061 if (optimize)
2062 {
2063 cond = fold_convert (long_integer_type_node, cond);
2064 tmp = build_zero_cst (long_integer_type_node);
2065 cond = build_call_expr_loc (input_location,
2066 builtin_decl_explicit (BUILT_IN_EXPECT),
2067 3, cond, tmp,
2068 build_int_cst (integer_type_node,
2069 predictor));
2070 }
2071 cond = fold_convert (boolean_type_node, cond);
2072 return cond;
2073 }
2074
2075
2076 /* Helper function for marking a boolean expression tree as likely. */
2077
2078 tree
gfc_likely(tree cond,enum br_predictor predictor)2079 gfc_likely (tree cond, enum br_predictor predictor)
2080 {
2081 tree tmp;
2082
2083 if (optimize)
2084 {
2085 cond = fold_convert (long_integer_type_node, cond);
2086 tmp = build_one_cst (long_integer_type_node);
2087 cond = build_call_expr_loc (input_location,
2088 builtin_decl_explicit (BUILT_IN_EXPECT),
2089 3, cond, tmp,
2090 build_int_cst (integer_type_node,
2091 predictor));
2092 }
2093 cond = fold_convert (boolean_type_node, cond);
2094 return cond;
2095 }
2096
2097
2098 /* Get the string length for a deferred character length component. */
2099
2100 bool
gfc_deferred_strlen(gfc_component * c,tree * decl)2101 gfc_deferred_strlen (gfc_component *c, tree *decl)
2102 {
2103 char name[GFC_MAX_SYMBOL_LEN+9];
2104 gfc_component *strlen;
2105 if (!(c->ts.type == BT_CHARACTER && c->ts.deferred))
2106 return false;
2107 sprintf (name, "_%s_length", c->name);
2108 for (strlen = c; strlen; strlen = strlen->next)
2109 if (strcmp (strlen->name, name) == 0)
2110 break;
2111 *decl = strlen ? strlen->backend_decl : NULL_TREE;
2112 return strlen != NULL;
2113 }
2114