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