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