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