]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/trans-decl.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
2009-06-12 Steven G. Kargl <kargls@comcast.net>
[thirdparty/gcc.git] / gcc / fortran / trans-decl.c
CommitLineData
4ee9c684 1/* Backend function setup
cfaf579d 2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4ee9c684 4 Contributed by Paul Brook
5
c84b470d 6This file is part of GCC.
4ee9c684 7
c84b470d 8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
bdabe786 10Software Foundation; either version 3, or (at your option) any later
c84b470d 11version.
4ee9c684 12
c84b470d 13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16for more details.
4ee9c684 17
18You should have received a copy of the GNU General Public License
bdabe786 19along with GCC; see the file COPYING3. If not see
20<http://www.gnu.org/licenses/>. */
4ee9c684 21
22/* trans-decl.c -- Handling of backend function and variable decls, etc */
23
24#include "config.h"
25#include "system.h"
26#include "coretypes.h"
27#include "tree.h"
28#include "tree-dump.h"
75a70cf9 29#include "gimple.h"
4ee9c684 30#include "ggc.h"
31#include "toplev.h"
32#include "tm.h"
0290e11b 33#include "rtl.h"
4ee9c684 34#include "target.h"
35#include "function.h"
4ee9c684 36#include "flags.h"
37#include "cgraph.h"
df4d540f 38#include "debug.h"
4ee9c684 39#include "gfortran.h"
9579733e 40#include "pointer-set.h"
4ee9c684 41#include "trans.h"
42#include "trans-types.h"
43#include "trans-array.h"
44#include "trans-const.h"
45/* Only for gfc_trans_code. Shouldn't need to include this. */
46#include "trans-stmt.h"
47
48#define MAX_LABEL_VALUE 99999
49
50
51/* Holds the result of the function if no result variable specified. */
52
53static GTY(()) tree current_fake_result_decl;
c750cc52 54static GTY(()) tree parent_fake_result_decl;
4ee9c684 55
56static GTY(()) tree current_function_return_label;
57
58
59/* Holds the variable DECLs for the current function. */
60
d4163395 61static GTY(()) tree saved_function_decls;
62static GTY(()) tree saved_parent_function_decls;
4ee9c684 63
9579733e 64static struct pointer_set_t *nonlocal_dummy_decl_pset;
65static GTY(()) tree nonlocal_dummy_decls;
4ee9c684 66
67/* The namespace of the module we're currently generating. Only used while
68 outputting decls for module variables. Do not rely on this being set. */
69
70static gfc_namespace *module_namespace;
71
72
73/* List of static constructor functions. */
74
75tree gfc_static_ctors;
76
77
78/* Function declarations for builtin library functions. */
79
4ee9c684 80tree gfor_fndecl_pause_numeric;
81tree gfor_fndecl_pause_string;
82tree gfor_fndecl_stop_numeric;
83tree gfor_fndecl_stop_string;
4ee9c684 84tree gfor_fndecl_runtime_error;
50ad5fa2 85tree gfor_fndecl_runtime_error_at;
da6ffc6d 86tree gfor_fndecl_runtime_warning_at;
9915365e 87tree gfor_fndecl_os_error;
50ad5fa2 88tree gfor_fndecl_generate_error;
7257a5d2 89tree gfor_fndecl_set_args;
8c84a5de 90tree gfor_fndecl_set_fpe;
56c7c2d7 91tree gfor_fndecl_set_options;
15774a8b 92tree gfor_fndecl_set_convert;
f23886ab 93tree gfor_fndecl_set_record_marker;
bbaaa7b1 94tree gfor_fndecl_set_max_subrecord_length;
b902b078 95tree gfor_fndecl_ctime;
96tree gfor_fndecl_fdate;
dbc97b88 97tree gfor_fndecl_ttynam;
4ee9c684 98tree gfor_fndecl_in_pack;
99tree gfor_fndecl_in_unpack;
100tree gfor_fndecl_associated;
101
102
103/* Math functions. Many other math functions are handled in
104 trans-intrinsic.c. */
105
920e54ef 106gfc_powdecl_list gfor_fndecl_math_powi[4][3];
4ee9c684 107tree gfor_fndecl_math_ishftc4;
108tree gfor_fndecl_math_ishftc8;
920e54ef 109tree gfor_fndecl_math_ishftc16;
4ee9c684 110
111
112/* String functions. */
113
4ee9c684 114tree gfor_fndecl_compare_string;
115tree gfor_fndecl_concat_string;
116tree gfor_fndecl_string_len_trim;
117tree gfor_fndecl_string_index;
118tree gfor_fndecl_string_scan;
119tree gfor_fndecl_string_verify;
120tree gfor_fndecl_string_trim;
5fcc6ec2 121tree gfor_fndecl_string_minmax;
4ee9c684 122tree gfor_fndecl_adjustl;
123tree gfor_fndecl_adjustr;
b44437b9 124tree gfor_fndecl_select_string;
40b806de 125tree gfor_fndecl_compare_string_char4;
126tree gfor_fndecl_concat_string_char4;
127tree gfor_fndecl_string_len_trim_char4;
128tree gfor_fndecl_string_index_char4;
129tree gfor_fndecl_string_scan_char4;
130tree gfor_fndecl_string_verify_char4;
131tree gfor_fndecl_string_trim_char4;
132tree gfor_fndecl_string_minmax_char4;
133tree gfor_fndecl_adjustl_char4;
134tree gfor_fndecl_adjustr_char4;
b44437b9 135tree gfor_fndecl_select_string_char4;
136
137
138/* Conversion between character kinds. */
139tree gfor_fndecl_convert_char1_to_char4;
140tree gfor_fndecl_convert_char4_to_char1;
4ee9c684 141
142
143/* Other misc. runtime library functions. */
144
145tree gfor_fndecl_size0;
146tree gfor_fndecl_size1;
9b057c29 147tree gfor_fndecl_iargc;
70eb4f1a 148tree gfor_fndecl_clz128;
149tree gfor_fndecl_ctz128;
4ee9c684 150
59e2a584 151/* Intrinsic functions implemented in Fortran. */
152tree gfor_fndecl_sc_kind;
4ee9c684 153tree gfor_fndecl_si_kind;
154tree gfor_fndecl_sr_kind;
155
4e8e57b0 156/* BLAS gemm functions. */
157tree gfor_fndecl_sgemm;
158tree gfor_fndecl_dgemm;
159tree gfor_fndecl_cgemm;
160tree gfor_fndecl_zgemm;
161
4ee9c684 162
163static void
164gfc_add_decl_to_parent_function (tree decl)
165{
22d678e8 166 gcc_assert (decl);
4ee9c684 167 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
168 DECL_NONLOCAL (decl) = 1;
169 TREE_CHAIN (decl) = saved_parent_function_decls;
170 saved_parent_function_decls = decl;
171}
172
173void
174gfc_add_decl_to_function (tree decl)
175{
22d678e8 176 gcc_assert (decl);
4ee9c684 177 TREE_USED (decl) = 1;
178 DECL_CONTEXT (decl) = current_function_decl;
179 TREE_CHAIN (decl) = saved_function_decls;
180 saved_function_decls = decl;
181}
182
183
b797d6d3 184/* Build a backend label declaration. Set TREE_USED for named labels.
185 The context of the label is always the current_function_decl. All
186 labels are marked artificial. */
4ee9c684 187
188tree
189gfc_build_label_decl (tree label_id)
190{
191 /* 2^32 temporaries should be enough. */
192 static unsigned int tmp_num = 1;
193 tree label_decl;
194 char *label_name;
195
196 if (label_id == NULL_TREE)
197 {
198 /* Build an internal label name. */
199 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
200 label_id = get_identifier (label_name);
201 }
202 else
203 label_name = NULL;
204
205 /* Build the LABEL_DECL node. Labels have no type. */
206 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
207 DECL_CONTEXT (label_decl) = current_function_decl;
208 DECL_MODE (label_decl) = VOIDmode;
209
b797d6d3 210 /* We always define the label as used, even if the original source
211 file never references the label. We don't want all kinds of
212 spurious warnings for old-style Fortran code with too many
213 labels. */
214 TREE_USED (label_decl) = 1;
4ee9c684 215
b797d6d3 216 DECL_ARTIFICIAL (label_decl) = 1;
4ee9c684 217 return label_decl;
218}
219
220
221/* Returns the return label for the current function. */
222
223tree
224gfc_get_return_label (void)
225{
226 char name[GFC_MAX_SYMBOL_LEN + 10];
227
228 if (current_function_return_label)
229 return current_function_return_label;
230
231 sprintf (name, "__return_%s",
232 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
233
234 current_function_return_label =
235 gfc_build_label_decl (get_identifier (name));
236
237 DECL_ARTIFICIAL (current_function_return_label) = 1;
238
239 return current_function_return_label;
240}
241
242
b31f705b 243/* Set the backend source location of a decl. */
244
245void
246gfc_set_decl_location (tree decl, locus * loc)
247{
b31f705b 248 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
b31f705b 249}
250
251
4ee9c684 252/* Return the backend label declaration for a given label structure,
253 or create it if it doesn't exist yet. */
254
255tree
256gfc_get_label_decl (gfc_st_label * lp)
257{
4ee9c684 258 if (lp->backend_decl)
259 return lp->backend_decl;
260 else
261 {
262 char label_name[GFC_MAX_SYMBOL_LEN + 1];
263 tree label_decl;
264
265 /* Validate the label declaration from the front end. */
22d678e8 266 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
4ee9c684 267
268 /* Build a mangled name for the label. */
269 sprintf (label_name, "__label_%.6d", lp->value);
270
271 /* Build the LABEL_DECL node. */
272 label_decl = gfc_build_label_decl (get_identifier (label_name));
273
274 /* Tell the debugger where the label came from. */
f888a3fb 275 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
b31f705b 276 gfc_set_decl_location (label_decl, &lp->where);
4ee9c684 277 else
278 DECL_ARTIFICIAL (label_decl) = 1;
279
280 /* Store the label in the label list and return the LABEL_DECL. */
281 lp->backend_decl = label_decl;
282 return label_decl;
283 }
284}
285
286
287/* Convert a gfc_symbol to an identifier of the same name. */
288
289static tree
290gfc_sym_identifier (gfc_symbol * sym)
291{
0509d0ee 292 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
293 return (get_identifier ("MAIN__"));
294 else
295 return (get_identifier (sym->name));
4ee9c684 296}
297
298
299/* Construct mangled name from symbol name. */
300
301static tree
302gfc_sym_mangled_identifier (gfc_symbol * sym)
303{
304 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
305
c5d33754 306 /* Prevent the mangling of identifiers that have an assigned
307 binding label (mainly those that are bind(c)). */
308 if (sym->attr.is_bind_c == 1
309 && sym->binding_label[0] != '\0')
310 return get_identifier(sym->binding_label);
311
4f0fae8e 312 if (sym->module == NULL)
4ee9c684 313 return gfc_sym_identifier (sym);
314 else
315 {
f08a3f6f 316 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
4ee9c684 317 return get_identifier (name);
318 }
319}
320
321
322/* Construct mangled function name from symbol name. */
323
324static tree
325gfc_sym_mangled_function_id (gfc_symbol * sym)
326{
327 int has_underscore;
328 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
329
c5d33754 330 /* It may be possible to simply use the binding label if it's
331 provided, and remove the other checks. Then we could use it
332 for other things if we wished. */
333 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
334 sym->binding_label[0] != '\0')
335 /* use the binding label rather than the mangled name */
336 return get_identifier (sym->binding_label);
337
4f0fae8e 338 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
12441a18 339 || (sym->module != NULL && (sym->attr.external
340 || sym->attr.if_source == IFSRC_IFBODY)))
4ee9c684 341 {
a2f97da7 342 /* Main program is mangled into MAIN__. */
343 if (sym->attr.is_main_program)
344 return get_identifier ("MAIN__");
345
346 /* Intrinsic procedures are never mangled. */
347 if (sym->attr.proc == PROC_INTRINSIC)
4ee9c684 348 return get_identifier (sym->name);
349
350 if (gfc_option.flag_underscoring)
351 {
352 has_underscore = strchr (sym->name, '_') != 0;
353 if (gfc_option.flag_second_underscore && has_underscore)
354 snprintf (name, sizeof name, "%s__", sym->name);
355 else
356 snprintf (name, sizeof name, "%s_", sym->name);
357 return get_identifier (name);
358 }
359 else
360 return get_identifier (sym->name);
361 }
362 else
363 {
f08a3f6f 364 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
4ee9c684 365 return get_identifier (name);
366 }
367}
368
369
5ed82495 370/* Returns true if a variable of specified size should go on the stack. */
371
372int
373gfc_can_put_var_on_stack (tree size)
374{
375 unsigned HOST_WIDE_INT low;
376
377 if (!INTEGER_CST_P (size))
378 return 0;
379
380 if (gfc_option.flag_max_stack_var_size < 0)
381 return 1;
382
383 if (TREE_INT_CST_HIGH (size) != 0)
384 return 0;
385
386 low = TREE_INT_CST_LOW (size);
387 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
388 return 0;
389
390/* TODO: Set a per-function stack size limit. */
391
392 return 1;
393}
394
395
b7bf3f81 396/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
397 an expression involving its corresponding pointer. There are
398 2 cases; one for variable size arrays, and one for everything else,
399 because variable-sized arrays require one fewer level of
400 indirection. */
401
402static void
403gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
404{
405 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
406 tree value;
407
408 /* Parameters need to be dereferenced. */
409 if (sym->cp_pointer->attr.dummy)
4fa2c167 410 ptr_decl = build_fold_indirect_ref (ptr_decl);
b7bf3f81 411
412 /* Check to see if we're dealing with a variable-sized array. */
413 if (sym->attr.dimension
414 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
415 {
942043f8 416 /* These decls will be dereferenced later, so we don't dereference
b7bf3f81 417 them here. */
418 value = convert (TREE_TYPE (decl), ptr_decl);
419 }
420 else
421 {
422 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
423 ptr_decl);
4fa2c167 424 value = build_fold_indirect_ref (ptr_decl);
b7bf3f81 425 }
426
427 SET_DECL_VALUE_EXPR (decl, value);
428 DECL_HAS_VALUE_EXPR_P (decl) = 1;
764f1175 429 GFC_DECL_CRAY_POINTEE (decl) = 1;
b7bf3f81 430 /* This is a fake variable just for debugging purposes. */
431 TREE_ASM_WRITTEN (decl) = 1;
432}
433
434
b9c7fce7 435/* Finish processing of a declaration without an initial value. */
4ee9c684 436
437static void
b9c7fce7 438gfc_finish_decl (tree decl)
4ee9c684 439{
b9c7fce7 440 gcc_assert (TREE_CODE (decl) == PARM_DECL
441 || DECL_INITIAL (decl) == NULL_TREE);
4ee9c684 442
b9c7fce7 443 if (TREE_CODE (decl) != VAR_DECL)
444 return;
4ee9c684 445
b9c7fce7 446 if (DECL_SIZE (decl) == NULL_TREE
447 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
448 layout_decl (decl, 0);
449
450 /* A few consistency checks. */
451 /* A static variable with an incomplete type is an error if it is
452 initialized. Also if it is not file scope. Otherwise, let it
453 through, but if it is not `extern' then it may cause an error
454 message later. */
455 /* An automatic variable with an incomplete type is an error. */
456
457 /* We should know the storage size. */
458 gcc_assert (DECL_SIZE (decl) != NULL_TREE
459 || (TREE_STATIC (decl)
460 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
461 : DECL_EXTERNAL (decl)));
462
463 /* The storage size should be constant. */
464 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
465 || !DECL_SIZE (decl)
466 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
4ee9c684 467}
468
469
470/* Apply symbol attributes to a variable, and add it to the function scope. */
471
472static void
473gfc_finish_var_decl (tree decl, gfc_symbol * sym)
474{
c1977dbe 475 tree new_type;
f888a3fb 476 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
4ee9c684 477 This is the equivalent of the TARGET variables.
478 We also need to set this if the variable is passed by reference in a
479 CALL statement. */
b549d2a5 480
b7bf3f81 481 /* Set DECL_VALUE_EXPR for Cray Pointees. */
b549d2a5 482 if (sym->attr.cray_pointee)
b7bf3f81 483 gfc_finish_cray_pointee (decl, sym);
b549d2a5 484
4ee9c684 485 if (sym->attr.target)
486 TREE_ADDRESSABLE (decl) = 1;
487 /* If it wasn't used we wouldn't be getting it. */
488 TREE_USED (decl) = 1;
489
490 /* Chain this decl to the pending declarations. Don't do pushdecl()
491 because this would add them to the current scope rather than the
492 function scope. */
493 if (current_function_decl != NULL_TREE)
494 {
7af6a4af 495 if (sym->ns->proc_name->backend_decl == current_function_decl
496 || sym->result == sym)
4ee9c684 497 gfc_add_decl_to_function (decl);
498 else
499 gfc_add_decl_to_parent_function (decl);
500 }
501
b7bf3f81 502 if (sym->attr.cray_pointee)
503 return;
504
c5d33754 505 if(sym->attr.is_bind_c == 1)
506 {
507 /* We need to put variables that are bind(c) into the common
508 segment of the object file, because this is what C would do.
509 gfortran would typically put them in either the BSS or
510 initialized data segments, and only mark them as common if
511 they were part of common blocks. However, if they are not put
512 into common space, then C cannot initialize global fortran
513 variables that it interoperates with and the draft says that
514 either Fortran or C should be able to initialize it (but not
515 both, of course.) (J3/04-007, section 15.3). */
516 TREE_PUBLIC(decl) = 1;
517 DECL_COMMON(decl) = 1;
518 }
519
4ee9c684 520 /* If a variable is USE associated, it's always external. */
521 if (sym->attr.use_assoc)
522 {
523 DECL_EXTERNAL (decl) = 1;
524 TREE_PUBLIC (decl) = 1;
525 }
4f0fae8e 526 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
4ee9c684 527 {
6b20224d 528 /* TODO: Don't set sym->module for result or dummy variables. */
7af6a4af 529 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
4ee9c684 530 /* This is the declaration of a module variable. */
531 TREE_PUBLIC (decl) = 1;
532 TREE_STATIC (decl) = 1;
533 }
534
f0d4969f 535 /* Derived types are a bit peculiar because of the possibility of
536 a default initializer; this must be applied each time the variable
537 comes into scope it therefore need not be static. These variables
538 are SAVE_NONE but have an initializer. Otherwise explicitly
69b1505f 539 initialized variables are SAVE_IMPLICIT and explicitly saved are
f0d4969f 540 SAVE_EXPLICIT. */
541 if (!sym->attr.use_assoc
542 && (sym->attr.save != SAVE_NONE || sym->attr.data
543 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
4ee9c684 544 TREE_STATIC (decl) = 1;
ef814c81 545
546 if (sym->attr.volatile_)
547 {
ef814c81 548 TREE_THIS_VOLATILE (decl) = 1;
c1977dbe 549 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
550 TREE_TYPE (decl) = new_type;
ef814c81 551 }
552
4ee9c684 553 /* Keep variables larger than max-stack-var-size off stack. */
554 if (!sym->ns->proc_name->attr.recursive
555 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
a3f2c0e1 556 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
557 /* Put variable length auto array pointers always into stack. */
558 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
559 || sym->attr.dimension == 0
560 || sym->as->type != AS_EXPLICIT
561 || sym->attr.pointer
562 || sym->attr.allocatable)
563 && !DECL_ARTIFICIAL (decl))
4ee9c684 564 TREE_STATIC (decl) = 1;
764f1175 565
566 /* Handle threadprivate variables. */
9dda1f80 567 if (sym->attr.threadprivate
764f1175 568 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
569 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
4ee9c684 570}
571
572
573/* Allocate the lang-specific part of a decl. */
574
575void
576gfc_allocate_lang_decl (tree decl)
577{
578 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
579 ggc_alloc_cleared (sizeof (struct lang_decl));
580}
581
582/* Remember a symbol to generate initialization/cleanup code at function
583 entry/exit. */
584
585static void
586gfc_defer_symbol_init (gfc_symbol * sym)
587{
588 gfc_symbol *p;
589 gfc_symbol *last;
590 gfc_symbol *head;
591
592 /* Don't add a symbol twice. */
593 if (sym->tlink)
594 return;
595
596 last = head = sym->ns->proc_name;
597 p = last->tlink;
598
599 /* Make sure that setup code for dummy variables which are used in the
600 setup of other variables is generated first. */
601 if (sym->attr.dummy)
602 {
603 /* Find the first dummy arg seen after us, or the first non-dummy arg.
604 This is a circular list, so don't go past the head. */
605 while (p != head
606 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
607 {
608 last = p;
609 p = p->tlink;
610 }
611 }
612 /* Insert in between last and p. */
613 last->tlink = sym;
614 sym->tlink = p;
615}
616
617
618/* Create an array index type variable with function scope. */
619
620static tree
621create_index_var (const char * pfx, int nest)
622{
623 tree decl;
624
625 decl = gfc_create_var_np (gfc_array_index_type, pfx);
626 if (nest)
627 gfc_add_decl_to_parent_function (decl);
628 else
629 gfc_add_decl_to_function (decl);
630 return decl;
631}
632
633
634/* Create variables to hold all the non-constant bits of info for a
635 descriptorless array. Remember these in the lang-specific part of the
636 type. */
637
638static void
639gfc_build_qualified_array (tree decl, gfc_symbol * sym)
640{
641 tree type;
642 int dim;
643 int nest;
644
645 type = TREE_TYPE (decl);
646
647 /* We just use the descriptor, if there is one. */
648 if (GFC_DESCRIPTOR_TYPE_P (type))
649 return;
650
22d678e8 651 gcc_assert (GFC_ARRAY_TYPE_P (type));
4ee9c684 652 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
653 && !sym->attr.contained;
654
655 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
656 {
657 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
86254bbf 658 {
659 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
660 TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
661 }
9ca15c9b 662 /* Don't try to use the unknown bound for assumed shape arrays. */
4ee9c684 663 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
664 && (sym->as->type != AS_ASSUMED_SIZE
665 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
86254bbf 666 {
667 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
668 TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
669 }
4ee9c684 670
671 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
86254bbf 672 {
673 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
674 TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
675 }
4ee9c684 676 }
677 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
678 {
679 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
680 "offset");
86254bbf 681 TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
682
4ee9c684 683 if (nest)
684 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
685 else
686 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
687 }
d4163395 688
689 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
690 && sym->as->type != AS_ASSUMED_SIZE)
86254bbf 691 {
692 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
693 TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
694 }
d4163395 695
696 if (POINTER_TYPE_P (type))
697 {
698 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
699 gcc_assert (TYPE_LANG_SPECIFIC (type)
700 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
701 type = TREE_TYPE (type);
702 }
703
704 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
705 {
706 tree size, range;
707
f75d6b8a 708 size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
709 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
d4163395 710 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
711 size);
712 TYPE_DOMAIN (type) = range;
713 layout_type (type);
714 }
6cf159a6 715
6cf159a6 716 if (TYPE_NAME (type) != NULL_TREE
717 && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
718 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
719 {
720 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
721
722 for (dim = 0; dim < sym->as->rank - 1; dim++)
723 {
724 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
725 gtype = TREE_TYPE (gtype);
726 }
727 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
728 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
729 TYPE_NAME (type) = NULL_TREE;
730 }
731
732 if (TYPE_NAME (type) == NULL_TREE)
733 {
734 tree gtype = TREE_TYPE (type), rtype, type_decl;
735
736 for (dim = sym->as->rank - 1; dim >= 0; dim--)
737 {
738 rtype = build_range_type (gfc_array_index_type,
739 GFC_TYPE_ARRAY_LBOUND (type, dim),
740 GFC_TYPE_ARRAY_UBOUND (type, dim));
741 gtype = build_array_type (gtype, rtype);
742 /* Ensure the bound variables aren't optimized out at -O0. */
743 if (!optimize)
744 {
745 if (GFC_TYPE_ARRAY_LBOUND (type, dim)
746 && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
747 DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
748 if (GFC_TYPE_ARRAY_UBOUND (type, dim)
749 && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
750 DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
751 }
752 }
753 TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
754 DECL_ORIGINAL_TYPE (type_decl) = gtype;
755 }
4ee9c684 756}
757
758
759/* For some dummy arguments we don't use the actual argument directly.
5ed82495 760 Instead we create a local decl and use that. This allows us to perform
4ee9c684 761 initialization, and construct full type information. */
762
763static tree
764gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
765{
766 tree decl;
767 tree type;
768 gfc_array_spec *as;
769 char *name;
3d8dea5a 770 gfc_packed packed;
4ee9c684 771 int n;
772 bool known_size;
773
774 if (sym->attr.pointer || sym->attr.allocatable)
775 return dummy;
776
777 /* Add to list of variables if not a fake result variable. */
778 if (sym->attr.result || sym->attr.dummy)
779 gfc_defer_symbol_init (sym);
780
781 type = TREE_TYPE (dummy);
22d678e8 782 gcc_assert (TREE_CODE (dummy) == PARM_DECL
4ee9c684 783 && POINTER_TYPE_P (type));
784
f888a3fb 785 /* Do we know the element size? */
4ee9c684 786 known_size = sym->ts.type != BT_CHARACTER
787 || INTEGER_CST_P (sym->ts.cl->backend_decl);
788
789 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
790 {
791 /* For descriptorless arrays with known element size the actual
792 argument is sufficient. */
22d678e8 793 gcc_assert (GFC_ARRAY_TYPE_P (type));
4ee9c684 794 gfc_build_qualified_array (dummy, sym);
795 return dummy;
796 }
797
798 type = TREE_TYPE (type);
799 if (GFC_DESCRIPTOR_TYPE_P (type))
800 {
cb8e3560 801 /* Create a descriptorless array pointer. */
4ee9c684 802 as = sym->as;
3d8dea5a 803 packed = PACKED_NO;
3d235846 804
805 /* Even when -frepack-arrays is used, symbols with TARGET attribute
806 are not repacked. */
807 if (!gfc_option.flag_repack_arrays || sym->attr.target)
4ee9c684 808 {
809 if (as->type == AS_ASSUMED_SIZE)
3d8dea5a 810 packed = PACKED_FULL;
4ee9c684 811 }
812 else
813 {
814 if (as->type == AS_EXPLICIT)
815 {
3d8dea5a 816 packed = PACKED_FULL;
4ee9c684 817 for (n = 0; n < as->rank; n++)
818 {
819 if (!(as->upper[n]
820 && as->lower[n]
821 && as->upper[n]->expr_type == EXPR_CONSTANT
822 && as->lower[n]->expr_type == EXPR_CONSTANT))
3d8dea5a 823 packed = PACKED_PARTIAL;
4ee9c684 824 }
825 }
826 else
3d8dea5a 827 packed = PACKED_PARTIAL;
4ee9c684 828 }
829
830 type = gfc_typenode_for_spec (&sym->ts);
831 type = gfc_get_nodesc_array_type (type, sym->as, packed);
832 }
833 else
834 {
835 /* We now have an expression for the element size, so create a fully
836 qualified type. Reset sym->backend decl or this will just return the
837 old type. */
d95efb59 838 DECL_ARTIFICIAL (sym->backend_decl) = 1;
4ee9c684 839 sym->backend_decl = NULL_TREE;
840 type = gfc_sym_type (sym);
3d8dea5a 841 packed = PACKED_FULL;
4ee9c684 842 }
843
844 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
845 decl = build_decl (VAR_DECL, get_identifier (name), type);
846
847 DECL_ARTIFICIAL (decl) = 1;
848 TREE_PUBLIC (decl) = 0;
849 TREE_STATIC (decl) = 0;
850 DECL_EXTERNAL (decl) = 0;
851
852 /* We should never get deferred shape arrays here. We used to because of
853 frontend bugs. */
22d678e8 854 gcc_assert (sym->as->type != AS_DEFERRED);
4ee9c684 855
3d8dea5a 856 if (packed == PACKED_PARTIAL)
857 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
858 else if (packed == PACKED_FULL)
859 GFC_DECL_PACKED_ARRAY (decl) = 1;
4ee9c684 860
861 gfc_build_qualified_array (decl, sym);
862
863 if (DECL_LANG_SPECIFIC (dummy))
864 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
865 else
866 gfc_allocate_lang_decl (decl);
867
868 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
869
870 if (sym->ns->proc_name->backend_decl == current_function_decl
871 || sym->attr.contained)
872 gfc_add_decl_to_function (decl);
873 else
874 gfc_add_decl_to_parent_function (decl);
875
876 return decl;
877}
878
9579733e 879/* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
880 function add a VAR_DECL to the current function with DECL_VALUE_EXPR
881 pointing to the artificial variable for debug info purposes. */
882
883static void
884gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
885{
886 tree decl, dummy;
887
888 if (! nonlocal_dummy_decl_pset)
889 nonlocal_dummy_decl_pset = pointer_set_create ();
890
891 if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
892 return;
893
894 dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
895 decl = build_decl (VAR_DECL, DECL_NAME (dummy),
896 TREE_TYPE (sym->backend_decl));
897 DECL_ARTIFICIAL (decl) = 0;
898 TREE_USED (decl) = 1;
899 TREE_PUBLIC (decl) = 0;
900 TREE_STATIC (decl) = 0;
901 DECL_EXTERNAL (decl) = 0;
902 if (DECL_BY_REFERENCE (dummy))
903 DECL_BY_REFERENCE (decl) = 1;
904 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
905 SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
906 DECL_HAS_VALUE_EXPR_P (decl) = 1;
907 DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
908 TREE_CHAIN (decl) = nonlocal_dummy_decls;
909 nonlocal_dummy_decls = decl;
910}
4ee9c684 911
912/* Return a constant or a variable to use as a string length. Does not
913 add the decl to the current scope. */
914
915static tree
916gfc_create_string_length (gfc_symbol * sym)
917{
22d678e8 918 gcc_assert (sym->ts.cl);
4ee9c684 919 gfc_conv_const_charlen (sym->ts.cl);
a4abf8a0 920
4ee9c684 921 if (sym->ts.cl->backend_decl == NULL_TREE)
922 {
a4abf8a0 923 tree length;
4ee9c684 924 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
925
926 /* Also prefix the mangled name. */
927 strcpy (&name[1], sym->name);
928 name[0] = '.';
929 length = build_decl (VAR_DECL, get_identifier (name),
9ad09405 930 gfc_charlen_type_node);
4ee9c684 931 DECL_ARTIFICIAL (length) = 1;
932 TREE_USED (length) = 1;
d4163395 933 if (sym->ns->proc_name->tlink != NULL)
934 gfc_defer_symbol_init (sym);
a4abf8a0 935
4ee9c684 936 sym->ts.cl->backend_decl = length;
937 }
938
a4abf8a0 939 gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
4ee9c684 940 return sym->ts.cl->backend_decl;
941}
942
c8f1568f 943/* If a variable is assigned a label, we add another two auxiliary
944 variables. */
945
946static void
947gfc_add_assign_aux_vars (gfc_symbol * sym)
948{
949 tree addr;
950 tree length;
951 tree decl;
952
953 gcc_assert (sym->backend_decl);
954
955 decl = sym->backend_decl;
956 gfc_allocate_lang_decl (decl);
957 GFC_DECL_ASSIGN (decl) = 1;
958 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
959 gfc_charlen_type_node);
960 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
961 pvoid_type_node);
962 gfc_finish_var_decl (length, sym);
963 gfc_finish_var_decl (addr, sym);
964 /* STRING_LENGTH is also used as flag. Less than -1 means that
965 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
966 target label's address. Otherwise, value is the length of a format string
967 and ASSIGN_ADDR is its address. */
968 if (TREE_STATIC (length))
969 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
970 else
971 gfc_defer_symbol_init (sym);
972
973 GFC_DECL_STRING_LEN (decl) = length;
974 GFC_DECL_ASSIGN_ADDR (decl) = addr;
975}
4ee9c684 976
977/* Return the decl for a gfc_symbol, create it if it doesn't already
978 exist. */
979
980tree
981gfc_get_symbol_decl (gfc_symbol * sym)
982{
983 tree decl;
984 tree length = NULL_TREE;
4ee9c684 985 int byref;
986
0b5dc8b5 987 gcc_assert (sym->attr.referenced
d0f6ad22 988 || sym->attr.use_assoc
989 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
4ee9c684 990
991 if (sym->ns && sym->ns->proc_name->attr.function)
992 byref = gfc_return_by_reference (sym->ns->proc_name);
993 else
994 byref = 0;
995
996 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
997 {
998 /* Return via extra parameter. */
999 if (sym->attr.result && byref
1000 && !sym->backend_decl)
1001 {
1002 sym->backend_decl =
1003 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
c6871095 1004 /* For entry master function skip over the __entry
1005 argument. */
1006 if (sym->ns->proc_name->attr.entry_master)
1007 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
4ee9c684 1008 }
1009
1010 /* Dummy variables should already have been created. */
22d678e8 1011 gcc_assert (sym->backend_decl);
4ee9c684 1012
1013 /* Create a character length variable. */
1014 if (sym->ts.type == BT_CHARACTER)
1015 {
1016 if (sym->ts.cl->backend_decl == NULL_TREE)
d4163395 1017 length = gfc_create_string_length (sym);
1018 else
1019 length = sym->ts.cl->backend_decl;
1020 if (TREE_CODE (length) == VAR_DECL
1021 && DECL_CONTEXT (length) == NULL_TREE)
4ee9c684 1022 {
d95efb59 1023 /* Add the string length to the same context as the symbol. */
1024 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1025 gfc_add_decl_to_function (length);
1026 else
1027 gfc_add_decl_to_parent_function (length);
1028
1029 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1030 DECL_CONTEXT (length));
1031
d4163395 1032 gfc_defer_symbol_init (sym);
e8ff3944 1033 }
4ee9c684 1034 }
1035
1036 /* Use a copy of the descriptor for dummy arrays. */
1037 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1038 {
d95efb59 1039 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1040 /* Prevent the dummy from being detected as unused if it is copied. */
1041 if (sym->backend_decl != NULL && decl != sym->backend_decl)
1042 DECL_ARTIFICIAL (sym->backend_decl) = 1;
1043 sym->backend_decl = decl;
4ee9c684 1044 }
1045
1046 TREE_USED (sym->backend_decl) = 1;
c8f1568f 1047 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1048 {
1049 gfc_add_assign_aux_vars (sym);
1050 }
9579733e 1051
1052 if (sym->attr.dimension
1053 && DECL_LANG_SPECIFIC (sym->backend_decl)
1054 && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1055 && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1056 gfc_nonlocal_dummy_array_decl (sym);
1057
4ee9c684 1058 return sym->backend_decl;
1059 }
1060
1061 if (sym->backend_decl)
1062 return sym->backend_decl;
1063
7251ca54 1064 /* Catch function declarations. Only used for actual parameters and
1065 procedure pointers. */
4ee9c684 1066 if (sym->attr.flavor == FL_PROCEDURE)
1067 {
1068 decl = gfc_get_extern_function_decl (sym);
7251ca54 1069 gfc_set_decl_location (decl, &sym->declared_at);
4ee9c684 1070 return decl;
1071 }
1072
1073 if (sym->attr.intrinsic)
1074 internal_error ("intrinsic variable which isn't a procedure");
1075
1076 /* Create string length decl first so that they can be used in the
1077 type declaration. */
1078 if (sym->ts.type == BT_CHARACTER)
1079 length = gfc_create_string_length (sym);
1080
1081 /* Create the decl for the variable. */
1082 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1083
b31f705b 1084 gfc_set_decl_location (decl, &sym->declared_at);
1085
f888a3fb 1086 /* Symbols from modules should have their assembler names mangled.
4ee9c684 1087 This is done here rather than in gfc_finish_var_decl because it
1088 is different for string length variables. */
4f0fae8e 1089 if (sym->module)
df4d540f 1090 {
1091 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
1092 if (sym->attr.use_assoc)
1093 DECL_IGNORED_P (decl) = 1;
1094 }
4ee9c684 1095
1096 if (sym->attr.dimension)
1097 {
1098 /* Create variables to hold the non-constant bits of array info. */
1099 gfc_build_qualified_array (decl, sym);
1100
1101 /* Remember this variable for allocation/cleanup. */
1102 gfc_defer_symbol_init (sym);
1103
1104 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1105 GFC_DECL_PACKED_ARRAY (decl) = 1;
1106 }
1107
2294b616 1108 if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
1109 gfc_defer_symbol_init (sym);
f0d4969f 1110 /* This applies a derived type default initializer. */
1111 else if (sym->ts.type == BT_DERIVED
1112 && sym->attr.save == SAVE_NONE
1113 && !sym->attr.data
1114 && !sym->attr.allocatable
1115 && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1116 && !sym->attr.use_assoc)
1117 gfc_defer_symbol_init (sym);
2294b616 1118
4ee9c684 1119 gfc_finish_var_decl (decl, sym);
1120
bda1f152 1121 if (sym->ts.type == BT_CHARACTER)
4ee9c684 1122 {
4ee9c684 1123 /* Character variables need special handling. */
1124 gfc_allocate_lang_decl (decl);
1125
bda1f152 1126 if (TREE_CODE (length) != INTEGER_CST)
4ee9c684 1127 {
1128 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1129
4f0fae8e 1130 if (sym->module)
4ee9c684 1131 {
1132 /* Also prefix the mangled name for symbols from modules. */
1133 strcpy (&name[1], sym->name);
1134 name[0] = '.';
1135 strcpy (&name[1],
1136 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1137 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1138 }
1139 gfc_finish_var_decl (length, sym);
22d678e8 1140 gcc_assert (!sym->value);
4ee9c684 1141 }
4ee9c684 1142 }
1033248c 1143 else if (sym->attr.subref_array_pointer)
1144 {
1145 /* We need the span for these beasts. */
1146 gfc_allocate_lang_decl (decl);
1147 }
1148
1149 if (sym->attr.subref_array_pointer)
1150 {
1151 tree span;
1152 GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1153 span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
1154 gfc_array_index_type);
1155 gfc_finish_var_decl (span, sym);
6180d82a 1156 TREE_STATIC (span) = TREE_STATIC (decl);
1157 DECL_ARTIFICIAL (span) = 1;
1158 DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1033248c 1159
1160 GFC_DECL_SPAN (decl) = span;
6180d82a 1161 GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1033248c 1162 }
1163
4ee9c684 1164 sym->backend_decl = decl;
1165
c8f1568f 1166 if (sym->attr.assign)
21ebda4d 1167 gfc_add_assign_aux_vars (sym);
c8f1568f 1168
bda1f152 1169 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1170 {
1171 /* Add static initializer. */
1172 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1173 TREE_TYPE (decl), sym->attr.dimension,
1174 sym->attr.pointer || sym->attr.allocatable);
1175 }
1176
9579733e 1177 if (!TREE_STATIC (decl)
1178 && POINTER_TYPE_P (TREE_TYPE (decl))
1179 && !sym->attr.pointer
1180 && !sym->attr.allocatable
1181 && !sym->attr.proc_pointer)
1182 DECL_BY_REFERENCE (decl) = 1;
1183
4ee9c684 1184 return decl;
1185}
1186
1187
dbe60343 1188/* Substitute a temporary variable in place of the real one. */
1189
1190void
1191gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1192{
1193 save->attr = sym->attr;
1194 save->decl = sym->backend_decl;
1195
1196 gfc_clear_attr (&sym->attr);
1197 sym->attr.referenced = 1;
1198 sym->attr.flavor = FL_VARIABLE;
1199
1200 sym->backend_decl = decl;
1201}
1202
1203
1204/* Restore the original variable. */
1205
1206void
1207gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1208{
1209 sym->attr = save->attr;
1210 sym->backend_decl = save->decl;
1211}
1212
1213
cad0ddcf 1214/* Declare a procedure pointer. */
1215
1216static tree
1217get_proc_pointer_decl (gfc_symbol *sym)
1218{
1219 tree decl;
1220
1221 decl = sym->backend_decl;
1222 if (decl)
1223 return decl;
1224
1225 decl = build_decl (VAR_DECL, get_identifier (sym->name),
1226 build_pointer_type (gfc_get_function_type (sym)));
1227
e72f979a 1228 if ((sym->ns->proc_name
1229 && sym->ns->proc_name->backend_decl == current_function_decl)
cad0ddcf 1230 || sym->attr.contained)
1231 gfc_add_decl_to_function (decl);
cf269acc 1232 else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
cad0ddcf 1233 gfc_add_decl_to_parent_function (decl);
1234
1235 sym->backend_decl = decl;
1236
cf269acc 1237 /* If a variable is USE associated, it's always external. */
1238 if (sym->attr.use_assoc)
1239 {
1240 DECL_EXTERNAL (decl) = 1;
1241 TREE_PUBLIC (decl) = 1;
1242 }
1243 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1244 {
1245 /* This is the declaration of a module variable. */
1246 TREE_PUBLIC (decl) = 1;
1247 TREE_STATIC (decl) = 1;
1248 }
1249
cad0ddcf 1250 if (!sym->attr.use_assoc
1251 && (sym->attr.save != SAVE_NONE || sym->attr.data
1252 || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1253 TREE_STATIC (decl) = 1;
1254
1255 if (TREE_STATIC (decl) && sym->value)
1256 {
1257 /* Add static initializer. */
1258 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1259 TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
1260 }
1261
1262 return decl;
1263}
1264
1265
4ee9c684 1266/* Get a basic decl for an external function. */
1267
1268tree
1269gfc_get_extern_function_decl (gfc_symbol * sym)
1270{
1271 tree type;
1272 tree fndecl;
1273 gfc_expr e;
1274 gfc_intrinsic_sym *isym;
1275 gfc_expr argexpr;
17000b91 1276 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
4ee9c684 1277 tree name;
1278 tree mangled_name;
83aeedb9 1279 gfc_gsymbol *gsym;
4ee9c684 1280
1281 if (sym->backend_decl)
1282 return sym->backend_decl;
1283
1b716045 1284 /* We should never be creating external decls for alternate entry points.
1285 The procedure may be an alternate entry point, but we don't want/need
1286 to know that. */
22d678e8 1287 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1b716045 1288
cad0ddcf 1289 if (sym->attr.proc_pointer)
1290 return get_proc_pointer_decl (sym);
1291
83aeedb9 1292 /* See if this is an external procedure from the same file. If so,
1293 return the backend_decl. */
1294 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
1295
1296 if (gfc_option.flag_whole_file
1297 && !sym->backend_decl
1298 && gsym && gsym->ns
1299 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1300 && gsym->ns->proc_name->backend_decl)
1301 {
1302 /* If the namespace has entries, the proc_name is the
1303 entry master. Find the entry and use its backend_decl.
1304 otherwise, use the proc_name backend_decl. */
1305 if (gsym->ns->entries)
1306 {
1307 gfc_entry_list *entry = gsym->ns->entries;
1308
1309 for (; entry; entry = entry->next)
1310 {
1311 if (strcmp (gsym->name, entry->sym->name) == 0)
1312 {
1313 sym->backend_decl = entry->sym->backend_decl;
1314 break;
1315 }
1316 }
1317 }
1318 else
1319 {
1320 sym->backend_decl = gsym->ns->proc_name->backend_decl;
1321 }
1322
1323 if (sym->backend_decl)
1324 return sym->backend_decl;
1325 }
1326
4ee9c684 1327 if (sym->attr.intrinsic)
1328 {
1329 /* Call the resolution function to get the actual name. This is
1330 a nasty hack which relies on the resolution functions only looking
1331 at the first argument. We pass NULL for the second argument
1332 otherwise things like AINT get confused. */
1333 isym = gfc_find_function (sym->name);
22d678e8 1334 gcc_assert (isym->resolve.f0 != NULL);
4ee9c684 1335
1336 memset (&e, 0, sizeof (e));
1337 e.expr_type = EXPR_FUNCTION;
1338
1339 memset (&argexpr, 0, sizeof (argexpr));
22d678e8 1340 gcc_assert (isym->formal);
4ee9c684 1341 argexpr.ts = isym->formal->ts;
1342
1343 if (isym->formal->next == NULL)
1344 isym->resolve.f1 (&e, &argexpr);
1345 else
1346 {
37e0271a 1347 if (isym->formal->next->next == NULL)
1348 isym->resolve.f2 (&e, &argexpr, NULL);
1349 else
1350 {
7fe55cc9 1351 if (isym->formal->next->next->next == NULL)
1352 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1353 else
1354 {
1355 /* All specific intrinsics take less than 5 arguments. */
1356 gcc_assert (isym->formal->next->next->next->next == NULL);
1357 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1358 }
37e0271a 1359 }
4ee9c684 1360 }
bdaed7d2 1361
1362 if (gfc_option.flag_f2c
1363 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1364 || e.ts.type == BT_COMPLEX))
1365 {
1366 /* Specific which needs a different implementation if f2c
1367 calling conventions are used. */
17000b91 1368 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
bdaed7d2 1369 }
1370 else
17000b91 1371 sprintf (s, "_gfortran_specific%s", e.value.function.name);
bdaed7d2 1372
4ee9c684 1373 name = get_identifier (s);
1374 mangled_name = name;
1375 }
1376 else
1377 {
1378 name = gfc_sym_identifier (sym);
1379 mangled_name = gfc_sym_mangled_function_id (sym);
1380 }
1381
1382 type = gfc_get_function_type (sym);
1383 fndecl = build_decl (FUNCTION_DECL, name, type);
1384
1385 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1386 /* If the return type is a pointer, avoid alias issues by setting
1387 DECL_IS_MALLOC to nonzero. This means that the function should be
1388 treated as if it were a malloc, meaning it returns a pointer that
1389 is not an alias. */
1390 if (POINTER_TYPE_P (type))
1391 DECL_IS_MALLOC (fndecl) = 1;
1392
1393 /* Set the context of this decl. */
1394 if (0 && sym->ns && sym->ns->proc_name)
1395 {
1396 /* TODO: Add external decls to the appropriate scope. */
1397 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1398 }
1399 else
1400 {
f888a3fb 1401 /* Global declaration, e.g. intrinsic subroutine. */
4ee9c684 1402 DECL_CONTEXT (fndecl) = NULL_TREE;
1403 }
1404
1405 DECL_EXTERNAL (fndecl) = 1;
1406
f888a3fb 1407 /* This specifies if a function is globally addressable, i.e. it is
4ee9c684 1408 the opposite of declaring static in C. */
1409 TREE_PUBLIC (fndecl) = 1;
1410
1411 /* Set attributes for PURE functions. A call to PURE function in the
1412 Fortran 95 sense is both pure and without side effects in the C
1413 sense. */
1414 if (sym->attr.pure || sym->attr.elemental)
1415 {
4d4b9f0e 1416 if (sym->attr.function && !gfc_return_by_reference (sym))
9c2a0c05 1417 DECL_PURE_P (fndecl) = 1;
be393645 1418 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1419 parameters and don't use alternate returns (is this
1420 allowed?). In that case, calls to them are meaningless, and
1b716045 1421 can be optimized away. See also in build_function_decl(). */
be393645 1422 TREE_SIDE_EFFECTS (fndecl) = 0;
4ee9c684 1423 }
1424
6e27d773 1425 /* Mark non-returning functions. */
1426 if (sym->attr.noreturn)
1427 TREE_THIS_VOLATILE(fndecl) = 1;
1428
4ee9c684 1429 sym->backend_decl = fndecl;
1430
1431 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1432 pushdecl_top_level (fndecl);
1433
1434 return fndecl;
1435}
1436
1437
1438/* Create a declaration for a procedure. For external functions (in the C
1b716045 1439 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1440 a master function with alternate entry points. */
4ee9c684 1441
1b716045 1442static void
1443build_function_decl (gfc_symbol * sym)
4ee9c684 1444{
1b716045 1445 tree fndecl, type;
4ee9c684 1446 symbol_attribute attr;
1b716045 1447 tree result_decl;
4ee9c684 1448 gfc_formal_arglist *f;
1449
22d678e8 1450 gcc_assert (!sym->backend_decl);
1451 gcc_assert (!sym->attr.external);
4ee9c684 1452
b31f705b 1453 /* Set the line and filename. sym->declared_at seems to point to the
1454 last statement for subroutines, but it'll do for now. */
1455 gfc_set_backend_locus (&sym->declared_at);
1456
4ee9c684 1457 /* Allow only one nesting level. Allow public declarations. */
22d678e8 1458 gcc_assert (current_function_decl == NULL_TREE
df4d540f 1459 || DECL_CONTEXT (current_function_decl) == NULL_TREE
1460 || TREE_CODE (DECL_CONTEXT (current_function_decl))
1461 == NAMESPACE_DECL);
4ee9c684 1462
1463 type = gfc_get_function_type (sym);
1464 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1465
1466 /* Perform name mangling if this is a top level or module procedure. */
1467 if (current_function_decl == NULL_TREE)
1468 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1469
1470 /* Figure out the return type of the declared function, and build a
f888a3fb 1471 RESULT_DECL for it. If this is a subroutine with alternate
4ee9c684 1472 returns, build a RESULT_DECL for it. */
1473 attr = sym->attr;
1474
1475 result_decl = NULL_TREE;
1476 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1477 if (attr.function)
1478 {
1479 if (gfc_return_by_reference (sym))
1480 type = void_type_node;
1481 else
1482 {
1483 if (sym->result != sym)
1484 result_decl = gfc_sym_identifier (sym->result);
1485
1486 type = TREE_TYPE (TREE_TYPE (fndecl));
1487 }
1488 }
1489 else
1490 {
1491 /* Look for alternate return placeholders. */
1492 int has_alternate_returns = 0;
1493 for (f = sym->formal; f; f = f->next)
1494 {
1495 if (f->sym == NULL)
1496 {
1497 has_alternate_returns = 1;
1498 break;
1499 }
1500 }
1501
1502 if (has_alternate_returns)
1503 type = integer_type_node;
1504 else
1505 type = void_type_node;
1506 }
1507
1508 result_decl = build_decl (RESULT_DECL, result_decl, type);
540edea7 1509 DECL_ARTIFICIAL (result_decl) = 1;
1510 DECL_IGNORED_P (result_decl) = 1;
4ee9c684 1511 DECL_CONTEXT (result_decl) = fndecl;
1512 DECL_RESULT (fndecl) = result_decl;
1513
1514 /* Don't call layout_decl for a RESULT_DECL.
f888a3fb 1515 layout_decl (result_decl, 0); */
4ee9c684 1516
1517 /* If the return type is a pointer, avoid alias issues by setting
1518 DECL_IS_MALLOC to nonzero. This means that the function should be
1519 treated as if it were a malloc, meaning it returns a pointer that
1520 is not an alias. */
1521 if (POINTER_TYPE_P (type))
1522 DECL_IS_MALLOC (fndecl) = 1;
1523
1524 /* Set up all attributes for the function. */
1525 DECL_CONTEXT (fndecl) = current_function_decl;
1526 DECL_EXTERNAL (fndecl) = 0;
1527
9d138f47 1528 /* This specifies if a function is globally visible, i.e. it is
dfc222eb 1529 the opposite of declaring static in C. */
1b716045 1530 if (DECL_CONTEXT (fndecl) == NULL_TREE
7257a5d2 1531 && !sym->attr.entry_master && !sym->attr.is_main_program)
4ee9c684 1532 TREE_PUBLIC (fndecl) = 1;
1533
1534 /* TREE_STATIC means the function body is defined here. */
e4b2c26c 1535 TREE_STATIC (fndecl) = 1;
4ee9c684 1536
f888a3fb 1537 /* Set attributes for PURE functions. A call to a PURE function in the
4ee9c684 1538 Fortran 95 sense is both pure and without side effects in the C
1539 sense. */
1540 if (attr.pure || attr.elemental)
1541 {
be393645 1542 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
a0527218 1543 including an alternate return. In that case it can also be
231e961a 1544 marked as PURE. See also in gfc_get_extern_function_decl(). */
4c319962 1545 if (attr.function && !gfc_return_by_reference (sym))
9c2a0c05 1546 DECL_PURE_P (fndecl) = 1;
4ee9c684 1547 TREE_SIDE_EFFECTS (fndecl) = 0;
1548 }
1549
1550 /* Layout the function declaration and put it in the binding level
1551 of the current function. */
e4b2c26c 1552 pushdecl (fndecl);
1b716045 1553
1554 sym->backend_decl = fndecl;
1555}
1556
1557
1558/* Create the DECL_ARGUMENTS for a procedure. */
1559
1560static void
1561create_function_arglist (gfc_symbol * sym)
1562{
1563 tree fndecl;
1564 gfc_formal_arglist *f;
d4163395 1565 tree typelist, hidden_typelist;
1566 tree arglist, hidden_arglist;
1b716045 1567 tree type;
1568 tree parm;
1569
1570 fndecl = sym->backend_decl;
1571
e4b2c26c 1572 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1573 the new FUNCTION_DECL node. */
e4b2c26c 1574 arglist = NULL_TREE;
d4163395 1575 hidden_arglist = NULL_TREE;
e4b2c26c 1576 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1b716045 1577
1578 if (sym->attr.entry_master)
1579 {
1580 type = TREE_VALUE (typelist);
1581 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1582
1583 DECL_CONTEXT (parm) = fndecl;
1584 DECL_ARG_TYPE (parm) = type;
1585 TREE_READONLY (parm) = 1;
b9c7fce7 1586 gfc_finish_decl (parm);
d95efb59 1587 DECL_ARTIFICIAL (parm) = 1;
1b716045 1588
1589 arglist = chainon (arglist, parm);
1590 typelist = TREE_CHAIN (typelist);
1591 }
1592
e4b2c26c 1593 if (gfc_return_by_reference (sym))
4ee9c684 1594 {
d4163395 1595 tree type = TREE_VALUE (typelist), length = NULL;
4ee9c684 1596
e4b2c26c 1597 if (sym->ts.type == BT_CHARACTER)
1598 {
e4b2c26c 1599 /* Length of character result. */
d4163395 1600 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1601 gcc_assert (len_type == gfc_charlen_type_node);
4ee9c684 1602
e4b2c26c 1603 length = build_decl (PARM_DECL,
1604 get_identifier (".__result"),
d4163395 1605 len_type);
e4b2c26c 1606 if (!sym->ts.cl->length)
1607 {
1608 sym->ts.cl->backend_decl = length;
1609 TREE_USED (length) = 1;
4ee9c684 1610 }
22d678e8 1611 gcc_assert (TREE_CODE (length) == PARM_DECL);
e4b2c26c 1612 DECL_CONTEXT (length) = fndecl;
d4163395 1613 DECL_ARG_TYPE (length) = len_type;
e4b2c26c 1614 TREE_READONLY (length) = 1;
b5b40b3f 1615 DECL_ARTIFICIAL (length) = 1;
b9c7fce7 1616 gfc_finish_decl (length);
d4163395 1617 if (sym->ts.cl->backend_decl == NULL
1618 || sym->ts.cl->backend_decl == length)
1619 {
1620 gfc_symbol *arg;
1621 tree backend_decl;
4ee9c684 1622
d4163395 1623 if (sym->ts.cl->backend_decl == NULL)
1624 {
1625 tree len = build_decl (VAR_DECL,
1626 get_identifier ("..__result"),
1627 gfc_charlen_type_node);
1628 DECL_ARTIFICIAL (len) = 1;
1629 TREE_USED (len) = 1;
1630 sym->ts.cl->backend_decl = len;
1631 }
4ee9c684 1632
d4163395 1633 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1634 arg = sym->result ? sym->result : sym;
1635 backend_decl = arg->backend_decl;
1636 /* Temporary clear it, so that gfc_sym_type creates complete
1637 type. */
1638 arg->backend_decl = NULL;
1639 type = gfc_sym_type (arg);
1640 arg->backend_decl = backend_decl;
1641 type = build_reference_type (type);
1642 }
1643 }
4ee9c684 1644
d4163395 1645 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
4ee9c684 1646
d4163395 1647 DECL_CONTEXT (parm) = fndecl;
1648 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1649 TREE_READONLY (parm) = 1;
1650 DECL_ARTIFICIAL (parm) = 1;
b9c7fce7 1651 gfc_finish_decl (parm);
4ee9c684 1652
d4163395 1653 arglist = chainon (arglist, parm);
1654 typelist = TREE_CHAIN (typelist);
4ee9c684 1655
d4163395 1656 if (sym->ts.type == BT_CHARACTER)
1657 {
1658 gfc_allocate_lang_decl (parm);
1659 arglist = chainon (arglist, length);
e4b2c26c 1660 typelist = TREE_CHAIN (typelist);
1661 }
1662 }
4ee9c684 1663
d4163395 1664 hidden_typelist = typelist;
1665 for (f = sym->formal; f; f = f->next)
1666 if (f->sym != NULL) /* Ignore alternate returns. */
1667 hidden_typelist = TREE_CHAIN (hidden_typelist);
1668
e4b2c26c 1669 for (f = sym->formal; f; f = f->next)
1670 {
1671 char name[GFC_MAX_SYMBOL_LEN + 2];
d4163395 1672
e4b2c26c 1673 /* Ignore alternate returns. */
1674 if (f->sym == NULL)
1675 continue;
4ee9c684 1676
e4b2c26c 1677 type = TREE_VALUE (typelist);
4ee9c684 1678
d4163395 1679 if (f->sym->ts.type == BT_CHARACTER)
1680 {
1681 tree len_type = TREE_VALUE (hidden_typelist);
1682 tree length = NULL_TREE;
1683 gcc_assert (len_type == gfc_charlen_type_node);
1684
1685 strcpy (&name[1], f->sym->name);
1686 name[0] = '_';
1687 length = build_decl (PARM_DECL, get_identifier (name), len_type);
4ee9c684 1688
d4163395 1689 hidden_arglist = chainon (hidden_arglist, length);
1690 DECL_CONTEXT (length) = fndecl;
1691 DECL_ARTIFICIAL (length) = 1;
1692 DECL_ARG_TYPE (length) = len_type;
1693 TREE_READONLY (length) = 1;
b9c7fce7 1694 gfc_finish_decl (length);
4ee9c684 1695
a4abf8a0 1696 /* Remember the passed value. */
1697 f->sym->ts.cl->passed_length = length;
4ee9c684 1698
d4163395 1699 /* Use the passed value for assumed length variables. */
1700 if (!f->sym->ts.cl->length)
4ee9c684 1701 {
d4163395 1702 TREE_USED (length) = 1;
04b61f60 1703 gcc_assert (!f->sym->ts.cl->backend_decl);
1704 f->sym->ts.cl->backend_decl = length;
d4163395 1705 }
1706
1707 hidden_typelist = TREE_CHAIN (hidden_typelist);
1708
1709 if (f->sym->ts.cl->backend_decl == NULL
1710 || f->sym->ts.cl->backend_decl == length)
1711 {
1712 if (f->sym->ts.cl->backend_decl == NULL)
1713 gfc_create_string_length (f->sym);
1714
1715 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1716 if (f->sym->attr.flavor == FL_PROCEDURE)
1717 type = build_pointer_type (gfc_get_function_type (f->sym));
1718 else
1719 type = gfc_sym_type (f->sym);
4ee9c684 1720 }
4ee9c684 1721 }
1722
d4163395 1723 /* For non-constant length array arguments, make sure they use
1724 a different type node from TYPE_ARG_TYPES type. */
1725 if (f->sym->attr.dimension
1726 && type == TREE_VALUE (typelist)
1727 && TREE_CODE (type) == POINTER_TYPE
1728 && GFC_ARRAY_TYPE_P (type)
1729 && f->sym->as->type != AS_ASSUMED_SIZE
1730 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1731 {
1732 if (f->sym->attr.flavor == FL_PROCEDURE)
1733 type = build_pointer_type (gfc_get_function_type (f->sym));
1734 else
1735 type = gfc_sym_type (f->sym);
1736 }
1737
cad0ddcf 1738 if (f->sym->attr.proc_pointer)
1739 type = build_pointer_type (type);
1740
69b1505f 1741 /* Build the argument declaration. */
d4163395 1742 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1743
1744 /* Fill in arg stuff. */
1745 DECL_CONTEXT (parm) = fndecl;
1746 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1747 /* All implementation args are read-only. */
1748 TREE_READONLY (parm) = 1;
98923a84 1749 if (POINTER_TYPE_P (type)
1750 && (!f->sym->attr.proc_pointer
1751 && f->sym->attr.flavor != FL_PROCEDURE))
1752 DECL_BY_REFERENCE (parm) = 1;
d4163395 1753
b9c7fce7 1754 gfc_finish_decl (parm);
d4163395 1755
1756 f->sym->backend_decl = parm;
1757
1758 arglist = chainon (arglist, parm);
e4b2c26c 1759 typelist = TREE_CHAIN (typelist);
4ee9c684 1760 }
e4b2c26c 1761
465e4a95 1762 /* Add the hidden string length parameters, unless the procedure
1763 is bind(C). */
1764 if (!sym->attr.is_bind_c)
1765 arglist = chainon (arglist, hidden_arglist);
d4163395 1766
ebe27ea2 1767 gcc_assert (hidden_typelist == NULL_TREE
1768 || TREE_VALUE (hidden_typelist) == void_type_node);
e4b2c26c 1769 DECL_ARGUMENTS (fndecl) = arglist;
1b716045 1770}
e4b2c26c 1771
1b716045 1772/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1773
1774static void
1775gfc_gimplify_function (tree fndecl)
1776{
1777 struct cgraph_node *cgn;
1778
1779 gimplify_function_tree (fndecl);
1780 dump_function (TDI_generic, fndecl);
1781
764f1175 1782 /* Generate errors for structured block violations. */
1783 /* ??? Could be done as part of resolve_labels. */
1784 if (flag_openmp)
1785 diagnose_omp_structured_block_errors (fndecl);
1786
1b716045 1787 /* Convert all nested functions to GIMPLE now. We do things in this order
1788 so that items like VLA sizes are expanded properly in the context of the
1789 correct function. */
1790 cgn = cgraph_node (fndecl);
1791 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1792 gfc_gimplify_function (cgn->decl);
1793}
1794
1795
1796/* Do the setup necessary before generating the body of a function. */
1797
1798static void
1799trans_function_start (gfc_symbol * sym)
1800{
1801 tree fndecl;
1802
1803 fndecl = sym->backend_decl;
1804
f888a3fb 1805 /* Let GCC know the current scope is this function. */
1b716045 1806 current_function_decl = fndecl;
1807
f888a3fb 1808 /* Let the world know what we're about to do. */
1b716045 1809 announce_function (fndecl);
1810
1811 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1812 {
f888a3fb 1813 /* Create RTL for function declaration. */
1b716045 1814 rest_of_decl_compilation (fndecl, 1, 0);
1815 }
1816
f888a3fb 1817 /* Create RTL for function definition. */
1b716045 1818 make_decl_rtl (fndecl);
1819
1b716045 1820 init_function_start (fndecl);
1821
1822 /* Even though we're inside a function body, we still don't want to
1823 call expand_expr to calculate the size of a variable-sized array.
1824 We haven't necessarily assigned RTL to all variables yet, so it's
1825 not safe to try to expand expressions involving them. */
18d50ae6 1826 cfun->dont_save_pending_sizes_p = 1;
1b716045 1827
f888a3fb 1828 /* function.c requires a push at the start of the function. */
1b716045 1829 pushlevel (0);
1830}
1831
1832/* Create thunks for alternate entry points. */
1833
1834static void
1835build_entry_thunks (gfc_namespace * ns)
1836{
1837 gfc_formal_arglist *formal;
1838 gfc_formal_arglist *thunk_formal;
1839 gfc_entry_list *el;
1840 gfc_symbol *thunk_sym;
1841 stmtblock_t body;
1842 tree thunk_fndecl;
1843 tree args;
1844 tree string_args;
1845 tree tmp;
b31f705b 1846 locus old_loc;
1b716045 1847
1848 /* This should always be a toplevel function. */
22d678e8 1849 gcc_assert (current_function_decl == NULL_TREE);
1b716045 1850
b31f705b 1851 gfc_get_backend_locus (&old_loc);
1b716045 1852 for (el = ns->entries; el; el = el->next)
1853 {
1854 thunk_sym = el->sym;
1855
1856 build_function_decl (thunk_sym);
1857 create_function_arglist (thunk_sym);
1858
1859 trans_function_start (thunk_sym);
1860
1861 thunk_fndecl = thunk_sym->backend_decl;
1862
e5004242 1863 gfc_init_block (&body);
1b716045 1864
f888a3fb 1865 /* Pass extra parameter identifying this entry point. */
7016c612 1866 tmp = build_int_cst (gfc_array_index_type, el->id);
1b716045 1867 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1868 string_args = NULL_TREE;
1869
c6871095 1870 if (thunk_sym->attr.function)
1871 {
1872 if (gfc_return_by_reference (ns->proc_name))
1873 {
1874 tree ref = DECL_ARGUMENTS (current_function_decl);
1875 args = tree_cons (NULL_TREE, ref, args);
1876 if (ns->proc_name->ts.type == BT_CHARACTER)
1877 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1878 args);
1879 }
1880 }
1881
1b716045 1882 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1883 {
c6871095 1884 /* Ignore alternate returns. */
1885 if (formal->sym == NULL)
1886 continue;
1887
1b716045 1888 /* We don't have a clever way of identifying arguments, so resort to
1889 a brute-force search. */
1890 for (thunk_formal = thunk_sym->formal;
1891 thunk_formal;
1892 thunk_formal = thunk_formal->next)
1893 {
1894 if (thunk_formal->sym == formal->sym)
1895 break;
1896 }
1897
1898 if (thunk_formal)
1899 {
1900 /* Pass the argument. */
d95efb59 1901 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1b716045 1902 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1903 args);
1904 if (formal->sym->ts.type == BT_CHARACTER)
1905 {
1906 tmp = thunk_formal->sym->ts.cl->backend_decl;
1907 string_args = tree_cons (NULL_TREE, tmp, string_args);
1908 }
1909 }
1910 else
1911 {
1912 /* Pass NULL for a missing argument. */
1913 args = tree_cons (NULL_TREE, null_pointer_node, args);
1914 if (formal->sym->ts.type == BT_CHARACTER)
1915 {
7d3075f6 1916 tmp = build_int_cst (gfc_charlen_type_node, 0);
1b716045 1917 string_args = tree_cons (NULL_TREE, tmp, string_args);
1918 }
1919 }
1920 }
1921
1922 /* Call the master function. */
1923 args = nreverse (args);
1924 args = chainon (args, nreverse (string_args));
1925 tmp = ns->proc_name->backend_decl;
ac47d547 1926 tmp = build_function_call_expr (tmp, args);
c6871095 1927 if (ns->proc_name->attr.mixed_entry_master)
1928 {
1929 tree union_decl, field;
1930 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1931
1932 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1933 TREE_TYPE (master_type));
1934 DECL_ARTIFICIAL (union_decl) = 1;
1935 DECL_EXTERNAL (union_decl) = 0;
1936 TREE_PUBLIC (union_decl) = 0;
1937 TREE_USED (union_decl) = 1;
1938 layout_decl (union_decl, 0);
1939 pushdecl (union_decl);
1940
1941 DECL_CONTEXT (union_decl) = current_function_decl;
f75d6b8a 1942 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1943 union_decl, tmp);
c6871095 1944 gfc_add_expr_to_block (&body, tmp);
1945
1946 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1947 field; field = TREE_CHAIN (field))
1948 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1949 thunk_sym->result->name) == 0)
1950 break;
1951 gcc_assert (field != NULL_TREE);
f75d6b8a 1952 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1953 union_decl, field, NULL_TREE);
1954 tmp = fold_build2 (MODIFY_EXPR,
1955 TREE_TYPE (DECL_RESULT (current_function_decl)),
1956 DECL_RESULT (current_function_decl), tmp);
c6871095 1957 tmp = build1_v (RETURN_EXPR, tmp);
1958 }
1959 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1960 != void_type_node)
1961 {
f75d6b8a 1962 tmp = fold_build2 (MODIFY_EXPR,
1963 TREE_TYPE (DECL_RESULT (current_function_decl)),
1964 DECL_RESULT (current_function_decl), tmp);
c6871095 1965 tmp = build1_v (RETURN_EXPR, tmp);
1966 }
1b716045 1967 gfc_add_expr_to_block (&body, tmp);
1968
1969 /* Finish off this function and send it for code generation. */
1970 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
e5004242 1971 tmp = getdecls ();
1b716045 1972 poplevel (1, 0, 1);
1973 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
e5004242 1974 DECL_SAVED_TREE (thunk_fndecl)
1975 = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
1976 DECL_INITIAL (thunk_fndecl));
1b716045 1977
1978 /* Output the GENERIC tree. */
1979 dump_function (TDI_original, thunk_fndecl);
1980
1981 /* Store the end of the function, so that we get good line number
1982 info for the epilogue. */
1983 cfun->function_end_locus = input_location;
1984
1985 /* We're leaving the context of this function, so zap cfun.
1986 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1987 tree_rest_of_compilation. */
87d4aa85 1988 set_cfun (NULL);
1b716045 1989
1990 current_function_decl = NULL_TREE;
1991
1992 gfc_gimplify_function (thunk_fndecl);
9d95b2b0 1993 cgraph_finalize_function (thunk_fndecl, false);
1b716045 1994
1995 /* We share the symbols in the formal argument list with other entry
1996 points and the master function. Clear them so that they are
1997 recreated for each function. */
1998 for (formal = thunk_sym->formal; formal; formal = formal->next)
c6871095 1999 if (formal->sym != NULL) /* Ignore alternate returns. */
2000 {
2001 formal->sym->backend_decl = NULL_TREE;
2002 if (formal->sym->ts.type == BT_CHARACTER)
2003 formal->sym->ts.cl->backend_decl = NULL_TREE;
2004 }
2005
2006 if (thunk_sym->attr.function)
1b716045 2007 {
c6871095 2008 if (thunk_sym->ts.type == BT_CHARACTER)
2009 thunk_sym->ts.cl->backend_decl = NULL_TREE;
2010 if (thunk_sym->result->ts.type == BT_CHARACTER)
2011 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1b716045 2012 }
2013 }
b31f705b 2014
2015 gfc_set_backend_locus (&old_loc);
1b716045 2016}
2017
2018
2019/* Create a decl for a function, and create any thunks for alternate entry
2020 points. */
2021
2022void
2023gfc_create_function_decl (gfc_namespace * ns)
2024{
2025 /* Create a declaration for the master function. */
2026 build_function_decl (ns->proc_name);
2027
f888a3fb 2028 /* Compile the entry thunks. */
1b716045 2029 if (ns->entries)
2030 build_entry_thunks (ns);
2031
2032 /* Now create the read argument list. */
2033 create_function_arglist (ns->proc_name);
2034}
2035
c750cc52 2036/* Return the decl used to hold the function return value. If
3350e716 2037 parent_flag is set, the context is the parent_scope. */
4ee9c684 2038
2039tree
c750cc52 2040gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
4ee9c684 2041{
c750cc52 2042 tree decl;
2043 tree length;
2044 tree this_fake_result_decl;
2045 tree this_function_decl;
4ee9c684 2046
2047 char name[GFC_MAX_SYMBOL_LEN + 10];
2048
c750cc52 2049 if (parent_flag)
2050 {
2051 this_fake_result_decl = parent_fake_result_decl;
2052 this_function_decl = DECL_CONTEXT (current_function_decl);
2053 }
2054 else
2055 {
2056 this_fake_result_decl = current_fake_result_decl;
2057 this_function_decl = current_function_decl;
2058 }
2059
c6871095 2060 if (sym
c750cc52 2061 && sym->ns->proc_name->backend_decl == this_function_decl
d4163395 2062 && sym->ns->proc_name->attr.entry_master
c6871095 2063 && sym != sym->ns->proc_name)
2064 {
d4163395 2065 tree t = NULL, var;
c750cc52 2066 if (this_fake_result_decl != NULL)
2067 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
d4163395 2068 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2069 break;
2070 if (t)
2071 return TREE_VALUE (t);
c750cc52 2072 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2073
2074 if (parent_flag)
2075 this_fake_result_decl = parent_fake_result_decl;
2076 else
2077 this_fake_result_decl = current_fake_result_decl;
2078
d4163395 2079 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
c6871095 2080 {
2081 tree field;
2082
2083 for (field = TYPE_FIELDS (TREE_TYPE (decl));
2084 field; field = TREE_CHAIN (field))
2085 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2086 sym->name) == 0)
2087 break;
2088
2089 gcc_assert (field != NULL_TREE);
f75d6b8a 2090 decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2091 decl, field, NULL_TREE);
c6871095 2092 }
c750cc52 2093
2094 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2095 if (parent_flag)
2096 gfc_add_decl_to_parent_function (var);
2097 else
2098 gfc_add_decl_to_function (var);
2099
d4163395 2100 SET_DECL_VALUE_EXPR (var, decl);
2101 DECL_HAS_VALUE_EXPR_P (var) = 1;
2cf330c4 2102 GFC_DECL_RESULT (var) = 1;
c750cc52 2103
2104 TREE_CHAIN (this_fake_result_decl)
2105 = tree_cons (get_identifier (sym->name), var,
2106 TREE_CHAIN (this_fake_result_decl));
d4163395 2107 return var;
c6871095 2108 }
2109
c750cc52 2110 if (this_fake_result_decl != NULL_TREE)
2111 return TREE_VALUE (this_fake_result_decl);
4ee9c684 2112
2113 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2114 sym is NULL. */
2115 if (!sym)
2116 return NULL_TREE;
2117
d4163395 2118 if (sym->ts.type == BT_CHARACTER)
4ee9c684 2119 {
d4163395 2120 if (sym->ts.cl->backend_decl == NULL_TREE)
2121 length = gfc_create_string_length (sym);
2122 else
2123 length = sym->ts.cl->backend_decl;
2124 if (TREE_CODE (length) == VAR_DECL
2125 && DECL_CONTEXT (length) == NULL_TREE)
99042714 2126 gfc_add_decl_to_function (length);
4ee9c684 2127 }
2128
2129 if (gfc_return_by_reference (sym))
2130 {
c750cc52 2131 decl = DECL_ARGUMENTS (this_function_decl);
c6871095 2132
c750cc52 2133 if (sym->ns->proc_name->backend_decl == this_function_decl
c6871095 2134 && sym->ns->proc_name->attr.entry_master)
2135 decl = TREE_CHAIN (decl);
4ee9c684 2136
2137 TREE_USED (decl) = 1;
2138 if (sym->as)
2139 decl = gfc_build_dummy_array_decl (sym, decl);
2140 }
2141 else
2142 {
2143 sprintf (name, "__result_%.20s",
c750cc52 2144 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
4ee9c684 2145
3350e716 2146 if (!sym->attr.mixed_entry_master && sym->attr.function)
2147 decl = build_decl (VAR_DECL, get_identifier (name),
2148 gfc_sym_type (sym));
2149 else
2150 decl = build_decl (VAR_DECL, get_identifier (name),
2151 TREE_TYPE (TREE_TYPE (this_function_decl)));
4ee9c684 2152 DECL_ARTIFICIAL (decl) = 1;
2153 DECL_EXTERNAL (decl) = 0;
2154 TREE_PUBLIC (decl) = 0;
2155 TREE_USED (decl) = 1;
764f1175 2156 GFC_DECL_RESULT (decl) = 1;
a379e3a9 2157 TREE_ADDRESSABLE (decl) = 1;
4ee9c684 2158
2159 layout_decl (decl, 0);
2160
c750cc52 2161 if (parent_flag)
2162 gfc_add_decl_to_parent_function (decl);
2163 else
2164 gfc_add_decl_to_function (decl);
4ee9c684 2165 }
2166
c750cc52 2167 if (parent_flag)
2168 parent_fake_result_decl = build_tree_list (NULL, decl);
2169 else
2170 current_fake_result_decl = build_tree_list (NULL, decl);
4ee9c684 2171
2172 return decl;
2173}
2174
2175
2176/* Builds a function decl. The remaining parameters are the types of the
2177 function arguments. Negative nargs indicates a varargs function. */
2178
2179tree
2180gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2181{
2182 tree arglist;
2183 tree argtype;
2184 tree fntype;
2185 tree fndecl;
2186 va_list p;
2187 int n;
2188
2189 /* Library functions must be declared with global scope. */
22d678e8 2190 gcc_assert (current_function_decl == NULL_TREE);
4ee9c684 2191
2192 va_start (p, nargs);
2193
2194
2195 /* Create a list of the argument types. */
2196 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2197 {
2198 argtype = va_arg (p, tree);
2199 arglist = gfc_chainon_list (arglist, argtype);
2200 }
2201
2202 if (nargs >= 0)
2203 {
2204 /* Terminate the list. */
2205 arglist = gfc_chainon_list (arglist, void_type_node);
2206 }
2207
2208 /* Build the function type and decl. */
2209 fntype = build_function_type (rettype, arglist);
2210 fndecl = build_decl (FUNCTION_DECL, name, fntype);
2211
2212 /* Mark this decl as external. */
2213 DECL_EXTERNAL (fndecl) = 1;
2214 TREE_PUBLIC (fndecl) = 1;
2215
2216 va_end (p);
2217
2218 pushdecl (fndecl);
2219
b2c4af5e 2220 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 2221
2222 return fndecl;
2223}
2224
2225static void
2226gfc_build_intrinsic_function_decls (void)
2227{
90ba9145 2228 tree gfc_int4_type_node = gfc_get_int_type (4);
2229 tree gfc_int8_type_node = gfc_get_int_type (8);
920e54ef 2230 tree gfc_int16_type_node = gfc_get_int_type (16);
90ba9145 2231 tree gfc_logical4_type_node = gfc_get_logical_type (4);
40b806de 2232 tree pchar1_type_node = gfc_get_pchar_type (1);
2233 tree pchar4_type_node = gfc_get_pchar_type (4);
90ba9145 2234
4ee9c684 2235 /* String functions. */
4ee9c684 2236 gfor_fndecl_compare_string =
2237 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
f20cadb1 2238 integer_type_node, 4,
40b806de 2239 gfc_charlen_type_node, pchar1_type_node,
2240 gfc_charlen_type_node, pchar1_type_node);
4ee9c684 2241
2242 gfor_fndecl_concat_string =
2243 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
40b806de 2244 void_type_node, 6,
2245 gfc_charlen_type_node, pchar1_type_node,
2246 gfc_charlen_type_node, pchar1_type_node,
2247 gfc_charlen_type_node, pchar1_type_node);
4ee9c684 2248
2249 gfor_fndecl_string_len_trim =
2250 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
40b806de 2251 gfc_int4_type_node, 2,
2252 gfc_charlen_type_node, pchar1_type_node);
4ee9c684 2253
2254 gfor_fndecl_string_index =
2255 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
40b806de 2256 gfc_int4_type_node, 5,
2257 gfc_charlen_type_node, pchar1_type_node,
2258 gfc_charlen_type_node, pchar1_type_node,
2259 gfc_logical4_type_node);
4ee9c684 2260
2261 gfor_fndecl_string_scan =
2262 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
40b806de 2263 gfc_int4_type_node, 5,
2264 gfc_charlen_type_node, pchar1_type_node,
2265 gfc_charlen_type_node, pchar1_type_node,
2266 gfc_logical4_type_node);
4ee9c684 2267
2268 gfor_fndecl_string_verify =
2269 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
40b806de 2270 gfc_int4_type_node, 5,
2271 gfc_charlen_type_node, pchar1_type_node,
2272 gfc_charlen_type_node, pchar1_type_node,
2273 gfc_logical4_type_node);
4ee9c684 2274
5b11d932 2275 gfor_fndecl_string_trim =
4ee9c684 2276 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
40b806de 2277 void_type_node, 4,
2278 build_pointer_type (gfc_charlen_type_node),
2279 build_pointer_type (pchar1_type_node),
2280 gfc_charlen_type_node, pchar1_type_node);
4ee9c684 2281
5fcc6ec2 2282 gfor_fndecl_string_minmax =
2283 gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
40b806de 2284 void_type_node, -4,
2285 build_pointer_type (gfc_charlen_type_node),
2286 build_pointer_type (pchar1_type_node),
2287 integer_type_node, integer_type_node);
2288
2289 gfor_fndecl_adjustl =
2290 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2291 void_type_node, 3, pchar1_type_node,
2292 gfc_charlen_type_node, pchar1_type_node);
2293
2294 gfor_fndecl_adjustr =
2295 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2296 void_type_node, 3, pchar1_type_node,
2297 gfc_charlen_type_node, pchar1_type_node);
2298
b44437b9 2299 gfor_fndecl_select_string =
2300 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2301 integer_type_node, 4, pvoid_type_node,
2302 integer_type_node, pchar1_type_node,
2303 gfc_charlen_type_node);
2304
40b806de 2305 gfor_fndecl_compare_string_char4 =
2306 gfc_build_library_function_decl (get_identifier
2307 (PREFIX("compare_string_char4")),
2308 integer_type_node, 4,
2309 gfc_charlen_type_node, pchar4_type_node,
2310 gfc_charlen_type_node, pchar4_type_node);
2311
2312 gfor_fndecl_concat_string_char4 =
2313 gfc_build_library_function_decl (get_identifier
2314 (PREFIX("concat_string_char4")),
2315 void_type_node, 6,
2316 gfc_charlen_type_node, pchar4_type_node,
2317 gfc_charlen_type_node, pchar4_type_node,
2318 gfc_charlen_type_node, pchar4_type_node);
2319
2320 gfor_fndecl_string_len_trim_char4 =
2321 gfc_build_library_function_decl (get_identifier
2322 (PREFIX("string_len_trim_char4")),
2323 gfc_charlen_type_node, 2,
2324 gfc_charlen_type_node, pchar4_type_node);
2325
2326 gfor_fndecl_string_index_char4 =
2327 gfc_build_library_function_decl (get_identifier
2328 (PREFIX("string_index_char4")),
2329 gfc_charlen_type_node, 5,
2330 gfc_charlen_type_node, pchar4_type_node,
2331 gfc_charlen_type_node, pchar4_type_node,
2332 gfc_logical4_type_node);
2333
2334 gfor_fndecl_string_scan_char4 =
2335 gfc_build_library_function_decl (get_identifier
2336 (PREFIX("string_scan_char4")),
2337 gfc_charlen_type_node, 5,
2338 gfc_charlen_type_node, pchar4_type_node,
2339 gfc_charlen_type_node, pchar4_type_node,
2340 gfc_logical4_type_node);
2341
2342 gfor_fndecl_string_verify_char4 =
2343 gfc_build_library_function_decl (get_identifier
2344 (PREFIX("string_verify_char4")),
2345 gfc_charlen_type_node, 5,
2346 gfc_charlen_type_node, pchar4_type_node,
2347 gfc_charlen_type_node, pchar4_type_node,
2348 gfc_logical4_type_node);
2349
2350 gfor_fndecl_string_trim_char4 =
2351 gfc_build_library_function_decl (get_identifier
2352 (PREFIX("string_trim_char4")),
2353 void_type_node, 4,
2354 build_pointer_type (gfc_charlen_type_node),
2355 build_pointer_type (pchar4_type_node),
2356 gfc_charlen_type_node, pchar4_type_node);
2357
2358 gfor_fndecl_string_minmax_char4 =
2359 gfc_build_library_function_decl (get_identifier
2360 (PREFIX("string_minmax_char4")),
2361 void_type_node, -4,
2362 build_pointer_type (gfc_charlen_type_node),
2363 build_pointer_type (pchar4_type_node),
2364 integer_type_node, integer_type_node);
2365
2366 gfor_fndecl_adjustl_char4 =
2367 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2368 void_type_node, 3, pchar4_type_node,
2369 gfc_charlen_type_node, pchar4_type_node);
2370
2371 gfor_fndecl_adjustr_char4 =
2372 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2373 void_type_node, 3, pchar4_type_node,
2374 gfc_charlen_type_node, pchar4_type_node);
2375
b44437b9 2376 gfor_fndecl_select_string_char4 =
2377 gfc_build_library_function_decl (get_identifier
2378 (PREFIX("select_string_char4")),
2379 integer_type_node, 4, pvoid_type_node,
2380 integer_type_node, pvoid_type_node,
2381 gfc_charlen_type_node);
2382
2383
2384 /* Conversion between character kinds. */
2385
2386 gfor_fndecl_convert_char1_to_char4 =
2387 gfc_build_library_function_decl (get_identifier
2388 (PREFIX("convert_char1_to_char4")),
2389 void_type_node, 3,
2390 build_pointer_type (pchar4_type_node),
2391 gfc_charlen_type_node, pchar1_type_node);
2392
2393 gfor_fndecl_convert_char4_to_char1 =
2394 gfc_build_library_function_decl (get_identifier
2395 (PREFIX("convert_char4_to_char1")),
2396 void_type_node, 3,
2397 build_pointer_type (pchar1_type_node),
2398 gfc_charlen_type_node, pchar4_type_node);
2399
40b806de 2400 /* Misc. functions. */
5fcc6ec2 2401
dbc97b88 2402 gfor_fndecl_ttynam =
2403 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2404 void_type_node,
2405 3,
2406 pchar_type_node,
2407 gfc_charlen_type_node,
36c921b9 2408 integer_type_node);
dbc97b88 2409
b902b078 2410 gfor_fndecl_fdate =
2411 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2412 void_type_node,
2413 2,
2414 pchar_type_node,
2415 gfc_charlen_type_node);
2416
2417 gfor_fndecl_ctime =
2418 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2419 void_type_node,
2420 3,
2421 pchar_type_node,
2422 gfc_charlen_type_node,
2423 gfc_int8_type_node);
2424
59e2a584 2425 gfor_fndecl_sc_kind =
2426 gfc_build_library_function_decl (get_identifier
2427 (PREFIX("selected_char_kind")),
2428 gfc_int4_type_node, 2,
2429 gfc_charlen_type_node, pchar_type_node);
2430
4ee9c684 2431 gfor_fndecl_si_kind =
17000b91 2432 gfc_build_library_function_decl (get_identifier
2433 (PREFIX("selected_int_kind")),
59e2a584 2434 gfc_int4_type_node, 1, pvoid_type_node);
4ee9c684 2435
2436 gfor_fndecl_sr_kind =
5b11d932 2437 gfc_build_library_function_decl (get_identifier
17000b91 2438 (PREFIX("selected_real_kind")),
59e2a584 2439 gfc_int4_type_node, 2,
2440 pvoid_type_node, pvoid_type_node);
4ee9c684 2441
4ee9c684 2442 /* Power functions. */
76834664 2443 {
920e54ef 2444 tree ctype, rtype, itype, jtype;
2445 int rkind, ikind, jkind;
2446#define NIKINDS 3
2447#define NRKINDS 4
2448 static int ikinds[NIKINDS] = {4, 8, 16};
2449 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2450 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2451
2452 for (ikind=0; ikind < NIKINDS; ikind++)
76834664 2453 {
920e54ef 2454 itype = gfc_get_int_type (ikinds[ikind]);
2455
2456 for (jkind=0; jkind < NIKINDS; jkind++)
2457 {
2458 jtype = gfc_get_int_type (ikinds[jkind]);
2459 if (itype && jtype)
2460 {
2461 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2462 ikinds[jkind]);
2463 gfor_fndecl_math_powi[jkind][ikind].integer =
2464 gfc_build_library_function_decl (get_identifier (name),
2465 jtype, 2, jtype, itype);
2177d98b 2466 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
920e54ef 2467 }
2468 }
2469
2470 for (rkind = 0; rkind < NRKINDS; rkind ++)
76834664 2471 {
920e54ef 2472 rtype = gfc_get_real_type (rkinds[rkind]);
2473 if (rtype && itype)
2474 {
2475 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2476 ikinds[ikind]);
2477 gfor_fndecl_math_powi[rkind][ikind].real =
2478 gfc_build_library_function_decl (get_identifier (name),
2479 rtype, 2, rtype, itype);
2177d98b 2480 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
920e54ef 2481 }
2482
2483 ctype = gfc_get_complex_type (rkinds[rkind]);
2484 if (ctype && itype)
2485 {
2486 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2487 ikinds[ikind]);
2488 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2489 gfc_build_library_function_decl (get_identifier (name),
2490 ctype, 2,ctype, itype);
2177d98b 2491 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
920e54ef 2492 }
76834664 2493 }
2494 }
920e54ef 2495#undef NIKINDS
2496#undef NRKINDS
76834664 2497 }
2498
4ee9c684 2499 gfor_fndecl_math_ishftc4 =
2500 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2501 gfc_int4_type_node,
2502 3, gfc_int4_type_node,
2503 gfc_int4_type_node, gfc_int4_type_node);
2504 gfor_fndecl_math_ishftc8 =
2505 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2506 gfc_int8_type_node,
2507 3, gfc_int8_type_node,
920e54ef 2508 gfc_int4_type_node, gfc_int4_type_node);
2509 if (gfc_int16_type_node)
2510 gfor_fndecl_math_ishftc16 =
2511 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2512 gfc_int16_type_node, 3,
2513 gfc_int16_type_node,
2514 gfc_int4_type_node,
2515 gfc_int4_type_node);
2516
4e8e57b0 2517 /* BLAS functions. */
2518 {
36c921b9 2519 tree pint = build_pointer_type (integer_type_node);
4e8e57b0 2520 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2521 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2522 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2523 tree pz = build_pointer_type
2524 (gfc_get_complex_type (gfc_default_double_kind));
2525
2526 gfor_fndecl_sgemm = gfc_build_library_function_decl
2527 (get_identifier
2528 (gfc_option.flag_underscoring ? "sgemm_"
2529 : "sgemm"),
2530 void_type_node, 15, pchar_type_node,
2531 pchar_type_node, pint, pint, pint, ps, ps, pint,
36c921b9 2532 ps, pint, ps, ps, pint, integer_type_node,
2533 integer_type_node);
4e8e57b0 2534 gfor_fndecl_dgemm = gfc_build_library_function_decl
2535 (get_identifier
2536 (gfc_option.flag_underscoring ? "dgemm_"
2537 : "dgemm"),
2538 void_type_node, 15, pchar_type_node,
2539 pchar_type_node, pint, pint, pint, pd, pd, pint,
36c921b9 2540 pd, pint, pd, pd, pint, integer_type_node,
2541 integer_type_node);
4e8e57b0 2542 gfor_fndecl_cgemm = gfc_build_library_function_decl
2543 (get_identifier
2544 (gfc_option.flag_underscoring ? "cgemm_"
2545 : "cgemm"),
2546 void_type_node, 15, pchar_type_node,
2547 pchar_type_node, pint, pint, pint, pc, pc, pint,
36c921b9 2548 pc, pint, pc, pc, pint, integer_type_node,
2549 integer_type_node);
4e8e57b0 2550 gfor_fndecl_zgemm = gfc_build_library_function_decl
2551 (get_identifier
2552 (gfc_option.flag_underscoring ? "zgemm_"
2553 : "zgemm"),
2554 void_type_node, 15, pchar_type_node,
2555 pchar_type_node, pint, pint, pint, pz, pz, pint,
36c921b9 2556 pz, pint, pz, pz, pint, integer_type_node,
2557 integer_type_node);
4e8e57b0 2558 }
2559
4ee9c684 2560 /* Other functions. */
2561 gfor_fndecl_size0 =
2562 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2563 gfc_array_index_type,
2564 1, pvoid_type_node);
2565 gfor_fndecl_size1 =
2566 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2567 gfc_array_index_type,
2568 2, pvoid_type_node,
2569 gfc_array_index_type);
9b057c29 2570
2571 gfor_fndecl_iargc =
2572 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2573 gfc_int4_type_node,
2574 0);
70eb4f1a 2575
2576 if (gfc_type_for_size (128, true))
2577 {
2578 tree uint128 = gfc_type_for_size (128, true);
2579
2580 gfor_fndecl_clz128 =
2581 gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2582 integer_type_node, 1, uint128);
2583
2584 gfor_fndecl_ctz128 =
2585 gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2586 integer_type_node, 1, uint128);
2587 }
4ee9c684 2588}
2589
2590
2591/* Make prototypes for runtime library functions. */
2592
2593void
2594gfc_build_builtin_function_decls (void)
2595{
90ba9145 2596 tree gfc_int4_type_node = gfc_get_int_type (4);
4ee9c684 2597
2598 gfor_fndecl_stop_numeric =
2599 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2600 void_type_node, 1, gfc_int4_type_node);
98ccec97 2601 /* Stop doesn't return. */
2602 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2603
4ee9c684 2604 gfor_fndecl_stop_string =
2605 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2606 void_type_node, 2, pchar_type_node,
2607 gfc_int4_type_node);
98ccec97 2608 /* Stop doesn't return. */
2609 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
4ee9c684 2610
2611 gfor_fndecl_pause_numeric =
2612 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2613 void_type_node, 1, gfc_int4_type_node);
2614
2615 gfor_fndecl_pause_string =
2616 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2617 void_type_node, 2, pchar_type_node,
2618 gfc_int4_type_node);
2619
4ee9c684 2620 gfor_fndecl_runtime_error =
2621 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
399aecc1 2622 void_type_node, -1, pchar_type_node);
9c0f3811 2623 /* The runtime_error function does not return. */
2624 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
4ee9c684 2625
50ad5fa2 2626 gfor_fndecl_runtime_error_at =
2627 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
399aecc1 2628 void_type_node, -2, pchar_type_node,
50ad5fa2 2629 pchar_type_node);
2630 /* The runtime_error_at function does not return. */
2631 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2632
da6ffc6d 2633 gfor_fndecl_runtime_warning_at =
2634 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2635 void_type_node, -2, pchar_type_node,
2636 pchar_type_node);
50ad5fa2 2637 gfor_fndecl_generate_error =
2638 gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2639 void_type_node, 3, pvoid_type_node,
36c921b9 2640 integer_type_node, pchar_type_node);
50ad5fa2 2641
9915365e 2642 gfor_fndecl_os_error =
2643 gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2644 void_type_node, 1, pchar_type_node);
2645 /* The runtime_error function does not return. */
2646 TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2647
7257a5d2 2648 gfor_fndecl_set_args =
2649 gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2650 void_type_node, 2, integer_type_node,
2651 build_pointer_type (pchar_type_node));
2652
8c84a5de 2653 gfor_fndecl_set_fpe =
2654 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
36c921b9 2655 void_type_node, 1, integer_type_node);
8c84a5de 2656
56c7c2d7 2657 /* Keep the array dimension in sync with the call, later in this file. */
2658 gfor_fndecl_set_options =
2659 gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
36c921b9 2660 void_type_node, 2, integer_type_node,
7257a5d2 2661 build_pointer_type (integer_type_node));
64fc3c4c 2662
15774a8b 2663 gfor_fndecl_set_convert =
2664 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
36c921b9 2665 void_type_node, 1, integer_type_node);
15774a8b 2666
f23886ab 2667 gfor_fndecl_set_record_marker =
2668 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
36c921b9 2669 void_type_node, 1, integer_type_node);
f23886ab 2670
bbaaa7b1 2671 gfor_fndecl_set_max_subrecord_length =
2672 gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
36c921b9 2673 void_type_node, 1, integer_type_node);
bbaaa7b1 2674
4ee9c684 2675 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2676 get_identifier (PREFIX("internal_pack")),
2677 pvoid_type_node, 1, pvoid_type_node);
2678
2679 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2680 get_identifier (PREFIX("internal_unpack")),
8b8484b4 2681 void_type_node, 2, pvoid_type_node, pvoid_type_node);
4ee9c684 2682
2683 gfor_fndecl_associated =
2684 gfc_build_library_function_decl (
2685 get_identifier (PREFIX("associated")),
c1c66d1d 2686 integer_type_node, 2, ppvoid_type_node,
4ee9c684 2687 ppvoid_type_node);
2688
2689 gfc_build_intrinsic_function_decls ();
2690 gfc_build_intrinsic_lib_fndecls ();
2691 gfc_build_io_library_fndecls ();
2692}
2693
2694
231e961a 2695/* Evaluate the length of dummy character variables. */
4ee9c684 2696
2697static tree
d4163395 2698gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
4ee9c684 2699{
2700 stmtblock_t body;
2701
b9c7fce7 2702 gfc_finish_decl (cl->backend_decl);
4ee9c684 2703
2704 gfc_start_block (&body);
2705
2706 /* Evaluate the string length expression. */
d778204a 2707 gfc_conv_string_length (cl, NULL, &body);
d4163395 2708
2709 gfc_trans_vla_type_sizes (sym, &body);
2710
4ee9c684 2711 gfc_add_expr_to_block (&body, fnbody);
2712 return gfc_finish_block (&body);
2713}
2714
2715
2716/* Allocate and cleanup an automatic character variable. */
2717
2718static tree
2719gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2720{
2721 stmtblock_t body;
2722 tree decl;
4ee9c684 2723 tree tmp;
2724
22d678e8 2725 gcc_assert (sym->backend_decl);
2726 gcc_assert (sym->ts.cl && sym->ts.cl->length);
4ee9c684 2727
2728 gfc_start_block (&body);
2729
2730 /* Evaluate the string length expression. */
d778204a 2731 gfc_conv_string_length (sym->ts.cl, NULL, &body);
4ee9c684 2732
d4163395 2733 gfc_trans_vla_type_sizes (sym, &body);
2734
4ee9c684 2735 decl = sym->backend_decl;
2736
afcf285e 2737 /* Emit a DECL_EXPR for this variable, which will cause the
4b3a701c 2738 gimplifier to allocate storage, and all that good stuff. */
f75d6b8a 2739 tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
4ee9c684 2740 gfc_add_expr_to_block (&body, tmp);
afcf285e 2741
4ee9c684 2742 gfc_add_expr_to_block (&body, fnbody);
2743 return gfc_finish_block (&body);
2744}
2745
c8f1568f 2746/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2747
2748static tree
2749gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2750{
2751 stmtblock_t body;
2752
2753 gcc_assert (sym->backend_decl);
2754 gfc_start_block (&body);
2755
2756 /* Set the initial value to length. See the comments in
2757 function gfc_add_assign_aux_vars in this file. */
75a70cf9 2758 gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
c8f1568f 2759 build_int_cst (NULL_TREE, -2));
2760
2761 gfc_add_expr_to_block (&body, fnbody);
2762 return gfc_finish_block (&body);
2763}
2764
d4163395 2765static void
2766gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2767{
2768 tree t = *tp, var, val;
2769
2770 if (t == NULL || t == error_mark_node)
2771 return;
2772 if (TREE_CONSTANT (t) || DECL_P (t))
2773 return;
2774
2775 if (TREE_CODE (t) == SAVE_EXPR)
2776 {
2777 if (SAVE_EXPR_RESOLVED_P (t))
2778 {
2779 *tp = TREE_OPERAND (t, 0);
2780 return;
2781 }
2782 val = TREE_OPERAND (t, 0);
2783 }
2784 else
2785 val = t;
2786
2787 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2788 gfc_add_decl_to_function (var);
75a70cf9 2789 gfc_add_modify (body, var, val);
d4163395 2790 if (TREE_CODE (t) == SAVE_EXPR)
2791 TREE_OPERAND (t, 0) = var;
2792 *tp = var;
2793}
2794
2795static void
2796gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2797{
2798 tree t;
2799
2800 if (type == NULL || type == error_mark_node)
2801 return;
2802
2803 type = TYPE_MAIN_VARIANT (type);
2804
2805 if (TREE_CODE (type) == INTEGER_TYPE)
2806 {
2807 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2808 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2809
2810 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2811 {
2812 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2813 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2814 }
2815 }
2816 else if (TREE_CODE (type) == ARRAY_TYPE)
2817 {
2818 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2819 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2820 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2821 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2822
2823 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2824 {
2825 TYPE_SIZE (t) = TYPE_SIZE (type);
2826 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2827 }
2828 }
2829}
2830
2831/* Make sure all type sizes and array domains are either constant,
2832 or variable or parameter decls. This is a simplified variant
2833 of gimplify_type_sizes, but we can't use it here, as none of the
2834 variables in the expressions have been gimplified yet.
2835 As type sizes and domains for various variable length arrays
2836 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2837 time, without this routine gimplify_type_sizes in the middle-end
2838 could result in the type sizes being gimplified earlier than where
2839 those variables are initialized. */
2840
2841void
2842gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2843{
2844 tree type = TREE_TYPE (sym->backend_decl);
2845
2846 if (TREE_CODE (type) == FUNCTION_TYPE
2847 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2848 {
2849 if (! current_fake_result_decl)
2850 return;
2851
2852 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2853 }
2854
2855 while (POINTER_TYPE_P (type))
2856 type = TREE_TYPE (type);
2857
2858 if (GFC_DESCRIPTOR_TYPE_P (type))
2859 {
2860 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2861
2862 while (POINTER_TYPE_P (etype))
2863 etype = TREE_TYPE (etype);
2864
2865 gfc_trans_vla_type_sizes_1 (etype, body);
2866 }
2867
2868 gfc_trans_vla_type_sizes_1 (type, body);
2869}
2870
4ee9c684 2871
f0d4969f 2872/* Initialize a derived type by building an lvalue from the symbol
2873 and using trans_assignment to do the work. */
89e89e42 2874tree
2875gfc_init_default_dt (gfc_symbol * sym, tree body)
87114d2e 2876{
2877 stmtblock_t fnblock;
f0d4969f 2878 gfc_expr *e;
87114d2e 2879 tree tmp;
2880 tree present;
2881
2882 gfc_init_block (&fnblock);
f0d4969f 2883 gcc_assert (!sym->attr.allocatable);
2884 gfc_set_sym_referenced (sym);
2885 e = gfc_lval_expr_from_sym (sym);
2886 tmp = gfc_trans_assignment (e, sym->value, false);
2887 if (sym->attr.dummy)
87114d2e 2888 {
f0d4969f 2889 present = gfc_conv_expr_present (sym);
2890 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2891 tmp, build_empty_stmt ());
87114d2e 2892 }
f0d4969f 2893 gfc_add_expr_to_block (&fnblock, tmp);
2894 gfc_free_expr (e);
89e89e42 2895 if (body)
2896 gfc_add_expr_to_block (&fnblock, body);
87114d2e 2897 return gfc_finish_block (&fnblock);
2898}
2899
2900
8714fc76 2901/* Initialize INTENT(OUT) derived type dummies. As well as giving
2902 them their default initializer, if they do not have allocatable
2903 components, they have their allocatable components deallocated. */
2904
f0d4969f 2905static tree
2906init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2907{
2908 stmtblock_t fnblock;
2909 gfc_formal_arglist *f;
8714fc76 2910 tree tmp;
5907c3ea 2911 tree present;
f0d4969f 2912
2913 gfc_init_block (&fnblock);
2914 for (f = proc_sym->formal; f; f = f->next)
2915 if (f->sym && f->sym->attr.intent == INTENT_OUT
8714fc76 2916 && f->sym->ts.type == BT_DERIVED)
2917 {
2918 if (f->sym->ts.derived->attr.alloc_comp)
2919 {
2920 tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
2921 f->sym->backend_decl,
2922 f->sym->as ? f->sym->as->rank : 0);
5907c3ea 2923
2924 present = gfc_conv_expr_present (f->sym);
2925 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2926 tmp, build_empty_stmt ());
2927
8714fc76 2928 gfc_add_expr_to_block (&fnblock, tmp);
2929 }
2930
2931 if (!f->sym->ts.derived->attr.alloc_comp
2932 && f->sym->value)
2933 body = gfc_init_default_dt (f->sym, body);
2934 }
f0d4969f 2935
2936 gfc_add_expr_to_block (&fnblock, body);
2937 return gfc_finish_block (&fnblock);
2938}
2939
87114d2e 2940
4ee9c684 2941/* Generate function entry and exit code, and add it to the function body.
2942 This includes:
f888a3fb 2943 Allocation and initialization of array variables.
4ee9c684 2944 Allocation of character string variables.
c8f1568f 2945 Initialization and possibly repacking of dummy arrays.
2946 Initialization of ASSIGN statement auxiliary variable. */
4ee9c684 2947
2948static tree
2949gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2950{
2951 locus loc;
2952 gfc_symbol *sym;
d4163395 2953 gfc_formal_arglist *f;
2954 stmtblock_t body;
25dd7350 2955 bool seen_trans_deferred_array = false;
4ee9c684 2956
2957 /* Deal with implicit return variables. Explicit return variables will
2958 already have been added. */
2959 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2960 {
2961 if (!current_fake_result_decl)
2962 {
c6871095 2963 gfc_entry_list *el = NULL;
2964 if (proc_sym->attr.entry_master)
2965 {
2966 for (el = proc_sym->ns->entries; el; el = el->next)
2967 if (el->sym != el->sym->result)
2968 break;
2969 }
fa7b6574 2970 /* TODO: move to the appropriate place in resolve.c. */
2971 if (warn_return_type && el == NULL)
2972 gfc_warning ("Return value of function '%s' at %L not set",
2973 proc_sym->name, &proc_sym->declared_at);
4ee9c684 2974 }
c6871095 2975 else if (proc_sym->as)
4ee9c684 2976 {
d4163395 2977 tree result = TREE_VALUE (current_fake_result_decl);
2978 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
10b07432 2979
2980 /* An automatic character length, pointer array result. */
2981 if (proc_sym->ts.type == BT_CHARACTER
2982 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2983 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2984 fnbody);
4ee9c684 2985 }
2986 else if (proc_sym->ts.type == BT_CHARACTER)
2987 {
2988 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
d4163395 2989 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2990 fnbody);
4ee9c684 2991 }
2992 else
bdaed7d2 2993 gcc_assert (gfc_option.flag_f2c
2994 && proc_sym->ts.type == BT_COMPLEX);
4ee9c684 2995 }
2996
87114d2e 2997 /* Initialize the INTENT(OUT) derived type dummy arguments. This
2998 should be done here so that the offsets and lbounds of arrays
2999 are available. */
3000 fnbody = init_intent_out_dt (proc_sym, fnbody);
3001
4ee9c684 3002 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3003 {
2294b616 3004 bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3005 && sym->ts.derived->attr.alloc_comp;
4ee9c684 3006 if (sym->attr.dimension)
3007 {
3008 switch (sym->as->type)
3009 {
3010 case AS_EXPLICIT:
3011 if (sym->attr.dummy || sym->attr.result)
3012 fnbody =
3013 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3014 else if (sym->attr.pointer || sym->attr.allocatable)
3015 {
3016 if (TREE_STATIC (sym->backend_decl))
3017 gfc_trans_static_array_pointer (sym);
3018 else
25dd7350 3019 {
3020 seen_trans_deferred_array = true;
3021 fnbody = gfc_trans_deferred_array (sym, fnbody);
3022 }
4ee9c684 3023 }
3024 else
3025 {
25dd7350 3026 if (sym_has_alloc_comp)
3027 {
3028 seen_trans_deferred_array = true;
3029 fnbody = gfc_trans_deferred_array (sym, fnbody);
3030 }
f0d4969f 3031 else if (sym->ts.type == BT_DERIVED
3032 && sym->value
3033 && !sym->attr.data
3034 && sym->attr.save == SAVE_NONE)
89e89e42 3035 fnbody = gfc_init_default_dt (sym, fnbody);
25dd7350 3036
4ee9c684 3037 gfc_get_backend_locus (&loc);
3038 gfc_set_backend_locus (&sym->declared_at);
3039 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3040 sym, fnbody);
3041 gfc_set_backend_locus (&loc);
3042 }
3043 break;
3044
3045 case AS_ASSUMED_SIZE:
3046 /* Must be a dummy parameter. */
22d678e8 3047 gcc_assert (sym->attr.dummy);
4ee9c684 3048
3049 /* We should always pass assumed size arrays the g77 way. */
4ee9c684 3050 fnbody = gfc_trans_g77_array (sym, fnbody);
3051 break;
3052
3053 case AS_ASSUMED_SHAPE:
3054 /* Must be a dummy parameter. */
22d678e8 3055 gcc_assert (sym->attr.dummy);
4ee9c684 3056
3057 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3058 fnbody);
3059 break;
3060
3061 case AS_DEFERRED:
25dd7350 3062 seen_trans_deferred_array = true;
3063 fnbody = gfc_trans_deferred_array (sym, fnbody);
4ee9c684 3064 break;
3065
3066 default:
22d678e8 3067 gcc_unreachable ();
4ee9c684 3068 }
25dd7350 3069 if (sym_has_alloc_comp && !seen_trans_deferred_array)
2294b616 3070 fnbody = gfc_trans_deferred_array (sym, fnbody);
4ee9c684 3071 }
2294b616 3072 else if (sym_has_alloc_comp)
3073 fnbody = gfc_trans_deferred_array (sym, fnbody);
4ee9c684 3074 else if (sym->ts.type == BT_CHARACTER)
3075 {
3076 gfc_get_backend_locus (&loc);
3077 gfc_set_backend_locus (&sym->declared_at);
3078 if (sym->attr.dummy || sym->attr.result)
d4163395 3079 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
4ee9c684 3080 else
3081 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3082 gfc_set_backend_locus (&loc);
3083 }
c8f1568f 3084 else if (sym->attr.assign)
3085 {
3086 gfc_get_backend_locus (&loc);
3087 gfc_set_backend_locus (&sym->declared_at);
3088 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3089 gfc_set_backend_locus (&loc);
3090 }
f0d4969f 3091 else if (sym->ts.type == BT_DERIVED
3092 && sym->value
3093 && !sym->attr.data
3094 && sym->attr.save == SAVE_NONE)
89e89e42 3095 fnbody = gfc_init_default_dt (sym, fnbody);
4ee9c684 3096 else
22d678e8 3097 gcc_unreachable ();
4ee9c684 3098 }
3099
d4163395 3100 gfc_init_block (&body);
3101
3102 for (f = proc_sym->formal; f; f = f->next)
1e853e89 3103 {
3104 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3105 {
3106 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
3107 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
3108 gfc_trans_vla_type_sizes (f->sym, &body);
3109 }
1e853e89 3110 }
d4163395 3111
3112 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3113 && current_fake_result_decl != NULL)
3114 {
3115 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
3116 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
3117 gfc_trans_vla_type_sizes (proc_sym, &body);
3118 }
3119
3120 gfc_add_expr_to_block (&body, fnbody);
3121 return gfc_finish_block (&body);
4ee9c684 3122}
3123
df4d540f 3124static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3125
3126/* Hash and equality functions for module_htab. */
3127
3128static hashval_t
3129module_htab_do_hash (const void *x)
3130{
3131 return htab_hash_string (((const struct module_htab_entry *)x)->name);
3132}
3133
3134static int
3135module_htab_eq (const void *x1, const void *x2)
3136{
3137 return strcmp ((((const struct module_htab_entry *)x1)->name),
3138 (const char *)x2) == 0;
3139}
3140
3141/* Hash and equality functions for module_htab's decls. */
3142
3143static hashval_t
3144module_htab_decls_hash (const void *x)
3145{
3146 const_tree t = (const_tree) x;
3147 const_tree n = DECL_NAME (t);
3148 if (n == NULL_TREE)
3149 n = TYPE_NAME (TREE_TYPE (t));
3150 return htab_hash_string (IDENTIFIER_POINTER (n));
3151}
3152
3153static int
3154module_htab_decls_eq (const void *x1, const void *x2)
3155{
3156 const_tree t1 = (const_tree) x1;
3157 const_tree n1 = DECL_NAME (t1);
3158 if (n1 == NULL_TREE)
3159 n1 = TYPE_NAME (TREE_TYPE (t1));
3160 return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3161}
3162
3163struct module_htab_entry *
3164gfc_find_module (const char *name)
3165{
3166 void **slot;
3167
3168 if (! module_htab)
3169 module_htab = htab_create_ggc (10, module_htab_do_hash,
3170 module_htab_eq, NULL);
3171
3172 slot = htab_find_slot_with_hash (module_htab, name,
3173 htab_hash_string (name), INSERT);
3174 if (*slot == NULL)
3175 {
3176 struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3177
3178 entry->name = gfc_get_string (name);
3179 entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3180 module_htab_decls_eq, NULL);
3181 *slot = (void *) entry;
3182 }
3183 return (struct module_htab_entry *) *slot;
3184}
3185
3186void
3187gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3188{
3189 void **slot;
3190 const char *name;
3191
3192 if (DECL_NAME (decl))
3193 name = IDENTIFIER_POINTER (DECL_NAME (decl));
3194 else
3195 {
3196 gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3197 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3198 }
3199 slot = htab_find_slot_with_hash (entry->decls, name,
3200 htab_hash_string (name), INSERT);
3201 if (*slot == NULL)
3202 *slot = (void *) decl;
3203}
3204
3205static struct module_htab_entry *cur_module;
4ee9c684 3206
3207/* Output an initialized decl for a module variable. */
3208
3209static void
3210gfc_create_module_variable (gfc_symbol * sym)
3211{
3212 tree decl;
4ee9c684 3213
d77f260f 3214 /* Module functions with alternate entries are dealt with later and
3215 would get caught by the next condition. */
3216 if (sym->attr.entry)
3217 return;
3218
c5d33754 3219 /* Make sure we convert the types of the derived types from iso_c_binding
3220 into (void *). */
3221 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3222 && sym->ts.type == BT_DERIVED)
3223 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3224
df4d540f 3225 if (sym->attr.flavor == FL_DERIVED
3226 && sym->backend_decl
3227 && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3228 {
3229 decl = sym->backend_decl;
3230 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3231 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3232 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3233 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3234 || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3235 == sym->ns->proc_name->backend_decl);
3236 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3237 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3238 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3239 }
3240
cf269acc 3241 /* Only output variables, procedure pointers and array valued,
3242 or derived type, parameters. */
4ee9c684 3243 if (sym->attr.flavor != FL_VARIABLE
be0f1581 3244 && !(sym->attr.flavor == FL_PARAMETER
cf269acc 3245 && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3246 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4ee9c684 3247 return;
3248
df4d540f 3249 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3250 {
3251 decl = sym->backend_decl;
3252 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3253 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3254 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3255 gfc_module_add_decl (cur_module, decl);
3256 }
3257
d43a7f7f 3258 /* Don't generate variables from other modules. Variables from
3259 COMMONs will already have been generated. */
3260 if (sym->attr.use_assoc || sym->attr.in_common)
4ee9c684 3261 return;
3262
2b685f8e 3263 /* Equivalenced variables arrive here after creation. */
976d903a 3264 if (sym->backend_decl
df4d540f 3265 && (sym->equiv_built || sym->attr.in_equivalence))
3266 return;
2b685f8e 3267
4ee9c684 3268 if (sym->backend_decl)
3269 internal_error ("backend decl for module variable %s already exists",
3270 sym->name);
3271
3272 /* We always want module variables to be created. */
3273 sym->attr.referenced = 1;
3274 /* Create the decl. */
3275 decl = gfc_get_symbol_decl (sym);
3276
4ee9c684 3277 /* Create the variable. */
3278 pushdecl (decl);
df4d540f 3279 gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3280 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3281 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
b2c4af5e 3282 rest_of_decl_compilation (decl, 1, 0);
df4d540f 3283 gfc_module_add_decl (cur_module, decl);
4ee9c684 3284
3285 /* Also add length of strings. */
3286 if (sym->ts.type == BT_CHARACTER)
3287 {
3288 tree length;
3289
3290 length = sym->ts.cl->backend_decl;
3291 if (!INTEGER_CST_P (length))
3292 {
3293 pushdecl (length);
b2c4af5e 3294 rest_of_decl_compilation (length, 1, 0);
4ee9c684 3295 }
3296 }
3297}
3298
51d9479b 3299/* Emit debug information for USE statements. */
df4d540f 3300
3301static void
3302gfc_trans_use_stmts (gfc_namespace * ns)
3303{
3304 gfc_use_list *use_stmt;
3305 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3306 {
3307 struct module_htab_entry *entry
3308 = gfc_find_module (use_stmt->module_name);
3309 gfc_use_rename *rent;
3310
3311 if (entry->namespace_decl == NULL)
3312 {
3313 entry->namespace_decl
3314 = build_decl (NAMESPACE_DECL,
3315 get_identifier (use_stmt->module_name),
3316 void_type_node);
3317 DECL_EXTERNAL (entry->namespace_decl) = 1;
3318 }
51d9479b 3319 gfc_set_backend_locus (&use_stmt->where);
df4d540f 3320 if (!use_stmt->only_flag)
3321 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3322 NULL_TREE,
3323 ns->proc_name->backend_decl,
3324 false);
3325 for (rent = use_stmt->rename; rent; rent = rent->next)
3326 {
3327 tree decl, local_name;
3328 void **slot;
3329
3330 if (rent->op != INTRINSIC_NONE)
3331 continue;
3332
3333 slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3334 htab_hash_string (rent->use_name),
3335 INSERT);
3336 if (*slot == NULL)
3337 {
3338 gfc_symtree *st;
3339
3340 st = gfc_find_symtree (ns->sym_root,
3341 rent->local_name[0]
3342 ? rent->local_name : rent->use_name);
3343 gcc_assert (st && st->n.sym->attr.use_assoc);
51d9479b 3344 if (st->n.sym->backend_decl
3345 && DECL_P (st->n.sym->backend_decl)
3346 && st->n.sym->module
3347 && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
df4d540f 3348 {
51d9479b 3349 gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3350 || (TREE_CODE (st->n.sym->backend_decl)
3351 != VAR_DECL));
df4d540f 3352 decl = copy_node (st->n.sym->backend_decl);
3353 DECL_CONTEXT (decl) = entry->namespace_decl;
3354 DECL_EXTERNAL (decl) = 1;
3355 DECL_IGNORED_P (decl) = 0;
3356 DECL_INITIAL (decl) = NULL_TREE;
3357 }
3358 else
3359 {
3360 *slot = error_mark_node;
3361 htab_clear_slot (entry->decls, slot);
3362 continue;
3363 }
3364 *slot = decl;
3365 }
3366 decl = (tree) *slot;
3367 if (rent->local_name[0])
3368 local_name = get_identifier (rent->local_name);
3369 else
3370 local_name = NULL_TREE;
51d9479b 3371 gfc_set_backend_locus (&rent->where);
df4d540f 3372 (*debug_hooks->imported_module_or_decl) (decl, local_name,
3373 ns->proc_name->backend_decl,
3374 !use_stmt->only_flag);
3375 }
3376 }
4ee9c684 3377}
3378
51d9479b 3379
2eb674c9 3380/* Return true if expr is a constant initializer that gfc_conv_initializer
3381 will handle. */
3382
3383static bool
3384check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3385 bool pointer)
3386{
3387 gfc_constructor *c;
3388 gfc_component *cm;
3389
3390 if (pointer)
3391 return true;
3392 else if (array)
3393 {
3394 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3395 return true;
3396 else if (expr->expr_type == EXPR_STRUCTURE)
3397 return check_constant_initializer (expr, ts, false, false);
3398 else if (expr->expr_type != EXPR_ARRAY)
3399 return false;
3400 for (c = expr->value.constructor; c; c = c->next)
3401 {
3402 if (c->iterator)
3403 return false;
3404 if (c->expr->expr_type == EXPR_STRUCTURE)
3405 {
3406 if (!check_constant_initializer (c->expr, ts, false, false))
3407 return false;
3408 }
3409 else if (c->expr->expr_type != EXPR_CONSTANT)
3410 return false;
3411 }
3412 return true;
3413 }
3414 else switch (ts->type)
3415 {
3416 case BT_DERIVED:
3417 if (expr->expr_type != EXPR_STRUCTURE)
3418 return false;
3419 cm = expr->ts.derived->components;
3420 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3421 {
3422 if (!c->expr || cm->attr.allocatable)
3423 continue;
3424 if (!check_constant_initializer (c->expr, &cm->ts,
3425 cm->attr.dimension,
3426 cm->attr.pointer))
3427 return false;
3428 }
3429 return true;
3430 default:
3431 return expr->expr_type == EXPR_CONSTANT;
3432 }
3433}
3434
3435/* Emit debug info for parameters and unreferenced variables with
3436 initializers. */
3437
3438static void
3439gfc_emit_parameter_debug_info (gfc_symbol *sym)
3440{
3441 tree decl;
3442
3443 if (sym->attr.flavor != FL_PARAMETER
3444 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3445 return;
3446
3447 if (sym->backend_decl != NULL
3448 || sym->value == NULL
3449 || sym->attr.use_assoc
3450 || sym->attr.dummy
3451 || sym->attr.result
3452 || sym->attr.function
3453 || sym->attr.intrinsic
3454 || sym->attr.pointer
3455 || sym->attr.allocatable
3456 || sym->attr.cray_pointee
3457 || sym->attr.threadprivate
3458 || sym->attr.is_bind_c
3459 || sym->attr.subref_array_pointer
3460 || sym->attr.assign)
3461 return;
3462
3463 if (sym->ts.type == BT_CHARACTER)
3464 {
3465 gfc_conv_const_charlen (sym->ts.cl);
3466 if (sym->ts.cl->backend_decl == NULL
3467 || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
3468 return;
3469 }
3470 else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
3471 return;
3472
3473 if (sym->as)
3474 {
3475 int n;
3476
3477 if (sym->as->type != AS_EXPLICIT)
3478 return;
3479 for (n = 0; n < sym->as->rank; n++)
3480 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3481 || sym->as->upper[n] == NULL
3482 || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3483 return;
3484 }
3485
3486 if (!check_constant_initializer (sym->value, &sym->ts,
3487 sym->attr.dimension, false))
3488 return;
3489
3490 /* Create the decl for the variable or constant. */
3491 decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3492 gfc_sym_identifier (sym), gfc_sym_type (sym));
3493 if (sym->attr.flavor == FL_PARAMETER)
3494 TREE_READONLY (decl) = 1;
3495 gfc_set_decl_location (decl, &sym->declared_at);
3496 if (sym->attr.dimension)
3497 GFC_DECL_PACKED_ARRAY (decl) = 1;
3498 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3499 TREE_STATIC (decl) = 1;
3500 TREE_USED (decl) = 1;
3501 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3502 TREE_PUBLIC (decl) = 1;
3503 DECL_INITIAL (decl)
3504 = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3505 sym->attr.dimension, 0);
3506 debug_hooks->global_decl (decl);
3507}
3508
51d9479b 3509/* Generate all the required code for module variables. */
3510
3511void
3512gfc_generate_module_vars (gfc_namespace * ns)
3513{
3514 module_namespace = ns;
3515 cur_module = gfc_find_module (ns->proc_name->name);
3516
3517 /* Check if the frontend left the namespace in a reasonable state. */
3518 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3519
3520 /* Generate COMMON blocks. */
3521 gfc_trans_common (ns);
3522
3523 /* Create decls for all the module variables. */
3524 gfc_traverse_ns (ns, gfc_create_module_variable);
3525
3526 cur_module = NULL;
3527
3528 gfc_trans_use_stmts (ns);
2eb674c9 3529 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
51d9479b 3530}
3531
3532
4ee9c684 3533static void
3534gfc_generate_contained_functions (gfc_namespace * parent)
3535{
3536 gfc_namespace *ns;
3537
3538 /* We create all the prototypes before generating any code. */
3539 for (ns = parent->contained; ns; ns = ns->sibling)
3540 {
3541 /* Skip namespaces from used modules. */
3542 if (ns->parent != parent)
3543 continue;
3544
1b716045 3545 gfc_create_function_decl (ns);
4ee9c684 3546 }
3547
3548 for (ns = parent->contained; ns; ns = ns->sibling)
3549 {
3550 /* Skip namespaces from used modules. */
3551 if (ns->parent != parent)
3552 continue;
3553
3554 gfc_generate_function_code (ns);
3555 }
3556}
3557
3558
d95efb59 3559/* Drill down through expressions for the array specification bounds and
3560 character length calling generate_local_decl for all those variables
3561 that have not already been declared. */
3562
3563static void
3564generate_local_decl (gfc_symbol *);
3565
1acb400a 3566/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
d95efb59 3567
1acb400a 3568static bool
3569expr_decls (gfc_expr *e, gfc_symbol *sym,
3570 int *f ATTRIBUTE_UNUSED)
3571{
3572 if (e->expr_type != EXPR_VARIABLE
3573 || sym == e->symtree->n.sym
d95efb59 3574 || e->symtree->n.sym->mark
3575 || e->symtree->n.sym->ns != sym->ns)
1acb400a 3576 return false;
d95efb59 3577
1acb400a 3578 generate_local_decl (e->symtree->n.sym);
3579 return false;
3580}
d95efb59 3581
1acb400a 3582static void
3583generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3584{
3585 gfc_traverse_expr (e, sym, expr_decls, 0);
d95efb59 3586}
3587
3588
f6d0e37a 3589/* Check for dependencies in the character length and array spec. */
d95efb59 3590
3591static void
3592generate_dependency_declarations (gfc_symbol *sym)
3593{
3594 int i;
3595
3596 if (sym->ts.type == BT_CHARACTER
256a5f7b 3597 && sym->ts.cl
3598 && sym->ts.cl->length
3599 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
d95efb59 3600 generate_expr_decls (sym, sym->ts.cl->length);
3601
3602 if (sym->as && sym->as->rank)
3603 {
3604 for (i = 0; i < sym->as->rank; i++)
3605 {
3606 generate_expr_decls (sym, sym->as->lower[i]);
3607 generate_expr_decls (sym, sym->as->upper[i]);
3608 }
3609 }
3610}
3611
3612
4ee9c684 3613/* Generate decls for all local variables. We do this to ensure correct
3614 handling of expressions which only appear in the specification of
3615 other functions. */
3616
3617static void
3618generate_local_decl (gfc_symbol * sym)
3619{
3620 if (sym->attr.flavor == FL_VARIABLE)
3621 {
d95efb59 3622 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
8714fc76 3623 generate_dependency_declarations (sym);
d95efb59 3624
4ee9c684 3625 if (sym->attr.referenced)
8714fc76 3626 gfc_get_symbol_decl (sym);
76776e6d 3627 /* INTENT(out) dummy arguments are likely meant to be set. */
3628 else if (warn_unused_variable
3629 && sym->attr.dummy
3630 && sym->attr.intent == INTENT_OUT)
6ecfe89d 3631 gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
76776e6d 3632 sym->name, &sym->declared_at);
3633 /* Specific warning for unused dummy arguments. */
3634 else if (warn_unused_variable && sym->attr.dummy)
6ecfe89d 3635 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
d974cfde 3636 &sym->declared_at);
f888a3fb 3637 /* Warn for unused variables, but not if they're inside a common
14a3addc 3638 block or are use-associated. */
36609028 3639 else if (warn_unused_variable
fa7b6574 3640 && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
6ecfe89d 3641 gfc_warning ("Unused variable '%s' declared at %L", sym->name,
d974cfde 3642 &sym->declared_at);
8714fc76 3643
d4163395 3644 /* For variable length CHARACTER parameters, the PARM_DECL already
3645 references the length variable, so force gfc_get_symbol_decl
3646 even when not referenced. If optimize > 0, it will be optimized
3647 away anyway. But do this only after emitting -Wunused-parameter
3648 warning if requested. */
8714fc76 3649 if (sym->attr.dummy && !sym->attr.referenced
3650 && sym->ts.type == BT_CHARACTER
3651 && sym->ts.cl->backend_decl != NULL
3652 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
d4163395 3653 {
3654 sym->attr.referenced = 1;
3655 gfc_get_symbol_decl (sym);
3656 }
76776e6d 3657
8714fc76 3658 /* INTENT(out) dummy arguments with allocatable components are reset
3659 by default and need to be set referenced to generate the code for
3660 automatic lengths. */
3661 if (sym->attr.dummy && !sym->attr.referenced
3662 && sym->ts.type == BT_DERIVED
3663 && sym->ts.derived->attr.alloc_comp
3664 && sym->attr.intent == INTENT_OUT)
3665 {
3666 sym->attr.referenced = 1;
3667 gfc_get_symbol_decl (sym);
3668 }
3669
3670
e72f979a 3671 /* Check for dependencies in the array specification and string
3672 length, adding the necessary declarations to the function. We
3673 mark the symbol now, as well as in traverse_ns, to prevent
3674 getting stuck in a circular dependency. */
3675 sym->mark = 1;
3676
76776e6d 3677 /* We do not want the middle-end to warn about unused parameters
3678 as this was already done above. */
3679 if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3680 TREE_NO_WARNING(sym->backend_decl) = 1;
4ee9c684 3681 }
5dd246c1 3682 else if (sym->attr.flavor == FL_PARAMETER)
3683 {
6ecfe89d 3684 if (warn_unused_parameter
5dd246c1 3685 && !sym->attr.referenced
3686 && !sym->attr.use_assoc)
6ecfe89d 3687 gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
5dd246c1 3688 &sym->declared_at);
3689 }
fa7b6574 3690 else if (sym->attr.flavor == FL_PROCEDURE)
3691 {
3692 /* TODO: move to the appropriate place in resolve.c. */
3693 if (warn_return_type
3694 && sym->attr.function
3695 && sym->result
3696 && sym != sym->result
3697 && !sym->result->attr.referenced
3698 && !sym->attr.use_assoc
3699 && sym->attr.if_source != IFSRC_IFBODY)
3700 {
3701 gfc_warning ("Return value '%s' of function '%s' declared at "
3702 "%L not set", sym->result->name, sym->name,
3703 &sym->result->declared_at);
3704
3705 /* Prevents "Unused variable" warning for RESULT variables. */
e72f979a 3706 sym->result->mark = 1;
fa7b6574 3707 }
3708 }
c5d33754 3709
19ba2ad8 3710 if (sym->attr.dummy == 1)
3711 {
3712 /* Modify the tree type for scalar character dummy arguments of bind(c)
3713 procedures if they are passed by value. The tree type for them will
3714 be promoted to INTEGER_TYPE for the middle end, which appears to be
3715 what C would do with characters passed by-value. The value attribute
3716 implies the dummy is a scalar. */
3717 if (sym->attr.value == 1 && sym->backend_decl != NULL
3718 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3719 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4c47c8b7 3720 gfc_conv_scalar_char_value (sym, NULL, NULL);
19ba2ad8 3721 }
3722
c5d33754 3723 /* Make sure we convert the types of the derived types from iso_c_binding
3724 into (void *). */
3725 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3726 && sym->ts.type == BT_DERIVED)
3727 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4ee9c684 3728}
3729
3730static void
3731generate_local_vars (gfc_namespace * ns)
3732{
3733 gfc_traverse_ns (ns, generate_local_decl);
3734}
3735
3736
1b716045 3737/* Generate a switch statement to jump to the correct entry point. Also
3738 creates the label decls for the entry points. */
4ee9c684 3739
1b716045 3740static tree
3741gfc_trans_entry_master_switch (gfc_entry_list * el)
4ee9c684 3742{
1b716045 3743 stmtblock_t block;
3744 tree label;
3745 tree tmp;
3746 tree val;
4ee9c684 3747
1b716045 3748 gfc_init_block (&block);
3749 for (; el; el = el->next)
3750 {
3751 /* Add the case label. */
b797d6d3 3752 label = gfc_build_label_decl (NULL_TREE);
7016c612 3753 val = build_int_cst (gfc_array_index_type, el->id);
ed52ef8b 3754 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
1b716045 3755 gfc_add_expr_to_block (&block, tmp);
5b11d932 3756
1b716045 3757 /* And jump to the actual entry point. */
3758 label = gfc_build_label_decl (NULL_TREE);
1b716045 3759 tmp = build1_v (GOTO_EXPR, label);
3760 gfc_add_expr_to_block (&block, tmp);
3761
3762 /* Save the label decl. */
3763 el->label = label;
3764 }
3765 tmp = gfc_finish_block (&block);
3766 /* The first argument selects the entry point. */
3767 val = DECL_ARGUMENTS (current_function_decl);
ed52ef8b 3768 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
1b716045 3769 return tmp;
4ee9c684 3770}
3771
6374121b 3772
a4abf8a0 3773/* Add code to string lengths of actual arguments passed to a function against
3774 the expected lengths of the dummy arguments. */
3775
3776static void
3777add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
3778{
3779 gfc_formal_arglist *formal;
3780
3781 for (formal = sym->formal; formal; formal = formal->next)
3782 if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
3783 {
3784 enum tree_code comparison;
3785 tree cond;
3786 tree argname;
3787 gfc_symbol *fsym;
3788 gfc_charlen *cl;
3789 const char *message;
3790
3791 fsym = formal->sym;
3792 cl = fsym->ts.cl;
3793
3794 gcc_assert (cl);
3795 gcc_assert (cl->passed_length != NULL_TREE);
3796 gcc_assert (cl->backend_decl != NULL_TREE);
3797
3798 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
3799 string lengths must match exactly. Otherwise, it is only required
3800 that the actual string length is *at least* the expected one. */
3801 if (fsym->attr.pointer || fsym->attr.allocatable
3802 || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
3803 {
3804 comparison = NE_EXPR;
3805 message = _("Actual string length does not match the declared one"
3806 " for dummy argument '%s' (%ld/%ld)");
3807 }
3808 else
3809 {
3810 comparison = LT_EXPR;
3811 message = _("Actual string length is shorter than the declared one"
3812 " for dummy argument '%s' (%ld/%ld)");
3813 }
3814
3815 /* Build the condition. For optional arguments, an actual length
3816 of 0 is also acceptable if the associated string is NULL, which
3817 means the argument was not passed. */
3818 cond = fold_build2 (comparison, boolean_type_node,
3819 cl->passed_length, cl->backend_decl);
3820 if (fsym->attr.optional)
3821 {
3822 tree not_absent;
3823 tree not_0length;
3824 tree absent_failed;
3825
3826 not_0length = fold_build2 (NE_EXPR, boolean_type_node,
3827 cl->passed_length,
3828 fold_convert (gfc_charlen_type_node,
3829 integer_zero_node));
3830 not_absent = fold_build2 (NE_EXPR, boolean_type_node,
3831 fsym->backend_decl, null_pointer_node);
3832
3833 absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3834 not_0length, not_absent);
3835
3836 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3837 cond, absent_failed);
3838 }
3839
3840 /* Build the runtime check. */
3841 argname = gfc_build_cstring_const (fsym->name);
3842 argname = gfc_build_addr_expr (pchar_type_node, argname);
3843 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
3844 message, argname,
3845 fold_convert (long_integer_type_node,
3846 cl->passed_length),
3847 fold_convert (long_integer_type_node,
3848 cl->backend_decl));
3849 }
3850}
3851
3852
7257a5d2 3853static void
3854create_main_function (tree fndecl)
3855{
43702da6 3856 tree old_context;
7257a5d2 3857 tree ftn_main;
3858 tree tmp, decl, result_decl, argc, argv, typelist, arglist;
3859 stmtblock_t body;
3860
43702da6 3861 old_context = current_function_decl;
3862
3863 if (old_context)
3864 {
3865 push_function_context ();
3866 saved_parent_function_decls = saved_function_decls;
3867 saved_function_decls = NULL_TREE;
3868 }
3869
7257a5d2 3870 /* main() function must be declared with global scope. */
3871 gcc_assert (current_function_decl == NULL_TREE);
3872
3873 /* Declare the function. */
3874 tmp = build_function_type_list (integer_type_node, integer_type_node,
3875 build_pointer_type (pchar_type_node),
3876 NULL_TREE);
0509d0ee 3877 main_identifier_node = get_identifier ("main");
3878 ftn_main = build_decl (FUNCTION_DECL, main_identifier_node, tmp);
7257a5d2 3879 DECL_EXTERNAL (ftn_main) = 0;
3880 TREE_PUBLIC (ftn_main) = 1;
3881 TREE_STATIC (ftn_main) = 1;
3882 DECL_ATTRIBUTES (ftn_main)
3883 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
3884
3885 /* Setup the result declaration (for "return 0"). */
3886 result_decl = build_decl (RESULT_DECL, NULL_TREE, integer_type_node);
3887 DECL_ARTIFICIAL (result_decl) = 1;
3888 DECL_IGNORED_P (result_decl) = 1;
3889 DECL_CONTEXT (result_decl) = ftn_main;
3890 DECL_RESULT (ftn_main) = result_decl;
3891
3892 pushdecl (ftn_main);
3893
3894 /* Get the arguments. */
3895
3896 arglist = NULL_TREE;
3897 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
3898
3899 tmp = TREE_VALUE (typelist);
3900 argc = build_decl (PARM_DECL, get_identifier ("argc"), tmp);
3901 DECL_CONTEXT (argc) = ftn_main;
3902 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
3903 TREE_READONLY (argc) = 1;
3904 gfc_finish_decl (argc);
3905 arglist = chainon (arglist, argc);
3906
3907 typelist = TREE_CHAIN (typelist);
3908 tmp = TREE_VALUE (typelist);
3909 argv = build_decl (PARM_DECL, get_identifier ("argv"), tmp);
3910 DECL_CONTEXT (argv) = ftn_main;
3911 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
3912 TREE_READONLY (argv) = 1;
3913 DECL_BY_REFERENCE (argv) = 1;
3914 gfc_finish_decl (argv);
3915 arglist = chainon (arglist, argv);
3916
3917 DECL_ARGUMENTS (ftn_main) = arglist;
3918 current_function_decl = ftn_main;
3919 announce_function (ftn_main);
3920
3921 rest_of_decl_compilation (ftn_main, 1, 0);
3922 make_decl_rtl (ftn_main);
3923 init_function_start (ftn_main);
3924 pushlevel (0);
3925
3926 gfc_init_block (&body);
3927
3928 /* Call some libgfortran initialization routines, call then MAIN__(). */
3929
3930 /* Call _gfortran_set_args (argc, argv). */
43702da6 3931 TREE_USED (argc) = 1;
3932 TREE_USED (argv) = 1;
7257a5d2 3933 tmp = build_call_expr (gfor_fndecl_set_args, 2, argc, argv);
3934 gfc_add_expr_to_block (&body, tmp);
3935
3936 /* Add a call to set_options to set up the runtime library Fortran
3937 language standard parameters. */
3938 {
3939 tree array_type, array, var;
3940
3941 /* Passing a new option to the library requires four modifications:
3942 + add it to the tree_cons list below
3943 + change the array size in the call to build_array_type
3944 + change the first argument to the library call
3945 gfor_fndecl_set_options
3946 + modify the library (runtime/compile_options.c)! */
3947
3948 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3949 gfc_option.warn_std), NULL_TREE);
3950 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3951 gfc_option.allow_std), array);
3952 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
3953 array);
3954 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3955 gfc_option.flag_dump_core), array);
3956 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3957 gfc_option.flag_backtrace), array);
3958 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3959 gfc_option.flag_sign_zero), array);
3960
3961 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3962 (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
3963
3964 array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3965 gfc_option.flag_range_check), array);
3966
3967 array_type = build_array_type (integer_type_node,
3968 build_index_type (build_int_cst (NULL_TREE, 7)));
3969 array = build_constructor_from_list (array_type, nreverse (array));
3970 TREE_CONSTANT (array) = 1;
3971 TREE_STATIC (array) = 1;
3972
3973 /* Create a static variable to hold the jump table. */
3974 var = gfc_create_var (array_type, "options");
3975 TREE_CONSTANT (var) = 1;
3976 TREE_STATIC (var) = 1;
3977 TREE_READONLY (var) = 1;
3978 DECL_INITIAL (var) = array;
3979 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
3980
3981 tmp = build_call_expr (gfor_fndecl_set_options, 2,
3982 build_int_cst (integer_type_node, 8), var);
3983 gfc_add_expr_to_block (&body, tmp);
3984 }
3985
3986 /* If -ffpe-trap option was provided, add a call to set_fpe so that
3987 the library will raise a FPE when needed. */
3988 if (gfc_option.fpe != 0)
3989 {
3990 tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3991 build_int_cst (integer_type_node,
3992 gfc_option.fpe));
3993 gfc_add_expr_to_block (&body, tmp);
3994 }
3995
3996 /* If this is the main program and an -fconvert option was provided,
3997 add a call to set_convert. */
3998
3999 if (gfc_option.convert != GFC_CONVERT_NATIVE)
4000 {
4001 tmp = build_call_expr (gfor_fndecl_set_convert, 1,
4002 build_int_cst (integer_type_node,
4003 gfc_option.convert));
4004 gfc_add_expr_to_block (&body, tmp);
4005 }
4006
4007 /* If this is the main program and an -frecord-marker option was provided,
4008 add a call to set_record_marker. */
4009
4010 if (gfc_option.record_marker != 0)
4011 {
4012 tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
4013 build_int_cst (integer_type_node,
4014 gfc_option.record_marker));
4015 gfc_add_expr_to_block (&body, tmp);
4016 }
4017
4018 if (gfc_option.max_subrecord_length != 0)
4019 {
4020 tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length, 1,
4021 build_int_cst (integer_type_node,
4022 gfc_option.max_subrecord_length));
4023 gfc_add_expr_to_block (&body, tmp);
4024 }
4025
4026 /* Call MAIN__(). */
4027 tmp = build_call_expr (fndecl, 0);
4028 gfc_add_expr_to_block (&body, tmp);
4029
43702da6 4030 /* Mark MAIN__ as used. */
4031 TREE_USED (fndecl) = 1;
4032
7257a5d2 4033 /* "return 0". */
4034 tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4035 build_int_cst (integer_type_node, 0));
4036 tmp = build1_v (RETURN_EXPR, tmp);
4037 gfc_add_expr_to_block (&body, tmp);
4038
4039
4040 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4041 decl = getdecls ();
4042
4043 /* Finish off this function and send it for code generation. */
4044 poplevel (1, 0, 1);
4045 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4046
4047 DECL_SAVED_TREE (ftn_main)
4048 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4049 DECL_INITIAL (ftn_main));
4050
4051 /* Output the GENERIC tree. */
4052 dump_function (TDI_original, ftn_main);
4053
4054 gfc_gimplify_function (ftn_main);
4055 cgraph_finalize_function (ftn_main, false);
43702da6 4056
4057 if (old_context)
4058 {
4059 pop_function_context ();
4060 saved_function_decls = saved_parent_function_decls;
4061 }
4062 current_function_decl = old_context;
7257a5d2 4063}
4064
4065
4ee9c684 4066/* Generate code for a function. */
4067
4068void
4069gfc_generate_function_code (gfc_namespace * ns)
4070{
4071 tree fndecl;
4072 tree old_context;
4073 tree decl;
4074 tree tmp;
2294b616 4075 tree tmp2;
4ee9c684 4076 stmtblock_t block;
4077 stmtblock_t body;
4078 tree result;
a466adc9 4079 tree recurcheckvar = NULL;
4ee9c684 4080 gfc_symbol *sym;
2294b616 4081 int rank;
e50e62f5 4082 bool is_recursive;
4ee9c684 4083
4084 sym = ns->proc_name;
1b716045 4085
4ee9c684 4086 /* Check that the frontend isn't still using this. */
22d678e8 4087 gcc_assert (sym->tlink == NULL);
4ee9c684 4088 sym->tlink = sym;
4089
4090 /* Create the declaration for functions with global scope. */
4091 if (!sym->backend_decl)
1b716045 4092 gfc_create_function_decl (ns);
4ee9c684 4093
4094 fndecl = sym->backend_decl;
4095 old_context = current_function_decl;
4096
4097 if (old_context)
4098 {
4099 push_function_context ();
4100 saved_parent_function_decls = saved_function_decls;
4101 saved_function_decls = NULL_TREE;
4102 }
4103
1b716045 4104 trans_function_start (sym);
4ee9c684 4105
e5004242 4106 gfc_init_block (&block);
4ee9c684 4107
c6871095 4108 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4109 {
4110 /* Copy length backend_decls to all entry point result
4111 symbols. */
4112 gfc_entry_list *el;
4113 tree backend_decl;
4114
4115 gfc_conv_const_charlen (ns->proc_name->ts.cl);
4116 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
4117 for (el = ns->entries; el; el = el->next)
4118 el->sym->result->ts.cl->backend_decl = backend_decl;
4119 }
4120
4ee9c684 4121 /* Translate COMMON blocks. */
4122 gfc_trans_common (ns);
4123
c750cc52 4124 /* Null the parent fake result declaration if this namespace is
4125 a module function or an external procedures. */
4126 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4127 || ns->parent == NULL)
4128 parent_fake_result_decl = NULL_TREE;
4129
2b685f8e 4130 gfc_generate_contained_functions (ns);
4131
9579733e 4132 nonlocal_dummy_decls = NULL;
4133 nonlocal_dummy_decl_pset = NULL;
4134
4ee9c684 4135 generate_local_vars (ns);
5b11d932 4136
c750cc52 4137 /* Keep the parent fake result declaration in module functions
4138 or external procedures. */
4139 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4140 || ns->parent == NULL)
4141 current_fake_result_decl = parent_fake_result_decl;
4142 else
4143 current_fake_result_decl = NULL_TREE;
4144
4ee9c684 4145 current_function_return_label = NULL;
4146
4147 /* Now generate the code for the body of this function. */
4148 gfc_init_block (&body);
4149
e50e62f5 4150 is_recursive = sym->attr.recursive
4151 || (sym->attr.entry_master
4152 && sym->ns->entries->sym->attr.recursive);
4153 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
a466adc9 4154 {
4155 char * msg;
4156
4157 asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4158 sym->name);
4159 recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4160 TREE_STATIC (recurcheckvar) = 1;
4161 DECL_INITIAL (recurcheckvar) = boolean_false_node;
4162 gfc_add_expr_to_block (&block, recurcheckvar);
4163 gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4164 &sym->declared_at, msg);
4165 gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4166 gfc_free (msg);
4167 }
4168
4ee9c684 4169 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4170 && sym->attr.subroutine)
4171 {
4172 tree alternate_return;
c750cc52 4173 alternate_return = gfc_get_fake_result_decl (sym, 0);
75a70cf9 4174 gfc_add_modify (&body, alternate_return, integer_zero_node);
4ee9c684 4175 }
4176
1b716045 4177 if (ns->entries)
4178 {
4179 /* Jump to the correct entry point. */
4180 tmp = gfc_trans_entry_master_switch (ns->entries);
4181 gfc_add_expr_to_block (&body, tmp);
4182 }
4183
a4abf8a0 4184 /* If bounds-checking is enabled, generate code to check passed in actual
4185 arguments against the expected dummy argument attributes (e.g. string
4186 lengths). */
6ba3bda4 4187 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
a4abf8a0 4188 add_argument_checking (&body, sym);
4189
4ee9c684 4190 tmp = gfc_trans_code (ns->code);
4191 gfc_add_expr_to_block (&body, tmp);
4192
4193 /* Add a return label if needed. */
4194 if (current_function_return_label)
4195 {
4196 tmp = build1_v (LABEL_EXPR, current_function_return_label);
4197 gfc_add_expr_to_block (&body, tmp);
4198 }
4199
4200 tmp = gfc_finish_block (&body);
4201 /* Add code to create and cleanup arrays. */
4202 tmp = gfc_trans_deferred_vars (sym, tmp);
4ee9c684 4203
4204 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4205 {
14a3addc 4206 if (sym->attr.subroutine || sym == sym->result)
4ee9c684 4207 {
d4163395 4208 if (current_fake_result_decl != NULL)
4209 result = TREE_VALUE (current_fake_result_decl);
4210 else
4211 result = NULL_TREE;
4ee9c684 4212 current_fake_result_decl = NULL_TREE;
4213 }
4214 else
4215 result = sym->result->backend_decl;
4216
2294b616 4217 if (result != NULL_TREE && sym->attr.function
4218 && sym->ts.type == BT_DERIVED
091bff86 4219 && sym->ts.derived->attr.alloc_comp
4220 && !sym->attr.pointer)
2294b616 4221 {
4222 rank = sym->as ? sym->as->rank : 0;
4223 tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
4224 gfc_add_expr_to_block (&block, tmp2);
4225 }
4226
fa7b6574 4227 gfc_add_expr_to_block (&block, tmp);
4228
e50e62f5 4229 /* Reset recursion-check variable. */
4230 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4231 {
4232 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4233 recurcheckvar = NULL;
4234 }
4235
fa7b6574 4236 if (result == NULL_TREE)
4237 {
4238 /* TODO: move to the appropriate place in resolve.c. */
4239 if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4240 gfc_warning ("Return value of function '%s' at %L not set",
4241 sym->name, &sym->declared_at);
2294b616 4242
fa7b6574 4243 TREE_NO_WARNING(sym->backend_decl) = 1;
4244 }
4ee9c684 4245 else
4246 {
3350e716 4247 /* Set the return value to the dummy result variable. The
4248 types may be different for scalar default REAL functions
4249 with -ff2c, therefore we have to convert. */
4250 tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
f75d6b8a 4251 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4252 DECL_RESULT (fndecl), tmp);
ed52ef8b 4253 tmp = build1_v (RETURN_EXPR, tmp);
4ee9c684 4254 gfc_add_expr_to_block (&block, tmp);
4255 }
4256 }
2294b616 4257 else
e50e62f5 4258 {
4259 gfc_add_expr_to_block (&block, tmp);
4260 /* Reset recursion-check variable. */
4261 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4262 {
4263 gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4264 recurcheckvar = NULL;
4265 }
4266 }
2294b616 4267
4ee9c684 4268
4269 /* Add all the decls we created during processing. */
4270 decl = saved_function_decls;
4271 while (decl)
4272 {
4273 tree next;
4274
4275 next = TREE_CHAIN (decl);
4276 TREE_CHAIN (decl) = NULL_TREE;
4277 pushdecl (decl);
4278 decl = next;
4279 }
4280 saved_function_decls = NULL_TREE;
4281
4282 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
e5004242 4283 decl = getdecls ();
4ee9c684 4284
4285 /* Finish off this function and send it for code generation. */
4286 poplevel (1, 0, 1);
4287 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4288
e5004242 4289 DECL_SAVED_TREE (fndecl)
4290 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4291 DECL_INITIAL (fndecl));
4292
9579733e 4293 if (nonlocal_dummy_decls)
4294 {
4295 BLOCK_VARS (DECL_INITIAL (fndecl))
4296 = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4297 pointer_set_destroy (nonlocal_dummy_decl_pset);
4298 nonlocal_dummy_decls = NULL;
4299 nonlocal_dummy_decl_pset = NULL;
4300 }
4301
4ee9c684 4302 /* Output the GENERIC tree. */
4303 dump_function (TDI_original, fndecl);
4304
4305 /* Store the end of the function, so that we get good line number
4306 info for the epilogue. */
4307 cfun->function_end_locus = input_location;
4308
4309 /* We're leaving the context of this function, so zap cfun.
4310 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4311 tree_rest_of_compilation. */
87d4aa85 4312 set_cfun (NULL);
4ee9c684 4313
4314 if (old_context)
4315 {
4316 pop_function_context ();
4317 saved_function_decls = saved_parent_function_decls;
4318 }
4319 current_function_decl = old_context;
4320
4321 if (decl_function_context (fndecl))
6374121b 4322 /* Register this function with cgraph just far enough to get it
4323 added to our parent's nested function list. */
4324 (void) cgraph_node (fndecl);
4ee9c684 4325 else
4326 {
6374121b 4327 gfc_gimplify_function (fndecl);
9d95b2b0 4328 cgraph_finalize_function (fndecl, false);
4ee9c684 4329 }
df4d540f 4330
4331 gfc_trans_use_stmts (ns);
2eb674c9 4332 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
7257a5d2 4333
4334 if (sym->attr.is_main_program)
4335 create_main_function (fndecl);
4ee9c684 4336}
4337
7257a5d2 4338
4ee9c684 4339void
4340gfc_generate_constructors (void)
4341{
22d678e8 4342 gcc_assert (gfc_static_ctors == NULL_TREE);
4ee9c684 4343#if 0
4344 tree fnname;
4345 tree type;
4346 tree fndecl;
4347 tree decl;
4348 tree tmp;
4349
4350 if (gfc_static_ctors == NULL_TREE)
4351 return;
4352
db85cc4f 4353 fnname = get_file_function_name ("I");
4ee9c684 4354 type = build_function_type (void_type_node,
4355 gfc_chainon_list (NULL_TREE, void_type_node));
4356
4357 fndecl = build_decl (FUNCTION_DECL, fnname, type);
4358 TREE_PUBLIC (fndecl) = 1;
4359
4360 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
540edea7 4361 DECL_ARTIFICIAL (decl) = 1;
4362 DECL_IGNORED_P (decl) = 1;
4ee9c684 4363 DECL_CONTEXT (decl) = fndecl;
4364 DECL_RESULT (fndecl) = decl;
4365
4366 pushdecl (fndecl);
4367
4368 current_function_decl = fndecl;
4369
b2c4af5e 4370 rest_of_decl_compilation (fndecl, 1, 0);
4ee9c684 4371
b2c4af5e 4372 make_decl_rtl (fndecl);
4ee9c684 4373
b31f705b 4374 init_function_start (fndecl);
4ee9c684 4375
4ee9c684 4376 pushlevel (0);
4377
4378 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4379 {
c2f47e15 4380 tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
4ee9c684 4381 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
4382 }
4383
e5004242 4384 decl = getdecls ();
4ee9c684 4385 poplevel (1, 0, 1);
4386
4387 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
e5004242 4388 DECL_SAVED_TREE (fndecl)
4389 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4390 DECL_INITIAL (fndecl));
4ee9c684 4391
4392 free_after_parsing (cfun);
4393 free_after_compilation (cfun);
4394
6148a911 4395 tree_rest_of_compilation (fndecl);
4ee9c684 4396
4397 current_function_decl = NULL_TREE;
4398#endif
4399}
4400
9ec7c303 4401/* Translates a BLOCK DATA program unit. This means emitting the
4402 commons contained therein plus their initializations. We also emit
4403 a globally visible symbol to make sure that each BLOCK DATA program
4404 unit remains unique. */
4405
4406void
4407gfc_generate_block_data (gfc_namespace * ns)
4408{
4409 tree decl;
4410 tree id;
4411
b31f705b 4412 /* Tell the backend the source location of the block data. */
4413 if (ns->proc_name)
4414 gfc_set_backend_locus (&ns->proc_name->declared_at);
4415 else
4416 gfc_set_backend_locus (&gfc_current_locus);
4417
4418 /* Process the DATA statements. */
9ec7c303 4419 gfc_trans_common (ns);
4420
b31f705b 4421 /* Create a global symbol with the mane of the block data. This is to
4422 generate linker errors if the same name is used twice. It is never
4423 really used. */
9ec7c303 4424 if (ns->proc_name)
4425 id = gfc_sym_mangled_function_id (ns->proc_name);
4426 else
4427 id = get_identifier ("__BLOCK_DATA__");
4428
4429 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
4430 TREE_PUBLIC (decl) = 1;
4431 TREE_STATIC (decl) = 1;
df4d540f 4432 DECL_IGNORED_P (decl) = 1;
9ec7c303 4433
4434 pushdecl (decl);
4435 rest_of_decl_compilation (decl, 1, 0);
4436}
4437
b549d2a5 4438
4ee9c684 4439#include "gt-fortran-trans-decl.h"
Mirror of https://gcc.gnu.org/git/gcc.git