]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Code translation -- generate GCC trees from gfc_code. |
fa502cb2 PT |
2 | Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 |
3 | Free Software Foundation, Inc. | |
6de9cd9a DN |
4 | Contributed by Paul Brook |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
d234d788 | 10 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 11 | version. |
6de9cd9a | 12 | |
9fc4d79b TS |
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
19 | along with GCC; see the file COPYING3. If not see |
20 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a DN |
21 | |
22 | #include "config.h" | |
23 | #include "system.h" | |
24 | #include "coretypes.h" | |
25 | #include "tree.h" | |
a48ba7e1 | 26 | #include "gimple.h" /* For create_tmp_var_raw. */ |
726a989a | 27 | #include "tree-iterator.h" |
c829d016 | 28 | #include "diagnostic-core.h" /* For internal_error. */ |
6de9cd9a | 29 | #include "defaults.h" |
1529b8d9 | 30 | #include "flags.h" |
6de9cd9a DN |
31 | #include "gfortran.h" |
32 | #include "trans.h" | |
33 | #include "trans-stmt.h" | |
34 | #include "trans-array.h" | |
35 | #include "trans-types.h" | |
36 | #include "trans-const.h" | |
37 | ||
38 | /* Naming convention for backend interface code: | |
39 | ||
40 | gfc_trans_* translate gfc_code into STMT trees. | |
41 | ||
42 | gfc_conv_* expression conversion | |
43 | ||
44 | gfc_get_* get a backend tree representation of a decl or type */ | |
45 | ||
46 | static gfc_file *gfc_current_backend_file; | |
47 | ||
7e49f965 TS |
48 | const char gfc_msg_fault[] = N_("Array reference out of bounds"); |
49 | const char gfc_msg_wrong_return[] = N_("Incorrect function return value"); | |
dd18a33b | 50 | |
6de9cd9a DN |
51 | |
52 | /* Advance along TREE_CHAIN n times. */ | |
53 | ||
54 | tree | |
55 | gfc_advance_chain (tree t, int n) | |
56 | { | |
57 | for (; n > 0; n--) | |
58 | { | |
6e45f57b | 59 | gcc_assert (t != NULL_TREE); |
910ad8de | 60 | t = DECL_CHAIN (t); |
6de9cd9a DN |
61 | } |
62 | return t; | |
63 | } | |
64 | ||
65 | ||
66 | /* Wrap a node in a TREE_LIST node and add it to the end of a list. */ | |
67 | ||
68 | tree | |
69 | gfc_chainon_list (tree list, tree add) | |
70 | { | |
71 | tree l; | |
72 | ||
73 | l = tree_cons (NULL_TREE, add, NULL_TREE); | |
74 | ||
75 | return chainon (list, l); | |
76 | } | |
77 | ||
78 | ||
79 | /* Strip off a legitimate source ending from the input | |
80 | string NAME of length LEN. */ | |
81 | ||
82 | static inline void | |
83 | remove_suffix (char *name, int len) | |
84 | { | |
85 | int i; | |
86 | ||
87 | for (i = 2; i < 8 && len > i; i++) | |
88 | { | |
89 | if (name[len - i] == '.') | |
90 | { | |
91 | name[len - i] = '\0'; | |
92 | break; | |
93 | } | |
94 | } | |
95 | } | |
96 | ||
97 | ||
98 | /* Creates a variable declaration with a given TYPE. */ | |
99 | ||
100 | tree | |
101 | gfc_create_var_np (tree type, const char *prefix) | |
102 | { | |
049e4fb0 FXC |
103 | tree t; |
104 | ||
105 | t = create_tmp_var_raw (type, prefix); | |
106 | ||
107 | /* No warnings for anonymous variables. */ | |
108 | if (prefix == NULL) | |
109 | TREE_NO_WARNING (t) = 1; | |
110 | ||
111 | return t; | |
6de9cd9a DN |
112 | } |
113 | ||
114 | ||
115 | /* Like above, but also adds it to the current scope. */ | |
116 | ||
117 | tree | |
118 | gfc_create_var (tree type, const char *prefix) | |
119 | { | |
120 | tree tmp; | |
121 | ||
122 | tmp = gfc_create_var_np (type, prefix); | |
123 | ||
124 | pushdecl (tmp); | |
125 | ||
126 | return tmp; | |
127 | } | |
128 | ||
129 | ||
df2fba9e | 130 | /* If the expression is not constant, evaluate it now. We assign the |
6de9cd9a DN |
131 | result of the expression to an artificially created variable VAR, and |
132 | return a pointer to the VAR_DECL node for this variable. */ | |
133 | ||
134 | tree | |
55bd9c35 | 135 | gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock) |
6de9cd9a DN |
136 | { |
137 | tree var; | |
138 | ||
6615c446 | 139 | if (CONSTANT_CLASS_P (expr)) |
6de9cd9a DN |
140 | return expr; |
141 | ||
142 | var = gfc_create_var (TREE_TYPE (expr), NULL); | |
55bd9c35 | 143 | gfc_add_modify_loc (loc, pblock, var, expr); |
6de9cd9a DN |
144 | |
145 | return var; | |
146 | } | |
147 | ||
148 | ||
55bd9c35 TB |
149 | tree |
150 | gfc_evaluate_now (tree expr, stmtblock_t * pblock) | |
151 | { | |
152 | return gfc_evaluate_now_loc (input_location, expr, pblock); | |
153 | } | |
154 | ||
155 | ||
726a989a RB |
156 | /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. |
157 | A MODIFY_EXPR is an assignment: | |
07beea0d | 158 | LHS <- RHS. */ |
6de9cd9a DN |
159 | |
160 | void | |
55bd9c35 | 161 | gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs) |
6de9cd9a DN |
162 | { |
163 | tree tmp; | |
164 | ||
7ab92584 | 165 | #ifdef ENABLE_CHECKING |
10174ddf MM |
166 | tree t1, t2; |
167 | t1 = TREE_TYPE (rhs); | |
168 | t2 = TREE_TYPE (lhs); | |
7ab92584 SB |
169 | /* Make sure that the types of the rhs and the lhs are the same |
170 | for scalar assignments. We should probably have something | |
171 | similar for aggregates, but right now removing that check just | |
172 | breaks everything. */ | |
10174ddf | 173 | gcc_assert (t1 == t2 |
6e45f57b | 174 | || AGGREGATE_TYPE_P (TREE_TYPE (lhs))); |
7ab92584 SB |
175 | #endif |
176 | ||
55bd9c35 | 177 | tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs, |
65a9ca82 | 178 | rhs); |
6de9cd9a DN |
179 | gfc_add_expr_to_block (pblock, tmp); |
180 | } | |
181 | ||
182 | ||
55bd9c35 TB |
183 | void |
184 | gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs) | |
185 | { | |
186 | gfc_add_modify_loc (input_location, pblock, lhs, rhs); | |
187 | } | |
188 | ||
189 | ||
6de9cd9a | 190 | /* Create a new scope/binding level and initialize a block. Care must be |
1f2959f0 | 191 | taken when translating expressions as any temporaries will be placed in |
6de9cd9a DN |
192 | the innermost scope. */ |
193 | ||
194 | void | |
195 | gfc_start_block (stmtblock_t * block) | |
196 | { | |
197 | /* Start a new binding level. */ | |
198 | pushlevel (0); | |
199 | block->has_scope = 1; | |
200 | ||
201 | /* The block is empty. */ | |
202 | block->head = NULL_TREE; | |
203 | } | |
204 | ||
205 | ||
206 | /* Initialize a block without creating a new scope. */ | |
207 | ||
208 | void | |
209 | gfc_init_block (stmtblock_t * block) | |
210 | { | |
211 | block->head = NULL_TREE; | |
212 | block->has_scope = 0; | |
213 | } | |
214 | ||
215 | ||
216 | /* Sometimes we create a scope but it turns out that we don't actually | |
217 | need it. This function merges the scope of BLOCK with its parent. | |
218 | Only variable decls will be merged, you still need to add the code. */ | |
219 | ||
220 | void | |
221 | gfc_merge_block_scope (stmtblock_t * block) | |
222 | { | |
223 | tree decl; | |
224 | tree next; | |
225 | ||
6e45f57b | 226 | gcc_assert (block->has_scope); |
6de9cd9a DN |
227 | block->has_scope = 0; |
228 | ||
229 | /* Remember the decls in this scope. */ | |
230 | decl = getdecls (); | |
231 | poplevel (0, 0, 0); | |
232 | ||
233 | /* Add them to the parent scope. */ | |
234 | while (decl != NULL_TREE) | |
235 | { | |
910ad8de NF |
236 | next = DECL_CHAIN (decl); |
237 | DECL_CHAIN (decl) = NULL_TREE; | |
6de9cd9a DN |
238 | |
239 | pushdecl (decl); | |
240 | decl = next; | |
241 | } | |
242 | } | |
243 | ||
244 | ||
245 | /* Finish a scope containing a block of statements. */ | |
246 | ||
247 | tree | |
248 | gfc_finish_block (stmtblock_t * stmtblock) | |
249 | { | |
250 | tree decl; | |
251 | tree expr; | |
252 | tree block; | |
253 | ||
7c87eac6 PB |
254 | expr = stmtblock->head; |
255 | if (!expr) | |
c2255bc4 | 256 | expr = build_empty_stmt (input_location); |
7c87eac6 | 257 | |
6de9cd9a DN |
258 | stmtblock->head = NULL_TREE; |
259 | ||
260 | if (stmtblock->has_scope) | |
261 | { | |
262 | decl = getdecls (); | |
263 | ||
264 | if (decl) | |
265 | { | |
266 | block = poplevel (1, 0, 0); | |
923ab88c | 267 | expr = build3_v (BIND_EXPR, decl, expr, block); |
6de9cd9a DN |
268 | } |
269 | else | |
270 | poplevel (0, 0, 0); | |
271 | } | |
272 | ||
273 | return expr; | |
274 | } | |
275 | ||
276 | ||
277 | /* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the | |
278 | natural type is used. */ | |
279 | ||
280 | tree | |
281 | gfc_build_addr_expr (tree type, tree t) | |
282 | { | |
283 | tree base_type = TREE_TYPE (t); | |
284 | tree natural_type; | |
285 | ||
286 | if (type && POINTER_TYPE_P (type) | |
287 | && TREE_CODE (base_type) == ARRAY_TYPE | |
288 | && TYPE_MAIN_VARIANT (TREE_TYPE (type)) | |
289 | == TYPE_MAIN_VARIANT (TREE_TYPE (base_type))) | |
543535a3 AP |
290 | { |
291 | tree min_val = size_zero_node; | |
292 | tree type_domain = TYPE_DOMAIN (base_type); | |
293 | if (type_domain && TYPE_MIN_VALUE (type_domain)) | |
294 | min_val = TYPE_MIN_VALUE (type_domain); | |
5d44e5c8 TB |
295 | t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type), |
296 | t, min_val, NULL_TREE, NULL_TREE)); | |
543535a3 AP |
297 | natural_type = type; |
298 | } | |
6de9cd9a DN |
299 | else |
300 | natural_type = build_pointer_type (base_type); | |
301 | ||
302 | if (TREE_CODE (t) == INDIRECT_REF) | |
303 | { | |
304 | if (!type) | |
305 | type = natural_type; | |
306 | t = TREE_OPERAND (t, 0); | |
307 | natural_type = TREE_TYPE (t); | |
308 | } | |
309 | else | |
310 | { | |
628c189e RG |
311 | tree base = get_base_address (t); |
312 | if (base && DECL_P (base)) | |
313 | TREE_ADDRESSABLE (base) = 1; | |
65a9ca82 | 314 | t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t); |
6de9cd9a DN |
315 | } |
316 | ||
317 | if (type && natural_type != type) | |
318 | t = convert (type, t); | |
319 | ||
320 | return t; | |
321 | } | |
322 | ||
323 | ||
6de9cd9a DN |
324 | /* Build an ARRAY_REF with its natural type. */ |
325 | ||
326 | tree | |
1d6b7f39 | 327 | gfc_build_array_ref (tree base, tree offset, tree decl) |
6de9cd9a DN |
328 | { |
329 | tree type = TREE_TYPE (base); | |
1d6b7f39 PT |
330 | tree tmp; |
331 | ||
6e45f57b | 332 | gcc_assert (TREE_CODE (type) == ARRAY_TYPE); |
6de9cd9a DN |
333 | type = TREE_TYPE (type); |
334 | ||
335 | if (DECL_P (base)) | |
336 | TREE_ADDRESSABLE (base) = 1; | |
337 | ||
31120e8f RS |
338 | /* Strip NON_LVALUE_EXPR nodes. */ |
339 | STRIP_TYPE_NOPS (offset); | |
340 | ||
1d6b7f39 PT |
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 | { | |
65a9ca82 TB |
350 | offset = fold_build2_loc (input_location, MULT_EXPR, |
351 | gfc_array_index_type, | |
352 | offset, GFC_DECL_SPAN(decl)); | |
1d6b7f39 | 353 | tmp = gfc_build_addr_expr (pvoid_type_node, base); |
65a9ca82 TB |
354 | tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR, |
355 | pvoid_type_node, tmp, | |
356 | fold_convert (sizetype, offset)); | |
1d6b7f39 PT |
357 | tmp = fold_convert (build_pointer_type (type), tmp); |
358 | if (!TYPE_STRING_FLAG (type)) | |
db3927fb | 359 | tmp = build_fold_indirect_ref_loc (input_location, tmp); |
1d6b7f39 PT |
360 | return tmp; |
361 | } | |
362 | else | |
363 | /* Otherwise use a straightforward array reference. */ | |
5d44e5c8 TB |
364 | return build4_loc (input_location, ARRAY_REF, type, base, offset, |
365 | NULL_TREE, NULL_TREE); | |
6de9cd9a DN |
366 | } |
367 | ||
368 | ||
f25a62a5 DK |
369 | /* Generate a call to print a runtime error possibly including multiple |
370 | arguments and a locus. */ | |
6de9cd9a | 371 | |
55bd9c35 TB |
372 | static tree |
373 | trans_runtime_error_vararg (bool error, locus* where, const char* msgid, | |
374 | va_list ap) | |
f25a62a5 | 375 | { |
6de9cd9a | 376 | stmtblock_t block; |
6de9cd9a | 377 | tree tmp; |
f96d606f | 378 | tree arg, arg2; |
c8fe94c7 FXC |
379 | tree *argarray; |
380 | tree fntype; | |
f96d606f | 381 | char *message; |
c8fe94c7 FXC |
382 | const char *p; |
383 | int line, nargs, i; | |
55bd9c35 | 384 | location_t loc; |
6de9cd9a | 385 | |
c8fe94c7 FXC |
386 | /* Compute the number of extra arguments from the format string. */ |
387 | for (p = msgid, nargs = 0; *p; p++) | |
388 | if (*p == '%') | |
389 | { | |
390 | p++; | |
391 | if (*p != '%') | |
392 | nargs++; | |
393 | } | |
394 | ||
6de9cd9a DN |
395 | /* The code to generate the error. */ |
396 | gfc_start_block (&block); | |
397 | ||
dd18a33b FXC |
398 | if (where) |
399 | { | |
dd18a33b | 400 | line = LOCATION_LINE (where->lb->location); |
f96d606f JD |
401 | asprintf (&message, "At line %d of file %s", line, |
402 | where->lb->file->filename); | |
dd18a33b FXC |
403 | } |
404 | else | |
f96d606f | 405 | asprintf (&message, "In file '%s', around line %d", |
dd18a33b | 406 | gfc_source_file, input_line + 1); |
6de9cd9a | 407 | |
ee37d2f5 FXC |
408 | arg = gfc_build_addr_expr (pchar_type_node, |
409 | gfc_build_localized_cstring_const (message)); | |
dd18a33b | 410 | gfc_free(message); |
f96d606f JD |
411 | |
412 | asprintf (&message, "%s", _(msgid)); | |
ee37d2f5 FXC |
413 | arg2 = gfc_build_addr_expr (pchar_type_node, |
414 | gfc_build_localized_cstring_const (message)); | |
f96d606f | 415 | gfc_free(message); |
6de9cd9a | 416 | |
c8fe94c7 | 417 | /* Build the argument array. */ |
1145e690 | 418 | argarray = XALLOCAVEC (tree, nargs + 2); |
c8fe94c7 FXC |
419 | argarray[0] = arg; |
420 | argarray[1] = arg2; | |
c8fe94c7 | 421 | for (i = 0; i < nargs; i++) |
f25a62a5 | 422 | argarray[2 + i] = va_arg (ap, tree); |
c8fe94c7 | 423 | |
0d52899f | 424 | /* Build the function call to runtime_(warning,error)_at; because of the |
db3927fb AH |
425 | variable number of arguments, we can't use build_call_expr_loc dinput_location, |
426 | irectly. */ | |
0d52899f TB |
427 | if (error) |
428 | fntype = TREE_TYPE (gfor_fndecl_runtime_error_at); | |
429 | else | |
430 | fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at); | |
431 | ||
55bd9c35 TB |
432 | loc = where ? where->lb->location : input_location; |
433 | tmp = fold_builtin_call_array (loc, TREE_TYPE (fntype), | |
434 | fold_build1_loc (loc, ADDR_EXPR, | |
65a9ca82 TB |
435 | build_pointer_type (fntype), |
436 | error | |
437 | ? gfor_fndecl_runtime_error_at | |
438 | : gfor_fndecl_runtime_warning_at), | |
c8fe94c7 | 439 | nargs + 2, argarray); |
6de9cd9a DN |
440 | gfc_add_expr_to_block (&block, tmp); |
441 | ||
f25a62a5 DK |
442 | return gfc_finish_block (&block); |
443 | } | |
444 | ||
445 | ||
55bd9c35 TB |
446 | tree |
447 | gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...) | |
448 | { | |
449 | va_list ap; | |
450 | tree result; | |
451 | ||
452 | va_start (ap, msgid); | |
453 | result = trans_runtime_error_vararg (error, where, msgid, ap); | |
454 | va_end (ap); | |
455 | return result; | |
456 | } | |
457 | ||
458 | ||
f25a62a5 DK |
459 | /* Generate a runtime error if COND is true. */ |
460 | ||
461 | void | |
462 | gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, | |
463 | locus * where, const char * msgid, ...) | |
464 | { | |
465 | va_list ap; | |
466 | stmtblock_t block; | |
467 | tree body; | |
468 | tree tmp; | |
469 | tree tmpvar = NULL; | |
470 | ||
471 | if (integer_zerop (cond)) | |
472 | return; | |
473 | ||
474 | if (once) | |
475 | { | |
476 | tmpvar = gfc_create_var (boolean_type_node, "print_warning"); | |
477 | TREE_STATIC (tmpvar) = 1; | |
478 | DECL_INITIAL (tmpvar) = boolean_true_node; | |
479 | gfc_add_expr_to_block (pblock, tmpvar); | |
480 | } | |
481 | ||
482 | gfc_start_block (&block); | |
483 | ||
484 | /* The code to generate the error. */ | |
485 | va_start (ap, msgid); | |
486 | gfc_add_expr_to_block (&block, | |
55bd9c35 TB |
487 | trans_runtime_error_vararg (error, where, |
488 | msgid, ap)); | |
f25a62a5 | 489 | |
0d52899f | 490 | if (once) |
726a989a | 491 | gfc_add_modify (&block, tmpvar, boolean_false_node); |
0d52899f | 492 | |
6de9cd9a DN |
493 | body = gfc_finish_block (&block); |
494 | ||
495 | if (integer_onep (cond)) | |
496 | { | |
497 | gfc_add_expr_to_block (pblock, body); | |
498 | } | |
499 | else | |
500 | { | |
472ca416 | 501 | /* Tell the compiler that this isn't likely. */ |
0d52899f | 502 | if (once) |
55bd9c35 | 503 | cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR, |
65a9ca82 | 504 | long_integer_type_node, tmpvar, cond); |
0d52899f TB |
505 | else |
506 | cond = fold_convert (long_integer_type_node, cond); | |
507 | ||
5af07930 | 508 | cond = gfc_unlikely (cond); |
55bd9c35 TB |
509 | tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node, |
510 | cond, body, | |
511 | build_empty_stmt (where->lb->location)); | |
6de9cd9a DN |
512 | gfc_add_expr_to_block (pblock, tmp); |
513 | } | |
514 | } | |
515 | ||
516 | ||
1529b8d9 | 517 | /* Call malloc to allocate size bytes of memory, with special conditions: |
da17cbb7 | 518 | + if size == 0, return a malloced area of size 1, |
1529b8d9 FXC |
519 | + if malloc returns NULL, issue a runtime error. */ |
520 | tree | |
521 | gfc_call_malloc (stmtblock_t * block, tree type, tree size) | |
522 | { | |
22bdbb0f | 523 | tree tmp, msg, malloc_result, null_result, res; |
1529b8d9 FXC |
524 | stmtblock_t block2; |
525 | ||
526 | size = gfc_evaluate_now (size, block); | |
527 | ||
528 | if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) | |
529 | size = fold_convert (size_type_node, size); | |
530 | ||
531 | /* Create a variable to hold the result. */ | |
10174ddf | 532 | res = gfc_create_var (prvoid_type_node, NULL); |
1529b8d9 | 533 | |
22bdbb0f | 534 | /* Call malloc. */ |
1529b8d9 | 535 | gfc_start_block (&block2); |
8f0aaee5 | 536 | |
65a9ca82 TB |
537 | size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, |
538 | build_int_cst (size_type_node, 1)); | |
8f0aaee5 | 539 | |
726a989a | 540 | gfc_add_modify (&block2, res, |
10174ddf MM |
541 | fold_convert (prvoid_type_node, |
542 | build_call_expr_loc (input_location, | |
543 | built_in_decls[BUILT_IN_MALLOC], 1, size))); | |
22bdbb0f TB |
544 | |
545 | /* Optionally check whether malloc was successful. */ | |
546 | if (gfc_option.rtcheck & GFC_RTCHECK_MEM) | |
547 | { | |
65a9ca82 TB |
548 | null_result = fold_build2_loc (input_location, EQ_EXPR, |
549 | boolean_type_node, res, | |
550 | build_int_cst (pvoid_type_node, 0)); | |
22bdbb0f TB |
551 | msg = gfc_build_addr_expr (pchar_type_node, |
552 | gfc_build_localized_cstring_const ("Memory allocation failed")); | |
65a9ca82 TB |
553 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
554 | null_result, | |
22bdbb0f TB |
555 | build_call_expr_loc (input_location, |
556 | gfor_fndecl_os_error, 1, msg), | |
557 | build_empty_stmt (input_location)); | |
558 | gfc_add_expr_to_block (&block2, tmp); | |
559 | } | |
560 | ||
1529b8d9 FXC |
561 | malloc_result = gfc_finish_block (&block2); |
562 | ||
8f0aaee5 | 563 | gfc_add_expr_to_block (block, malloc_result); |
1529b8d9 FXC |
564 | |
565 | if (type != NULL) | |
566 | res = fold_convert (type, res); | |
567 | return res; | |
568 | } | |
569 | ||
22bdbb0f | 570 | |
4376b7cf FXC |
571 | /* Allocate memory, using an optional status argument. |
572 | ||
573 | This function follows the following pseudo-code: | |
574 | ||
575 | void * | |
576 | allocate (size_t size, integer_type* stat) | |
577 | { | |
578 | void *newmem; | |
579 | ||
580 | if (stat) | |
f25a62a5 | 581 | *stat = 0; |
4376b7cf | 582 | |
da17cbb7 JB |
583 | newmem = malloc (MAX (size, 1)); |
584 | if (newmem == NULL) | |
4376b7cf | 585 | { |
da17cbb7 JB |
586 | if (stat) |
587 | *stat = LIBERROR_ALLOCATION; | |
588 | else | |
bd085c20 | 589 | runtime_error ("Allocation would exceed memory limit"); |
4376b7cf | 590 | } |
4376b7cf FXC |
591 | return newmem; |
592 | } */ | |
593 | tree | |
594 | gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) | |
595 | { | |
596 | stmtblock_t alloc_block; | |
da17cbb7 | 597 | tree res, tmp, msg, cond; |
4376b7cf FXC |
598 | tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE; |
599 | ||
600 | /* Evaluate size only once, and make sure it has the right type. */ | |
601 | size = gfc_evaluate_now (size, block); | |
602 | if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) | |
603 | size = fold_convert (size_type_node, size); | |
604 | ||
605 | /* Create a variable to hold the result. */ | |
10174ddf | 606 | res = gfc_create_var (prvoid_type_node, NULL); |
4376b7cf FXC |
607 | |
608 | /* Set the optional status variable to zero. */ | |
609 | if (status != NULL_TREE && !integer_zerop (status)) | |
610 | { | |
65a9ca82 TB |
611 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, |
612 | fold_build1_loc (input_location, INDIRECT_REF, | |
613 | status_type, status), | |
614 | build_int_cst (status_type, 0)); | |
615 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
616 | fold_build2_loc (input_location, NE_EXPR, | |
617 | boolean_type_node, status, | |
618 | build_int_cst (TREE_TYPE (status), 0)), | |
619 | tmp, build_empty_stmt (input_location)); | |
4376b7cf FXC |
620 | gfc_add_expr_to_block (block, tmp); |
621 | } | |
622 | ||
4376b7cf FXC |
623 | /* The allocation itself. */ |
624 | gfc_start_block (&alloc_block); | |
726a989a | 625 | gfc_add_modify (&alloc_block, res, |
10174ddf MM |
626 | fold_convert (prvoid_type_node, |
627 | build_call_expr_loc (input_location, | |
db3927fb | 628 | built_in_decls[BUILT_IN_MALLOC], 1, |
65a9ca82 TB |
629 | fold_build2_loc (input_location, |
630 | MAX_EXPR, size_type_node, size, | |
631 | build_int_cst (size_type_node, | |
632 | 1))))); | |
4376b7cf | 633 | |
ee37d2f5 | 634 | msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const |
bd085c20 | 635 | ("Allocation would exceed memory limit")); |
db3927fb AH |
636 | tmp = build_call_expr_loc (input_location, |
637 | gfor_fndecl_os_error, 1, msg); | |
4376b7cf FXC |
638 | |
639 | if (status != NULL_TREE && !integer_zerop (status)) | |
640 | { | |
641 | /* Set the status variable if it's present. */ | |
642 | tree tmp2; | |
643 | ||
65a9ca82 TB |
644 | cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, |
645 | status, build_int_cst (TREE_TYPE (status), 0)); | |
646 | tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type, | |
647 | fold_build1_loc (input_location, INDIRECT_REF, | |
648 | status_type, status), | |
649 | build_int_cst (status_type, LIBERROR_ALLOCATION)); | |
650 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, | |
651 | tmp, tmp2); | |
4376b7cf FXC |
652 | } |
653 | ||
65a9ca82 TB |
654 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
655 | fold_build2_loc (input_location, EQ_EXPR, | |
656 | boolean_type_node, res, | |
657 | build_int_cst (prvoid_type_node, 0)), | |
658 | tmp, build_empty_stmt (input_location)); | |
4376b7cf | 659 | gfc_add_expr_to_block (&alloc_block, tmp); |
da17cbb7 | 660 | gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block)); |
4376b7cf FXC |
661 | |
662 | return res; | |
663 | } | |
664 | ||
665 | ||
666 | /* Generate code for an ALLOCATE statement when the argument is an | |
667 | allocatable array. If the array is currently allocated, it is an | |
668 | error to allocate it again. | |
669 | ||
670 | This function follows the following pseudo-code: | |
671 | ||
672 | void * | |
673 | allocate_array (void *mem, size_t size, integer_type *stat) | |
674 | { | |
675 | if (mem == NULL) | |
676 | return allocate (size, stat); | |
677 | else | |
678 | { | |
679 | if (stat) | |
680 | { | |
681 | free (mem); | |
682 | mem = allocate (size, stat); | |
d74b97cc | 683 | *stat = LIBERROR_ALLOCATION; |
4376b7cf FXC |
684 | return mem; |
685 | } | |
686 | else | |
f8dde8af | 687 | runtime_error ("Attempting to allocate already allocated variable"); |
5b130807 | 688 | } |
f25a62a5 DK |
689 | } |
690 | ||
691 | expr must be set to the original expression being allocated for its locus | |
692 | and variable name in case a runtime error has to be printed. */ | |
4376b7cf FXC |
693 | tree |
694 | gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size, | |
f25a62a5 | 695 | tree status, gfc_expr* expr) |
4376b7cf FXC |
696 | { |
697 | stmtblock_t alloc_block; | |
f25a62a5 | 698 | tree res, tmp, null_mem, alloc, error; |
4376b7cf FXC |
699 | tree type = TREE_TYPE (mem); |
700 | ||
701 | if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) | |
702 | size = fold_convert (size_type_node, size); | |
703 | ||
704 | /* Create a variable to hold the result. */ | |
10174ddf | 705 | res = gfc_create_var (type, NULL); |
65a9ca82 TB |
706 | null_mem = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, mem, |
707 | build_int_cst (type, 0)); | |
4376b7cf FXC |
708 | |
709 | /* If mem is NULL, we call gfc_allocate_with_status. */ | |
710 | gfc_start_block (&alloc_block); | |
711 | tmp = gfc_allocate_with_status (&alloc_block, size, status); | |
726a989a | 712 | gfc_add_modify (&alloc_block, res, fold_convert (type, tmp)); |
4376b7cf FXC |
713 | alloc = gfc_finish_block (&alloc_block); |
714 | ||
715 | /* Otherwise, we issue a runtime error or set the status variable. */ | |
f25a62a5 DK |
716 | if (expr) |
717 | { | |
718 | tree varname; | |
719 | ||
720 | gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree); | |
721 | varname = gfc_build_cstring_const (expr->symtree->name); | |
722 | varname = gfc_build_addr_expr (pchar_type_node, varname); | |
723 | ||
724 | error = gfc_trans_runtime_error (true, &expr->where, | |
725 | "Attempting to allocate already" | |
f8dde8af | 726 | " allocated variable '%s'", |
f25a62a5 DK |
727 | varname); |
728 | } | |
729 | else | |
730 | error = gfc_trans_runtime_error (true, NULL, | |
731 | "Attempting to allocate already allocated" | |
d8a07487 | 732 | " variable"); |
4376b7cf FXC |
733 | |
734 | if (status != NULL_TREE && !integer_zerop (status)) | |
735 | { | |
736 | tree status_type = TREE_TYPE (TREE_TYPE (status)); | |
737 | stmtblock_t set_status_block; | |
738 | ||
739 | gfc_start_block (&set_status_block); | |
db3927fb AH |
740 | tmp = build_call_expr_loc (input_location, |
741 | built_in_decls[BUILT_IN_FREE], 1, | |
4376b7cf FXC |
742 | fold_convert (pvoid_type_node, mem)); |
743 | gfc_add_expr_to_block (&set_status_block, tmp); | |
744 | ||
745 | tmp = gfc_allocate_with_status (&set_status_block, size, status); | |
726a989a | 746 | gfc_add_modify (&set_status_block, res, fold_convert (type, tmp)); |
4376b7cf | 747 | |
726a989a | 748 | gfc_add_modify (&set_status_block, |
65a9ca82 TB |
749 | fold_build1_loc (input_location, INDIRECT_REF, |
750 | status_type, status), | |
d74b97cc | 751 | build_int_cst (status_type, LIBERROR_ALLOCATION)); |
4376b7cf | 752 | |
65a9ca82 TB |
753 | tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, |
754 | status, build_int_cst (status_type, 0)); | |
755 | error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, | |
756 | error, gfc_finish_block (&set_status_block)); | |
4376b7cf FXC |
757 | } |
758 | ||
65a9ca82 TB |
759 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem, |
760 | alloc, error); | |
4376b7cf FXC |
761 | gfc_add_expr_to_block (block, tmp); |
762 | ||
763 | return res; | |
764 | } | |
765 | ||
1529b8d9 FXC |
766 | |
767 | /* Free a given variable, if it's not NULL. */ | |
768 | tree | |
769 | gfc_call_free (tree var) | |
770 | { | |
771 | stmtblock_t block; | |
772 | tree tmp, cond, call; | |
773 | ||
774 | if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node)) | |
775 | var = fold_convert (pvoid_type_node, var); | |
776 | ||
777 | gfc_start_block (&block); | |
778 | var = gfc_evaluate_now (var, &block); | |
65a9ca82 TB |
779 | cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var, |
780 | build_int_cst (pvoid_type_node, 0)); | |
db3927fb | 781 | call = build_call_expr_loc (input_location, |
65a9ca82 TB |
782 | built_in_decls[BUILT_IN_FREE], 1, var); |
783 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call, | |
784 | build_empty_stmt (input_location)); | |
1529b8d9 FXC |
785 | gfc_add_expr_to_block (&block, tmp); |
786 | ||
787 | return gfc_finish_block (&block); | |
788 | } | |
789 | ||
790 | ||
4376b7cf FXC |
791 | |
792 | /* User-deallocate; we emit the code directly from the front-end, and the | |
793 | logic is the same as the previous library function: | |
794 | ||
795 | void | |
796 | deallocate (void *pointer, GFC_INTEGER_4 * stat) | |
797 | { | |
798 | if (!pointer) | |
799 | { | |
800 | if (stat) | |
801 | *stat = 1; | |
802 | else | |
803 | runtime_error ("Attempt to DEALLOCATE unallocated memory."); | |
804 | } | |
805 | else | |
806 | { | |
807 | free (pointer); | |
808 | if (stat) | |
809 | *stat = 0; | |
810 | } | |
811 | } | |
812 | ||
813 | In this front-end version, status doesn't have to be GFC_INTEGER_4. | |
814 | Moreover, if CAN_FAIL is true, then we will not emit a runtime error, | |
815 | even when no status variable is passed to us (this is used for | |
816 | unconditional deallocation generated by the front-end at end of | |
f25a62a5 DK |
817 | each procedure). |
818 | ||
819 | If a runtime-message is possible, `expr' must point to the original | |
820 | expression being deallocated for its locus and variable name. */ | |
4376b7cf | 821 | tree |
f25a62a5 DK |
822 | gfc_deallocate_with_status (tree pointer, tree status, bool can_fail, |
823 | gfc_expr* expr) | |
4376b7cf FXC |
824 | { |
825 | stmtblock_t null, non_null; | |
f25a62a5 | 826 | tree cond, tmp, error; |
4376b7cf | 827 | |
65a9ca82 TB |
828 | cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, |
829 | build_int_cst (TREE_TYPE (pointer), 0)); | |
4376b7cf FXC |
830 | |
831 | /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise | |
832 | we emit a runtime error. */ | |
833 | gfc_start_block (&null); | |
834 | if (!can_fail) | |
835 | { | |
f25a62a5 DK |
836 | tree varname; |
837 | ||
838 | gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); | |
839 | ||
840 | varname = gfc_build_cstring_const (expr->symtree->name); | |
841 | varname = gfc_build_addr_expr (pchar_type_node, varname); | |
842 | ||
843 | error = gfc_trans_runtime_error (true, &expr->where, | |
844 | "Attempt to DEALLOCATE unallocated '%s'", | |
845 | varname); | |
4376b7cf FXC |
846 | } |
847 | else | |
c2255bc4 | 848 | error = build_empty_stmt (input_location); |
4376b7cf FXC |
849 | |
850 | if (status != NULL_TREE && !integer_zerop (status)) | |
851 | { | |
852 | tree status_type = TREE_TYPE (TREE_TYPE (status)); | |
853 | tree cond2; | |
854 | ||
65a9ca82 TB |
855 | cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, |
856 | status, build_int_cst (TREE_TYPE (status), 0)); | |
857 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, | |
858 | fold_build1_loc (input_location, INDIRECT_REF, | |
859 | status_type, status), | |
860 | build_int_cst (status_type, 1)); | |
861 | error = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
862 | cond2, tmp, error); | |
4376b7cf FXC |
863 | } |
864 | ||
865 | gfc_add_expr_to_block (&null, error); | |
866 | ||
867 | /* When POINTER is not NULL, we free it. */ | |
868 | gfc_start_block (&non_null); | |
2c807128 JW |
869 | tmp = build_call_expr_loc (input_location, |
870 | built_in_decls[BUILT_IN_FREE], 1, | |
871 | fold_convert (pvoid_type_node, pointer)); | |
872 | gfc_add_expr_to_block (&non_null, tmp); | |
873 | ||
874 | if (status != NULL_TREE && !integer_zerop (status)) | |
875 | { | |
876 | /* We set STATUS to zero if it is present. */ | |
877 | tree status_type = TREE_TYPE (TREE_TYPE (status)); | |
878 | tree cond2; | |
879 | ||
880 | cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, | |
881 | status, build_int_cst (TREE_TYPE (status), 0)); | |
882 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, | |
883 | fold_build1_loc (input_location, INDIRECT_REF, | |
884 | status_type, status), | |
885 | build_int_cst (status_type, 0)); | |
886 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, | |
887 | tmp, build_empty_stmt (input_location)); | |
888 | gfc_add_expr_to_block (&non_null, tmp); | |
889 | } | |
890 | ||
891 | return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, | |
892 | gfc_finish_block (&null), | |
893 | gfc_finish_block (&non_null)); | |
894 | } | |
895 | ||
896 | ||
897 | /* Generate code for deallocation of allocatable scalars (variables or | |
898 | components). Before the object itself is freed, any allocatable | |
899 | subcomponents are being deallocated. */ | |
900 | ||
901 | tree | |
902 | gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, | |
903 | gfc_expr* expr, gfc_typespec ts) | |
904 | { | |
905 | stmtblock_t null, non_null; | |
906 | tree cond, tmp, error; | |
907 | ||
908 | cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, | |
909 | build_int_cst (TREE_TYPE (pointer), 0)); | |
910 | ||
911 | /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise | |
912 | we emit a runtime error. */ | |
913 | gfc_start_block (&null); | |
914 | if (!can_fail) | |
915 | { | |
916 | tree varname; | |
917 | ||
918 | gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); | |
919 | ||
920 | varname = gfc_build_cstring_const (expr->symtree->name); | |
921 | varname = gfc_build_addr_expr (pchar_type_node, varname); | |
922 | ||
923 | error = gfc_trans_runtime_error (true, &expr->where, | |
924 | "Attempt to DEALLOCATE unallocated '%s'", | |
925 | varname); | |
926 | } | |
927 | else | |
928 | error = build_empty_stmt (input_location); | |
929 | ||
930 | if (status != NULL_TREE && !integer_zerop (status)) | |
931 | { | |
932 | tree status_type = TREE_TYPE (TREE_TYPE (status)); | |
933 | tree cond2; | |
934 | ||
935 | cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, | |
936 | status, build_int_cst (TREE_TYPE (status), 0)); | |
937 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, | |
938 | fold_build1_loc (input_location, INDIRECT_REF, | |
939 | status_type, status), | |
940 | build_int_cst (status_type, 1)); | |
941 | error = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
942 | cond2, tmp, error); | |
943 | } | |
944 | ||
945 | gfc_add_expr_to_block (&null, error); | |
946 | ||
947 | /* When POINTER is not NULL, we free it. */ | |
948 | gfc_start_block (&non_null); | |
949 | ||
950 | /* Free allocatable components. */ | |
951 | if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) | |
952 | { | |
953 | tmp = build_fold_indirect_ref_loc (input_location, pointer); | |
954 | tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); | |
955 | gfc_add_expr_to_block (&non_null, tmp); | |
956 | } | |
957 | else if (ts.type == BT_CLASS | |
958 | && ts.u.derived->components->ts.u.derived->attr.alloc_comp) | |
959 | { | |
960 | tmp = build_fold_indirect_ref_loc (input_location, pointer); | |
961 | tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived, | |
962 | tmp, 0); | |
963 | gfc_add_expr_to_block (&non_null, tmp); | |
964 | } | |
965 | ||
db3927fb AH |
966 | tmp = build_call_expr_loc (input_location, |
967 | built_in_decls[BUILT_IN_FREE], 1, | |
4376b7cf FXC |
968 | fold_convert (pvoid_type_node, pointer)); |
969 | gfc_add_expr_to_block (&non_null, tmp); | |
970 | ||
971 | if (status != NULL_TREE && !integer_zerop (status)) | |
972 | { | |
973 | /* We set STATUS to zero if it is present. */ | |
974 | tree status_type = TREE_TYPE (TREE_TYPE (status)); | |
975 | tree cond2; | |
976 | ||
65a9ca82 TB |
977 | cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, |
978 | status, build_int_cst (TREE_TYPE (status), 0)); | |
979 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, | |
980 | fold_build1_loc (input_location, INDIRECT_REF, | |
981 | status_type, status), | |
982 | build_int_cst (status_type, 0)); | |
983 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, | |
984 | tmp, build_empty_stmt (input_location)); | |
4376b7cf FXC |
985 | gfc_add_expr_to_block (&non_null, tmp); |
986 | } | |
987 | ||
65a9ca82 TB |
988 | return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, |
989 | gfc_finish_block (&null), | |
990 | gfc_finish_block (&non_null)); | |
4376b7cf FXC |
991 | } |
992 | ||
993 | ||
994 | /* Reallocate MEM so it has SIZE bytes of data. This behaves like the | |
995 | following pseudo-code: | |
996 | ||
997 | void * | |
998 | internal_realloc (void *mem, size_t size) | |
999 | { | |
28762eb0 FXC |
1000 | res = realloc (mem, size); |
1001 | if (!res && size != 0) | |
bd085c20 | 1002 | _gfortran_os_error ("Allocation would exceed memory limit"); |
4376b7cf FXC |
1003 | |
1004 | if (size == 0) | |
1005 | return NULL; | |
1006 | ||
28762eb0 | 1007 | return res; |
4376b7cf FXC |
1008 | } */ |
1009 | tree | |
1010 | gfc_call_realloc (stmtblock_t * block, tree mem, tree size) | |
1011 | { | |
da17cbb7 | 1012 | tree msg, res, nonzero, zero, null_result, tmp; |
4376b7cf FXC |
1013 | tree type = TREE_TYPE (mem); |
1014 | ||
1015 | size = gfc_evaluate_now (size, block); | |
1016 | ||
1017 | if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) | |
1018 | size = fold_convert (size_type_node, size); | |
1019 | ||
1020 | /* Create a variable to hold the result. */ | |
1021 | res = gfc_create_var (type, NULL); | |
1022 | ||
4376b7cf | 1023 | /* Call realloc and check the result. */ |
db3927fb AH |
1024 | tmp = build_call_expr_loc (input_location, |
1025 | built_in_decls[BUILT_IN_REALLOC], 2, | |
4376b7cf | 1026 | fold_convert (pvoid_type_node, mem), size); |
726a989a | 1027 | gfc_add_modify (block, res, fold_convert (type, tmp)); |
65a9ca82 TB |
1028 | null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, |
1029 | res, build_int_cst (pvoid_type_node, 0)); | |
1030 | nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size, | |
1031 | build_int_cst (size_type_node, 0)); | |
1032 | null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, | |
1033 | null_result, nonzero); | |
ee37d2f5 | 1034 | msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const |
bd085c20 | 1035 | ("Allocation would exceed memory limit")); |
65a9ca82 TB |
1036 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
1037 | null_result, | |
1038 | build_call_expr_loc (input_location, | |
1039 | gfor_fndecl_os_error, 1, msg), | |
1040 | build_empty_stmt (input_location)); | |
4376b7cf FXC |
1041 | gfc_add_expr_to_block (block, tmp); |
1042 | ||
1043 | /* if (size == 0) then the result is NULL. */ | |
65a9ca82 TB |
1044 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res, |
1045 | build_int_cst (type, 0)); | |
1046 | zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node, | |
1047 | nonzero); | |
1048 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp, | |
1049 | build_empty_stmt (input_location)); | |
4376b7cf FXC |
1050 | gfc_add_expr_to_block (block, tmp); |
1051 | ||
1052 | return res; | |
1053 | } | |
1054 | ||
6de9cd9a | 1055 | |
0019d498 | 1056 | /* Add an expression to another one, either at the front or the back. */ |
6de9cd9a | 1057 | |
0019d498 DK |
1058 | static void |
1059 | add_expr_to_chain (tree* chain, tree expr, bool front) | |
1060 | { | |
6de9cd9a DN |
1061 | if (expr == NULL_TREE || IS_EMPTY_STMT (expr)) |
1062 | return; | |
1063 | ||
0019d498 | 1064 | if (*chain) |
7c87eac6 | 1065 | { |
0019d498 | 1066 | if (TREE_CODE (*chain) != STATEMENT_LIST) |
7c87eac6 PB |
1067 | { |
1068 | tree tmp; | |
1069 | ||
0019d498 DK |
1070 | tmp = *chain; |
1071 | *chain = NULL_TREE; | |
1072 | append_to_statement_list (tmp, chain); | |
7c87eac6 | 1073 | } |
0019d498 DK |
1074 | |
1075 | if (front) | |
1076 | { | |
1077 | tree_stmt_iterator i; | |
1078 | ||
1079 | i = tsi_start (*chain); | |
1080 | tsi_link_before (&i, expr, TSI_CONTINUE_LINKING); | |
1081 | } | |
1082 | else | |
1083 | append_to_statement_list (expr, chain); | |
7c87eac6 | 1084 | } |
6de9cd9a | 1085 | else |
0019d498 DK |
1086 | *chain = expr; |
1087 | } | |
1088 | ||
46b2c440 MM |
1089 | |
1090 | /* Add a statement at the end of a block. */ | |
0019d498 DK |
1091 | |
1092 | void | |
1093 | gfc_add_expr_to_block (stmtblock_t * block, tree expr) | |
1094 | { | |
1095 | gcc_assert (block); | |
1096 | add_expr_to_chain (&block->head, expr, false); | |
6de9cd9a DN |
1097 | } |
1098 | ||
1099 | ||
46b2c440 MM |
1100 | /* Add a statement at the beginning of a block. */ |
1101 | ||
1102 | void | |
1103 | gfc_prepend_expr_to_block (stmtblock_t * block, tree expr) | |
1104 | { | |
1105 | gcc_assert (block); | |
1106 | add_expr_to_chain (&block->head, expr, true); | |
1107 | } | |
1108 | ||
1109 | ||
6de9cd9a DN |
1110 | /* Add a block the end of a block. */ |
1111 | ||
1112 | void | |
1113 | gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append) | |
1114 | { | |
6e45f57b PB |
1115 | gcc_assert (append); |
1116 | gcc_assert (!append->has_scope); | |
6de9cd9a DN |
1117 | |
1118 | gfc_add_expr_to_block (block, append->head); | |
1119 | append->head = NULL_TREE; | |
1120 | } | |
1121 | ||
1122 | ||
363aab21 MM |
1123 | /* Save the current locus. The structure may not be complete, and should |
1124 | only be used with gfc_restore_backend_locus. */ | |
6de9cd9a DN |
1125 | |
1126 | void | |
363aab21 | 1127 | gfc_save_backend_locus (locus * loc) |
6de9cd9a | 1128 | { |
ece3f663 | 1129 | loc->lb = XCNEW (gfc_linebuf); |
8e400578 | 1130 | loc->lb->location = input_location; |
d4fa05b9 | 1131 | loc->lb->file = gfc_current_backend_file; |
6de9cd9a DN |
1132 | } |
1133 | ||
1134 | ||
1135 | /* Set the current locus. */ | |
1136 | ||
1137 | void | |
1138 | gfc_set_backend_locus (locus * loc) | |
1139 | { | |
d4fa05b9 | 1140 | gfc_current_backend_file = loc->lb->file; |
c8cc8542 | 1141 | input_location = loc->lb->location; |
6de9cd9a DN |
1142 | } |
1143 | ||
1144 | ||
363aab21 MM |
1145 | /* Restore the saved locus. Only used in conjonction with |
1146 | gfc_save_backend_locus, to free the memory when we are done. */ | |
1147 | ||
1148 | void | |
1149 | gfc_restore_backend_locus (locus * loc) | |
1150 | { | |
1151 | gfc_set_backend_locus (loc); | |
1152 | gfc_free (loc->lb); | |
1153 | } | |
1154 | ||
1155 | ||
bc51e726 JD |
1156 | /* Translate an executable statement. The tree cond is used by gfc_trans_do. |
1157 | This static function is wrapped by gfc_trans_code_cond and | |
1158 | gfc_trans_code. */ | |
6de9cd9a | 1159 | |
bc51e726 JD |
1160 | static tree |
1161 | trans_code (gfc_code * code, tree cond) | |
6de9cd9a DN |
1162 | { |
1163 | stmtblock_t block; | |
1164 | tree res; | |
1165 | ||
1166 | if (!code) | |
c2255bc4 | 1167 | return build_empty_stmt (input_location); |
6de9cd9a DN |
1168 | |
1169 | gfc_start_block (&block); | |
1170 | ||
726a989a | 1171 | /* Translate statements one by one into GENERIC trees until we reach |
6de9cd9a DN |
1172 | the end of this gfc_code branch. */ |
1173 | for (; code; code = code->next) | |
1174 | { | |
6de9cd9a DN |
1175 | if (code->here != 0) |
1176 | { | |
1177 | res = gfc_trans_label_here (code); | |
1178 | gfc_add_expr_to_block (&block, res); | |
1179 | } | |
1180 | ||
88e09c79 JJ |
1181 | gfc_set_backend_locus (&code->loc); |
1182 | ||
6de9cd9a DN |
1183 | switch (code->op) |
1184 | { | |
1185 | case EXEC_NOP: | |
d80c695f | 1186 | case EXEC_END_BLOCK: |
5c71a5e0 | 1187 | case EXEC_END_PROCEDURE: |
6de9cd9a DN |
1188 | res = NULL_TREE; |
1189 | break; | |
1190 | ||
1191 | case EXEC_ASSIGN: | |
f43085aa | 1192 | if (code->expr1->ts.type == BT_CLASS) |
b2a5eb75 | 1193 | res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); |
f43085aa JW |
1194 | else |
1195 | res = gfc_trans_assign (code); | |
6de9cd9a DN |
1196 | break; |
1197 | ||
1198 | case EXEC_LABEL_ASSIGN: | |
1199 | res = gfc_trans_label_assign (code); | |
1200 | break; | |
1201 | ||
1202 | case EXEC_POINTER_ASSIGN: | |
f43085aa | 1203 | if (code->expr1->ts.type == BT_CLASS) |
b2a5eb75 | 1204 | res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); |
f43085aa JW |
1205 | else |
1206 | res = gfc_trans_pointer_assign (code); | |
6de9cd9a DN |
1207 | break; |
1208 | ||
6b591ec0 | 1209 | case EXEC_INIT_ASSIGN: |
7adac79a | 1210 | if (code->expr1->ts.type == BT_CLASS) |
b2a5eb75 | 1211 | res = gfc_trans_class_init_assign (code); |
7adac79a JW |
1212 | else |
1213 | res = gfc_trans_init_assign (code); | |
6b591ec0 PT |
1214 | break; |
1215 | ||
6de9cd9a DN |
1216 | case EXEC_CONTINUE: |
1217 | res = NULL_TREE; | |
1218 | break; | |
1219 | ||
d0a4a61c TB |
1220 | case EXEC_CRITICAL: |
1221 | res = gfc_trans_critical (code); | |
1222 | break; | |
1223 | ||
6de9cd9a DN |
1224 | case EXEC_CYCLE: |
1225 | res = gfc_trans_cycle (code); | |
1226 | break; | |
1227 | ||
1228 | case EXEC_EXIT: | |
1229 | res = gfc_trans_exit (code); | |
1230 | break; | |
1231 | ||
1232 | case EXEC_GOTO: | |
1233 | res = gfc_trans_goto (code); | |
1234 | break; | |
1235 | ||
3d79abbd PB |
1236 | case EXEC_ENTRY: |
1237 | res = gfc_trans_entry (code); | |
1238 | break; | |
1239 | ||
6de9cd9a DN |
1240 | case EXEC_PAUSE: |
1241 | res = gfc_trans_pause (code); | |
1242 | break; | |
1243 | ||
1244 | case EXEC_STOP: | |
d0a4a61c TB |
1245 | case EXEC_ERROR_STOP: |
1246 | res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP); | |
6de9cd9a DN |
1247 | break; |
1248 | ||
1249 | case EXEC_CALL: | |
12f681a0 DK |
1250 | /* For MVBITS we've got the special exception that we need a |
1251 | dependency check, too. */ | |
1252 | { | |
1253 | bool is_mvbits = false; | |
1254 | if (code->resolved_isym | |
1255 | && code->resolved_isym->id == GFC_ISYM_MVBITS) | |
1256 | is_mvbits = true; | |
b2a5eb75 JW |
1257 | if (code->resolved_isym |
1258 | && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC) | |
1259 | res = gfc_conv_intrinsic_move_alloc (code); | |
1260 | else | |
1261 | res = gfc_trans_call (code, is_mvbits, NULL_TREE, | |
1262 | NULL_TREE, false); | |
12f681a0 | 1263 | } |
476220e7 PT |
1264 | break; |
1265 | ||
713485cc | 1266 | case EXEC_CALL_PPC: |
eb74e79b PT |
1267 | res = gfc_trans_call (code, false, NULL_TREE, |
1268 | NULL_TREE, false); | |
713485cc JW |
1269 | break; |
1270 | ||
476220e7 | 1271 | case EXEC_ASSIGN_CALL: |
eb74e79b PT |
1272 | res = gfc_trans_call (code, true, NULL_TREE, |
1273 | NULL_TREE, false); | |
6de9cd9a DN |
1274 | break; |
1275 | ||
1276 | case EXEC_RETURN: | |
1277 | res = gfc_trans_return (code); | |
1278 | break; | |
1279 | ||
1280 | case EXEC_IF: | |
1281 | res = gfc_trans_if (code); | |
1282 | break; | |
1283 | ||
1284 | case EXEC_ARITHMETIC_IF: | |
1285 | res = gfc_trans_arithmetic_if (code); | |
9abe5e56 DK |
1286 | break; |
1287 | ||
1288 | case EXEC_BLOCK: | |
1289 | res = gfc_trans_block_construct (code); | |
6de9cd9a DN |
1290 | break; |
1291 | ||
1292 | case EXEC_DO: | |
bc51e726 | 1293 | res = gfc_trans_do (code, cond); |
6de9cd9a DN |
1294 | break; |
1295 | ||
1296 | case EXEC_DO_WHILE: | |
1297 | res = gfc_trans_do_while (code); | |
1298 | break; | |
1299 | ||
1300 | case EXEC_SELECT: | |
1301 | res = gfc_trans_select (code); | |
1302 | break; | |
1303 | ||
cf2b3c22 TB |
1304 | case EXEC_SELECT_TYPE: |
1305 | /* Do nothing. SELECT TYPE statements should be transformed into | |
1306 | an ordinary SELECT CASE at resolution stage. | |
1307 | TODO: Add an error message here once this is done. */ | |
1308 | res = NULL_TREE; | |
1309 | break; | |
1310 | ||
6403ec5f JB |
1311 | case EXEC_FLUSH: |
1312 | res = gfc_trans_flush (code); | |
1313 | break; | |
1314 | ||
d0a4a61c TB |
1315 | case EXEC_SYNC_ALL: |
1316 | case EXEC_SYNC_IMAGES: | |
1317 | case EXEC_SYNC_MEMORY: | |
1318 | res = gfc_trans_sync (code, code->op); | |
1319 | break; | |
1320 | ||
6de9cd9a DN |
1321 | case EXEC_FORALL: |
1322 | res = gfc_trans_forall (code); | |
1323 | break; | |
1324 | ||
1325 | case EXEC_WHERE: | |
1326 | res = gfc_trans_where (code); | |
1327 | break; | |
1328 | ||
1329 | case EXEC_ALLOCATE: | |
1330 | res = gfc_trans_allocate (code); | |
1331 | break; | |
1332 | ||
1333 | case EXEC_DEALLOCATE: | |
1334 | res = gfc_trans_deallocate (code); | |
1335 | break; | |
1336 | ||
1337 | case EXEC_OPEN: | |
1338 | res = gfc_trans_open (code); | |
1339 | break; | |
1340 | ||
1341 | case EXEC_CLOSE: | |
1342 | res = gfc_trans_close (code); | |
1343 | break; | |
1344 | ||
1345 | case EXEC_READ: | |
1346 | res = gfc_trans_read (code); | |
1347 | break; | |
1348 | ||
1349 | case EXEC_WRITE: | |
1350 | res = gfc_trans_write (code); | |
1351 | break; | |
1352 | ||
1353 | case EXEC_IOLENGTH: | |
1354 | res = gfc_trans_iolength (code); | |
1355 | break; | |
1356 | ||
1357 | case EXEC_BACKSPACE: | |
1358 | res = gfc_trans_backspace (code); | |
1359 | break; | |
1360 | ||
1361 | case EXEC_ENDFILE: | |
1362 | res = gfc_trans_endfile (code); | |
1363 | break; | |
1364 | ||
1365 | case EXEC_INQUIRE: | |
1366 | res = gfc_trans_inquire (code); | |
1367 | break; | |
1368 | ||
6f0f0b2e JD |
1369 | case EXEC_WAIT: |
1370 | res = gfc_trans_wait (code); | |
1371 | break; | |
1372 | ||
6de9cd9a DN |
1373 | case EXEC_REWIND: |
1374 | res = gfc_trans_rewind (code); | |
1375 | break; | |
1376 | ||
1377 | case EXEC_TRANSFER: | |
1378 | res = gfc_trans_transfer (code); | |
1379 | break; | |
1380 | ||
1381 | case EXEC_DT_END: | |
1382 | res = gfc_trans_dt_end (code); | |
1383 | break; | |
1384 | ||
6c7a4dfd JJ |
1385 | case EXEC_OMP_ATOMIC: |
1386 | case EXEC_OMP_BARRIER: | |
1387 | case EXEC_OMP_CRITICAL: | |
1388 | case EXEC_OMP_DO: | |
1389 | case EXEC_OMP_FLUSH: | |
1390 | case EXEC_OMP_MASTER: | |
1391 | case EXEC_OMP_ORDERED: | |
1392 | case EXEC_OMP_PARALLEL: | |
1393 | case EXEC_OMP_PARALLEL_DO: | |
1394 | case EXEC_OMP_PARALLEL_SECTIONS: | |
1395 | case EXEC_OMP_PARALLEL_WORKSHARE: | |
1396 | case EXEC_OMP_SECTIONS: | |
1397 | case EXEC_OMP_SINGLE: | |
a68ab351 JJ |
1398 | case EXEC_OMP_TASK: |
1399 | case EXEC_OMP_TASKWAIT: | |
6c7a4dfd JJ |
1400 | case EXEC_OMP_WORKSHARE: |
1401 | res = gfc_trans_omp_directive (code); | |
1402 | break; | |
1403 | ||
6de9cd9a DN |
1404 | default: |
1405 | internal_error ("gfc_trans_code(): Bad statement code"); | |
1406 | } | |
1407 | ||
bf737879 TS |
1408 | gfc_set_backend_locus (&code->loc); |
1409 | ||
6de9cd9a DN |
1410 | if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) |
1411 | { | |
60f5ed26 | 1412 | if (TREE_CODE (res) != STATEMENT_LIST) |
c8cc8542 | 1413 | SET_EXPR_LOCATION (res, input_location); |
bf737879 TS |
1414 | |
1415 | /* Add the new statement to the block. */ | |
6de9cd9a DN |
1416 | gfc_add_expr_to_block (&block, res); |
1417 | } | |
1418 | } | |
1419 | ||
1420 | /* Return the finished block. */ | |
1421 | return gfc_finish_block (&block); | |
1422 | } | |
1423 | ||
1424 | ||
bc51e726 JD |
1425 | /* Translate an executable statement with condition, cond. The condition is |
1426 | used by gfc_trans_do to test for IO result conditions inside implied | |
1427 | DO loops of READ and WRITE statements. See build_dt in trans-io.c. */ | |
1428 | ||
1429 | tree | |
1430 | gfc_trans_code_cond (gfc_code * code, tree cond) | |
1431 | { | |
1432 | return trans_code (code, cond); | |
1433 | } | |
1434 | ||
1435 | /* Translate an executable statement without condition. */ | |
1436 | ||
1437 | tree | |
1438 | gfc_trans_code (gfc_code * code) | |
1439 | { | |
1440 | return trans_code (code, NULL_TREE); | |
1441 | } | |
1442 | ||
1443 | ||
6de9cd9a DN |
1444 | /* This function is called after a complete program unit has been parsed |
1445 | and resolved. */ | |
1446 | ||
1447 | void | |
1448 | gfc_generate_code (gfc_namespace * ns) | |
1449 | { | |
34d01e1d | 1450 | ompws_flags = 0; |
0de4325e TS |
1451 | if (ns->is_block_data) |
1452 | { | |
1453 | gfc_generate_block_data (ns); | |
1454 | return; | |
1455 | } | |
1456 | ||
6de9cd9a DN |
1457 | gfc_generate_function_code (ns); |
1458 | } | |
1459 | ||
1460 | ||
1461 | /* This function is called after a complete module has been parsed | |
1462 | and resolved. */ | |
1463 | ||
1464 | void | |
1465 | gfc_generate_module_code (gfc_namespace * ns) | |
1466 | { | |
1467 | gfc_namespace *n; | |
a64f5186 JJ |
1468 | struct module_htab_entry *entry; |
1469 | ||
1470 | gcc_assert (ns->proc_name->backend_decl == NULL); | |
1471 | ns->proc_name->backend_decl | |
c2255bc4 AH |
1472 | = build_decl (ns->proc_name->declared_at.lb->location, |
1473 | NAMESPACE_DECL, get_identifier (ns->proc_name->name), | |
a64f5186 | 1474 | void_type_node); |
a64f5186 JJ |
1475 | entry = gfc_find_module (ns->proc_name->name); |
1476 | if (entry->namespace_decl) | |
1477 | /* Buggy sourcecode, using a module before defining it? */ | |
1478 | htab_empty (entry->decls); | |
1479 | entry->namespace_decl = ns->proc_name->backend_decl; | |
6de9cd9a DN |
1480 | |
1481 | gfc_generate_module_vars (ns); | |
1482 | ||
1483 | /* We need to generate all module function prototypes first, to allow | |
1484 | sibling calls. */ | |
1485 | for (n = ns->contained; n; n = n->sibling) | |
1486 | { | |
a64f5186 JJ |
1487 | gfc_entry_list *el; |
1488 | ||
6de9cd9a DN |
1489 | if (!n->proc_name) |
1490 | continue; | |
1491 | ||
fb55ca75 | 1492 | gfc_create_function_decl (n, false); |
a64f5186 JJ |
1493 | DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl; |
1494 | gfc_module_add_decl (entry, n->proc_name->backend_decl); | |
1495 | for (el = ns->entries; el; el = el->next) | |
1496 | { | |
a64f5186 JJ |
1497 | DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl; |
1498 | gfc_module_add_decl (entry, el->sym->backend_decl); | |
1499 | } | |
6de9cd9a DN |
1500 | } |
1501 | ||
1502 | for (n = ns->contained; n; n = n->sibling) | |
1503 | { | |
1504 | if (!n->proc_name) | |
1505 | continue; | |
1506 | ||
1507 | gfc_generate_function_code (n); | |
1508 | } | |
1509 | } | |
1510 | ||
0019d498 DK |
1511 | |
1512 | /* Initialize an init/cleanup block with existing code. */ | |
1513 | ||
1514 | void | |
1515 | gfc_start_wrapped_block (gfc_wrapped_block* block, tree code) | |
1516 | { | |
1517 | gcc_assert (block); | |
1518 | ||
1519 | block->init = NULL_TREE; | |
1520 | block->code = code; | |
1521 | block->cleanup = NULL_TREE; | |
1522 | } | |
1523 | ||
1524 | ||
1525 | /* Add a new pair of initializers/clean-up code. */ | |
1526 | ||
1527 | void | |
1528 | gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup) | |
1529 | { | |
1530 | gcc_assert (block); | |
1531 | ||
1532 | /* The new pair of init/cleanup should be "wrapped around" the existing | |
1533 | block of code, thus the initialization is added to the front and the | |
1534 | cleanup to the back. */ | |
1535 | add_expr_to_chain (&block->init, init, true); | |
1536 | add_expr_to_chain (&block->cleanup, cleanup, false); | |
1537 | } | |
1538 | ||
1539 | ||
1540 | /* Finish up a wrapped block by building a corresponding try-finally expr. */ | |
1541 | ||
1542 | tree | |
1543 | gfc_finish_wrapped_block (gfc_wrapped_block* block) | |
1544 | { | |
1545 | tree result; | |
1546 | ||
1547 | gcc_assert (block); | |
1548 | ||
1549 | /* Build the final expression. For this, just add init and body together, | |
1550 | and put clean-up with that into a TRY_FINALLY_EXPR. */ | |
1551 | result = block->init; | |
1552 | add_expr_to_chain (&result, block->code, false); | |
1553 | if (block->cleanup) | |
5d44e5c8 TB |
1554 | result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node, |
1555 | result, block->cleanup); | |
0019d498 DK |
1556 | |
1557 | /* Clear the block. */ | |
1558 | block->init = NULL_TREE; | |
1559 | block->code = NULL_TREE; | |
1560 | block->cleanup = NULL_TREE; | |
1561 | ||
1562 | return result; | |
1563 | } | |
5af07930 TB |
1564 | |
1565 | ||
1566 | /* Helper function for marking a boolean expression tree as unlikely. */ | |
1567 | ||
1568 | tree | |
1569 | gfc_unlikely (tree cond) | |
1570 | { | |
1571 | tree tmp; | |
1572 | ||
1573 | cond = fold_convert (long_integer_type_node, cond); | |
1574 | tmp = build_zero_cst (long_integer_type_node); | |
1575 | cond = build_call_expr_loc (input_location, | |
1576 | built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); | |
1577 | cond = fold_convert (boolean_type_node, cond); | |
1578 | return cond; | |
1579 | } |