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