]> gcc.gnu.org Git - gcc.git/blame - gcc/fortran/trans-decl.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
2006-10-03 Gary Benson <gbenson@redhat.com>
[gcc.git] / gcc / fortran / trans-decl.c
CommitLineData
6de9cd9a 1/* Backend function setup
681f47f2
TS		 2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
3 Inc.
6de9cd9a
DN		 4 Contributed by Paul Brook
5
9fc4d79b 6This file is part of GCC.
6de9cd9a 7
9fc4d79b
TS		 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
10Software Foundation; either version 2, or (at your option) any later
11version.
6de9cd9a 12
9fc4d79b
TS		 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.
6de9cd9a
DN		 17
18You should have received a copy of the GNU General Public License
9fc4d79b 19along with GCC; see the file COPYING. If not, write to the Free
ab57747b
KC		 20Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
2102110-1301, USA. */
6de9cd9a
DN		 22
23/* trans-decl.c -- Handling of backend function and variable decls, etc */
24
25#include "config.h"
26#include "system.h"
27#include "coretypes.h"
28#include "tree.h"
29#include "tree-dump.h"
eadf906f 30#include "tree-gimple.h"
6de9cd9a
DN		 31#include "ggc.h"
32#include "toplev.h"
33#include "tm.h"
25f2dfd3 34#include "rtl.h"
6de9cd9a
DN		 35#include "target.h"
36#include "function.h"
6de9cd9a
DN		 37#include "flags.h"
38#include "cgraph.h"
6de9cd9a
DN		 39#include "gfortran.h"
40#include "trans.h"
41#include "trans-types.h"
42#include "trans-array.h"
43#include "trans-const.h"
44/* Only for gfc_trans_code. Shouldn't need to include this. */
45#include "trans-stmt.h"
46
47#define MAX_LABEL_VALUE 99999
48
49
50/* Holds the result of the function if no result variable specified. */
51
52static GTY(()) tree current_fake_result_decl;
5f20c93a 53static GTY(()) tree parent_fake_result_decl;
6de9cd9a
DN		 54
55static GTY(()) tree current_function_return_label;
56
57
58/* Holds the variable DECLs for the current function. */
59
417ab240
JJ		 60static GTY(()) tree saved_function_decls;
61static GTY(()) tree saved_parent_function_decls;
6de9cd9a
DN		 62
63
64/* The namespace of the module we're currently generating. Only used while
65 outputting decls for module variables. Do not rely on this being set. */
66
67static gfc_namespace *module_namespace;
68
69
70/* List of static constructor functions. */
71
72tree gfc_static_ctors;
73
74
75/* Function declarations for builtin library functions. */
76
77tree gfor_fndecl_internal_malloc;
78tree gfor_fndecl_internal_malloc64;
ec25720b
RS		 79tree gfor_fndecl_internal_realloc;
80tree gfor_fndecl_internal_realloc64;
6de9cd9a
DN		 81tree gfor_fndecl_internal_free;
82tree gfor_fndecl_allocate;
83tree gfor_fndecl_allocate64;
5b725b8d
TK		 84tree gfor_fndecl_allocate_array;
85tree gfor_fndecl_allocate64_array;
6de9cd9a
DN		 86tree gfor_fndecl_deallocate;
87tree gfor_fndecl_pause_numeric;
88tree gfor_fndecl_pause_string;
89tree gfor_fndecl_stop_numeric;
90tree gfor_fndecl_stop_string;
91tree gfor_fndecl_select_string;
92tree gfor_fndecl_runtime_error;
944b8b35 93tree gfor_fndecl_set_fpe;
8b67b708 94tree gfor_fndecl_set_std;
eaa90d25 95tree gfor_fndecl_set_convert;
d67ab5ee 96tree gfor_fndecl_set_record_marker;
35059811
FXC		 97tree gfor_fndecl_ctime;
98tree gfor_fndecl_fdate;
25fc05eb 99tree gfor_fndecl_ttynam;
6de9cd9a
DN		 100tree gfor_fndecl_in_pack;
101tree gfor_fndecl_in_unpack;
102tree gfor_fndecl_associated;
103
104
105/* Math functions. Many other math functions are handled in
106 trans-intrinsic.c. */
107
644cb69f 108gfc_powdecl_list gfor_fndecl_math_powi[4][3];
6de9cd9a
DN		 109tree gfor_fndecl_math_cpowf;
110tree gfor_fndecl_math_cpow;
644cb69f
FXC		 111tree gfor_fndecl_math_cpowl10;
112tree gfor_fndecl_math_cpowl16;
6de9cd9a
DN		 113tree gfor_fndecl_math_ishftc4;
114tree gfor_fndecl_math_ishftc8;
644cb69f 115tree gfor_fndecl_math_ishftc16;
6de9cd9a
DN		 116tree gfor_fndecl_math_exponent4;
117tree gfor_fndecl_math_exponent8;
644cb69f
FXC		 118tree gfor_fndecl_math_exponent10;
119tree gfor_fndecl_math_exponent16;
6de9cd9a
DN		 120
121
122/* String functions. */
123
6de9cd9a
DN		 124tree gfor_fndecl_compare_string;
125tree gfor_fndecl_concat_string;
126tree gfor_fndecl_string_len_trim;
127tree gfor_fndecl_string_index;
128tree gfor_fndecl_string_scan;
129tree gfor_fndecl_string_verify;
130tree gfor_fndecl_string_trim;
131tree gfor_fndecl_string_repeat;
132tree gfor_fndecl_adjustl;
133tree gfor_fndecl_adjustr;
134
135
136/* Other misc. runtime library functions. */
137
138tree gfor_fndecl_size0;
139tree gfor_fndecl_size1;
b41b2534 140tree gfor_fndecl_iargc;
6de9cd9a
DN		 141
142/* Intrinsic functions implemented in FORTRAN. */
143tree gfor_fndecl_si_kind;
144tree gfor_fndecl_sr_kind;
145
146
147static void
148gfc_add_decl_to_parent_function (tree decl)
149{
6e45f57b 150 gcc_assert (decl);
6de9cd9a
DN		 151 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
152 DECL_NONLOCAL (decl) = 1;
153 TREE_CHAIN (decl) = saved_parent_function_decls;
154 saved_parent_function_decls = decl;
155}
156
157void
158gfc_add_decl_to_function (tree decl)
159{
6e45f57b 160 gcc_assert (decl);
6de9cd9a
DN		 161 TREE_USED (decl) = 1;
162 DECL_CONTEXT (decl) = current_function_decl;
163 TREE_CHAIN (decl) = saved_function_decls;
164 saved_function_decls = decl;
165}
166
167
c006df4e
SB		 168/* Build a backend label declaration. Set TREE_USED for named labels.
169 The context of the label is always the current_function_decl. All
170 labels are marked artificial. */
6de9cd9a
DN		 171
172tree
173gfc_build_label_decl (tree label_id)
174{
175 /* 2^32 temporaries should be enough. */
176 static unsigned int tmp_num = 1;
177 tree label_decl;
178 char *label_name;
179
180 if (label_id == NULL_TREE)
181 {
182 /* Build an internal label name. */
183 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
184 label_id = get_identifier (label_name);
185 }
186 else
187 label_name = NULL;
188
189 /* Build the LABEL_DECL node. Labels have no type. */
190 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
191 DECL_CONTEXT (label_decl) = current_function_decl;
192 DECL_MODE (label_decl) = VOIDmode;
193
c006df4e
SB		 194 /* We always define the label as used, even if the original source
195 file never references the label. We don't want all kinds of
196 spurious warnings for old-style Fortran code with too many
197 labels. */
198 TREE_USED (label_decl) = 1;
6de9cd9a 199
c006df4e 200 DECL_ARTIFICIAL (label_decl) = 1;
6de9cd9a
DN		 201 return label_decl;
202}
203
204
205/* Returns the return label for the current function. */
206
207tree
208gfc_get_return_label (void)
209{
210 char name[GFC_MAX_SYMBOL_LEN + 10];
211
212 if (current_function_return_label)
213 return current_function_return_label;
214
215 sprintf (name, "__return_%s",
216 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
217
218 current_function_return_label =
219 gfc_build_label_decl (get_identifier (name));
220
221 DECL_ARTIFICIAL (current_function_return_label) = 1;
222
223 return current_function_return_label;
224}
225
226
c8cc8542
PB		 227/* Set the backend source location of a decl. */
228
229void
230gfc_set_decl_location (tree decl, locus * loc)
231{
232#ifdef USE_MAPPED_LOCATION
233 DECL_SOURCE_LOCATION (decl) = loc->lb->location;
234#else
235 DECL_SOURCE_LINE (decl) = loc->lb->linenum;
236 DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
237#endif
238}
239
240
6de9cd9a
DN		 241/* Return the backend label declaration for a given label structure,
242 or create it if it doesn't exist yet. */
243
244tree
245gfc_get_label_decl (gfc_st_label * lp)
246{
6de9cd9a
DN		 247 if (lp->backend_decl)
248 return lp->backend_decl;
249 else
250 {
251 char label_name[GFC_MAX_SYMBOL_LEN + 1];
252 tree label_decl;
253
254 /* Validate the label declaration from the front end. */
6e45f57b 255 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
6de9cd9a
DN		 256
257 /* Build a mangled name for the label. */
258 sprintf (label_name, "__label_%.6d", lp->value);
259
260 /* Build the LABEL_DECL node. */
261 label_decl = gfc_build_label_decl (get_identifier (label_name));
262
263 /* Tell the debugger where the label came from. */
f8d0aee5 264 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
c8cc8542 265 gfc_set_decl_location (label_decl, &lp->where);
6de9cd9a
DN		 266 else
267 DECL_ARTIFICIAL (label_decl) = 1;
268
269 /* Store the label in the label list and return the LABEL_DECL. */
270 lp->backend_decl = label_decl;
271 return label_decl;
272 }
273}
274
275
276/* Convert a gfc_symbol to an identifier of the same name. */
277
278static tree
279gfc_sym_identifier (gfc_symbol * sym)
280{
281 return (get_identifier (sym->name));
282}
283
284
285/* Construct mangled name from symbol name. */
286
287static tree
288gfc_sym_mangled_identifier (gfc_symbol * sym)
289{
290 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
291
cb9e4f55 292 if (sym->module == NULL)
6de9cd9a
DN		 293 return gfc_sym_identifier (sym);
294 else
295 {
296 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
297 return get_identifier (name);
298 }
299}
300
301
302/* Construct mangled function name from symbol name. */
303
304static tree
305gfc_sym_mangled_function_id (gfc_symbol * sym)
306{
307 int has_underscore;
308 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
309
cb9e4f55
TS		 310 if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
311 || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
6de9cd9a
DN		 312 {
313 if (strcmp (sym->name, "MAIN__") == 0
314 || sym->attr.proc == PROC_INTRINSIC)
315 return get_identifier (sym->name);
316
317 if (gfc_option.flag_underscoring)
318 {
319 has_underscore = strchr (sym->name, '_') != 0;
320 if (gfc_option.flag_second_underscore && has_underscore)
321 snprintf (name, sizeof name, "%s__", sym->name);
322 else
323 snprintf (name, sizeof name, "%s_", sym->name);
324 return get_identifier (name);
325 }
326 else
327 return get_identifier (sym->name);
328 }
329 else
330 {
331 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
332 return get_identifier (name);
333 }
334}
335
336
bae88af6
TS		 337/* Returns true if a variable of specified size should go on the stack. */
338
339int
340gfc_can_put_var_on_stack (tree size)
341{
342 unsigned HOST_WIDE_INT low;
343
344 if (!INTEGER_CST_P (size))
345 return 0;
346
347 if (gfc_option.flag_max_stack_var_size < 0)
348 return 1;
349
350 if (TREE_INT_CST_HIGH (size) != 0)
351 return 0;
352
353 low = TREE_INT_CST_LOW (size);
354 if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
355 return 0;
356
357/* TODO: Set a per-function stack size limit. */
358
359 return 1;
360}
361
362
b122dc6a
JJ		 363/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
364 an expression involving its corresponding pointer. There are
365 2 cases; one for variable size arrays, and one for everything else,
366 because variable-sized arrays require one fewer level of
367 indirection. */
368
369static void
370gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
371{
372 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
373 tree value;
374
375 /* Parameters need to be dereferenced. */
376 if (sym->cp_pointer->attr.dummy)
38611275 377 ptr_decl = build_fold_indirect_ref (ptr_decl);
b122dc6a
JJ		 378
379 /* Check to see if we're dealing with a variable-sized array. */
380 if (sym->attr.dimension
381 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
382 {
831d7813 383 /* These decls will be dereferenced later, so we don't dereference
b122dc6a
JJ		 384 them here. */
385 value = convert (TREE_TYPE (decl), ptr_decl);
386 }
387 else
388 {
389 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
390 ptr_decl);
38611275 391 value = build_fold_indirect_ref (ptr_decl);
b122dc6a
JJ		 392 }
393
394 SET_DECL_VALUE_EXPR (decl, value);
395 DECL_HAS_VALUE_EXPR_P (decl) = 1;
6c7a4dfd 396 GFC_DECL_CRAY_POINTEE (decl) = 1;
b122dc6a
JJ		 397 /* This is a fake variable just for debugging purposes. */
398 TREE_ASM_WRITTEN (decl) = 1;
399}
400
401
6de9cd9a
DN		 402/* Finish processing of a declaration and install its initial value. */
403
404static void
405gfc_finish_decl (tree decl, tree init)
406{
407 if (TREE_CODE (decl) == PARM_DECL)
6e45f57b 408 gcc_assert (init == NULL_TREE);
6de9cd9a
DN		 409 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
410 -- it overlaps DECL_ARG_TYPE. */
411 else if (init == NULL_TREE)
6e45f57b 412 gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
6de9cd9a 413 else
6e45f57b 414 gcc_assert (DECL_INITIAL (decl) == error_mark_node);
6de9cd9a
DN		 415
416 if (init != NULL_TREE)
417 {
418 if (TREE_CODE (decl) != TYPE_DECL)
419 DECL_INITIAL (decl) = init;
420 else
421 {
422 /* typedef foo = bar; store the type of bar as the type of foo. */
423 TREE_TYPE (decl) = TREE_TYPE (init);
424 DECL_INITIAL (decl) = init = 0;
425 }
426 }
427
428 if (TREE_CODE (decl) == VAR_DECL)
429 {
430 if (DECL_SIZE (decl) == NULL_TREE
431 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
432 layout_decl (decl, 0);
433
434 /* A static variable with an incomplete type is an error if it is
435 initialized. Also if it is not file scope. Otherwise, let it
436 through, but if it is not `extern' then it may cause an error
437 message later. */
438 /* An automatic variable with an incomplete type is an error. */
439 if (DECL_SIZE (decl) == NULL_TREE
440 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
441 || DECL_CONTEXT (decl) != 0)
442 : !DECL_EXTERNAL (decl)))
443 {
444 gfc_fatal_error ("storage size not known");
445 }
446
447 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
448 && (DECL_SIZE (decl) != 0)
449 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
450 {
451 gfc_fatal_error ("storage size not constant");
452 }
453 }
454
455}
456
457
458/* Apply symbol attributes to a variable, and add it to the function scope. */
459
460static void
461gfc_finish_var_decl (tree decl, gfc_symbol * sym)
462{
f8d0aee5 463 /* TREE_ADDRESSABLE means the address of this variable is actually needed.
6de9cd9a
DN		 464 This is the equivalent of the TARGET variables.
465 We also need to set this if the variable is passed by reference in a
466 CALL statement. */
83d890b9 467
b122dc6a 468 /* Set DECL_VALUE_EXPR for Cray Pointees. */
83d890b9 469 if (sym->attr.cray_pointee)
b122dc6a 470 gfc_finish_cray_pointee (decl, sym);
83d890b9 471
6de9cd9a
DN		 472 if (sym->attr.target)
473 TREE_ADDRESSABLE (decl) = 1;
474 /* If it wasn't used we wouldn't be getting it. */
475 TREE_USED (decl) = 1;
476
477 /* Chain this decl to the pending declarations. Don't do pushdecl()
478 because this would add them to the current scope rather than the
479 function scope. */
480 if (current_function_decl != NULL_TREE)
481 {
d48734ef
EE		 482 if (sym->ns->proc_name->backend_decl == current_function_decl
483 || sym->result == sym)
6de9cd9a
DN		 484 gfc_add_decl_to_function (decl);
485 else
486 gfc_add_decl_to_parent_function (decl);
487 }
488
b122dc6a
JJ		 489 if (sym->attr.cray_pointee)
490 return;
491
6de9cd9a
DN		 492 /* If a variable is USE associated, it's always external. */
493 if (sym->attr.use_assoc)
494 {
495 DECL_EXTERNAL (decl) = 1;
496 TREE_PUBLIC (decl) = 1;
497 }
cb9e4f55 498 else if (sym->module && !sym->attr.result && !sym->attr.dummy)
6de9cd9a 499 {
adf3ed3f 500 /* TODO: Don't set sym->module for result or dummy variables. */
d48734ef 501 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
6de9cd9a
DN		 502 /* This is the declaration of a module variable. */
503 TREE_PUBLIC (decl) = 1;
504 TREE_STATIC (decl) = 1;
505 }
506
507 if ((sym->attr.save || sym->attr.data || sym->value)
508 && !sym->attr.use_assoc)
509 TREE_STATIC (decl) = 1;
510
511 /* Keep variables larger than max-stack-var-size off stack. */
512 if (!sym->ns->proc_name->attr.recursive
513 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
514 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
515 TREE_STATIC (decl) = 1;
6c7a4dfd
JJ		 516
517 /* Handle threadprivate variables. */
518 if (sym->attr.threadprivate && targetm.have_tls
519 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
520 DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
6de9cd9a
DN		 521}
522
523
524/* Allocate the lang-specific part of a decl. */
525
526void
527gfc_allocate_lang_decl (tree decl)
528{
529 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
530 ggc_alloc_cleared (sizeof (struct lang_decl));
531}
532
533/* Remember a symbol to generate initialization/cleanup code at function
534 entry/exit. */
535
536static void
537gfc_defer_symbol_init (gfc_symbol * sym)
538{
539 gfc_symbol *p;
540 gfc_symbol *last;
541 gfc_symbol *head;
542
543 /* Don't add a symbol twice. */
544 if (sym->tlink)
545 return;
546
547 last = head = sym->ns->proc_name;
548 p = last->tlink;
549
550 /* Make sure that setup code for dummy variables which are used in the
551 setup of other variables is generated first. */
552 if (sym->attr.dummy)
553 {
554 /* Find the first dummy arg seen after us, or the first non-dummy arg.
555 This is a circular list, so don't go past the head. */
556 while (p != head
557 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
558 {
559 last = p;
560 p = p->tlink;
561 }
562 }
563 /* Insert in between last and p. */
564 last->tlink = sym;
565 sym->tlink = p;
566}
567
568
569/* Create an array index type variable with function scope. */
570
571static tree
572create_index_var (const char * pfx, int nest)
573{
574 tree decl;
575
576 decl = gfc_create_var_np (gfc_array_index_type, pfx);
577 if (nest)
578 gfc_add_decl_to_parent_function (decl);
579 else
580 gfc_add_decl_to_function (decl);
581 return decl;
582}
583
584
585/* Create variables to hold all the non-constant bits of info for a
586 descriptorless array. Remember these in the lang-specific part of the
587 type. */
588
589static void
590gfc_build_qualified_array (tree decl, gfc_symbol * sym)
591{
592 tree type;
593 int dim;
594 int nest;
595
596 type = TREE_TYPE (decl);
597
598 /* We just use the descriptor, if there is one. */
599 if (GFC_DESCRIPTOR_TYPE_P (type))
600 return;
601
6e45f57b 602 gcc_assert (GFC_ARRAY_TYPE_P (type));
6de9cd9a
DN		 603 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
604 && !sym->attr.contained;
605
606 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
607 {
608 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
609 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
aa9c57ec 610 /* Don't try to use the unknown bound for assumed shape arrays. */
6de9cd9a
DN		 611 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
612 && (sym->as->type != AS_ASSUMED_SIZE
613 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
614 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
615
616 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
617 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
618 }
619 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
620 {
621 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
622 "offset");
623 if (nest)
624 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
625 else
626 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
627 }
417ab240
JJ		 628
629 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
630 && sym->as->type != AS_ASSUMED_SIZE)
631 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
632
633 if (POINTER_TYPE_P (type))
634 {
635 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
636 gcc_assert (TYPE_LANG_SPECIFIC (type)
637 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
638 type = TREE_TYPE (type);
639 }
640
641 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
642 {
643 tree size, range;
644
645 size = build2 (MINUS_EXPR, gfc_array_index_type,
646 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
647 range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
648 size);
649 TYPE_DOMAIN (type) = range;
650 layout_type (type);
651 }
6de9cd9a
DN		 652}
653
654
655/* For some dummy arguments we don't use the actual argument directly.
bae88af6 656 Instead we create a local decl and use that. This allows us to perform
6de9cd9a
DN		 657 initialization, and construct full type information. */
658
659static tree
660gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
661{
662 tree decl;
663 tree type;
664 gfc_array_spec *as;
665 char *name;
666 int packed;
667 int n;
668 bool known_size;
669
670 if (sym->attr.pointer || sym->attr.allocatable)
671 return dummy;
672
673 /* Add to list of variables if not a fake result variable. */
674 if (sym->attr.result || sym->attr.dummy)
675 gfc_defer_symbol_init (sym);
676
677 type = TREE_TYPE (dummy);
6e45f57b 678 gcc_assert (TREE_CODE (dummy) == PARM_DECL
6de9cd9a
DN		 679 && POINTER_TYPE_P (type));
680
f8d0aee5 681 /* Do we know the element size? */
6de9cd9a
DN		 682 known_size = sym->ts.type != BT_CHARACTER
683 || INTEGER_CST_P (sym->ts.cl->backend_decl);
684
685 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
686 {
687 /* For descriptorless arrays with known element size the actual
688 argument is sufficient. */
6e45f57b 689 gcc_assert (GFC_ARRAY_TYPE_P (type));
6de9cd9a
DN		 690 gfc_build_qualified_array (dummy, sym);
691 return dummy;
692 }
693
694 type = TREE_TYPE (type);
695 if (GFC_DESCRIPTOR_TYPE_P (type))
696 {
697 /* Create a decriptorless array pointer. */
698 as = sym->as;
699 packed = 0;
700 if (!gfc_option.flag_repack_arrays)
701 {
702 if (as->type == AS_ASSUMED_SIZE)
703 packed = 2;
704 }
705 else
706 {
707 if (as->type == AS_EXPLICIT)
708 {
709 packed = 2;
710 for (n = 0; n < as->rank; n++)
711 {
712 if (!(as->upper[n]
713 && as->lower[n]
714 && as->upper[n]->expr_type == EXPR_CONSTANT
715 && as->lower[n]->expr_type == EXPR_CONSTANT))
716 packed = 1;
717 }
718 }
719 else
720 packed = 1;
721 }
722
723 type = gfc_typenode_for_spec (&sym->ts);
724 type = gfc_get_nodesc_array_type (type, sym->as, packed);
725 }
726 else
727 {
728 /* We now have an expression for the element size, so create a fully
729 qualified type. Reset sym->backend decl or this will just return the
730 old type. */
3e978d30 731 DECL_ARTIFICIAL (sym->backend_decl) = 1;
6de9cd9a
DN		 732 sym->backend_decl = NULL_TREE;
733 type = gfc_sym_type (sym);
734 packed = 2;
735 }
736
737 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
738 decl = build_decl (VAR_DECL, get_identifier (name), type);
739
740 DECL_ARTIFICIAL (decl) = 1;
741 TREE_PUBLIC (decl) = 0;
742 TREE_STATIC (decl) = 0;
743 DECL_EXTERNAL (decl) = 0;
744
745 /* We should never get deferred shape arrays here. We used to because of
746 frontend bugs. */
6e45f57b 747 gcc_assert (sym->as->type != AS_DEFERRED);
6de9cd9a
DN		 748
749 switch (packed)
750 {
751 case 1:
752 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
753 break;
754
755 case 2:
756 GFC_DECL_PACKED_ARRAY (decl) = 1;
757 break;
758 }
759
760 gfc_build_qualified_array (decl, sym);
761
762 if (DECL_LANG_SPECIFIC (dummy))
763 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
764 else
765 gfc_allocate_lang_decl (decl);
766
767 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
768
769 if (sym->ns->proc_name->backend_decl == current_function_decl
770 || sym->attr.contained)
771 gfc_add_decl_to_function (decl);
772 else
773 gfc_add_decl_to_parent_function (decl);
774
775 return decl;
776}
777
778
779/* Return a constant or a variable to use as a string length. Does not
780 add the decl to the current scope. */
781
782static tree
783gfc_create_string_length (gfc_symbol * sym)
784{
785 tree length;
786
6e45f57b 787 gcc_assert (sym->ts.cl);
6de9cd9a
DN		 788 gfc_conv_const_charlen (sym->ts.cl);
789
790 if (sym->ts.cl->backend_decl == NULL_TREE)
791 {
792 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
793
794 /* Also prefix the mangled name. */
795 strcpy (&name[1], sym->name);
796 name[0] = '.';
797 length = build_decl (VAR_DECL, get_identifier (name),
d7177ab2 798 gfc_charlen_type_node);
6de9cd9a
DN		 799 DECL_ARTIFICIAL (length) = 1;
800 TREE_USED (length) = 1;
417ab240
JJ		 801 if (sym->ns->proc_name->tlink != NULL)
802 gfc_defer_symbol_init (sym);
6de9cd9a
DN		 803 sym->ts.cl->backend_decl = length;
804 }
805
806 return sym->ts.cl->backend_decl;
807}
808
910450c1
FW		 809/* If a variable is assigned a label, we add another two auxiliary
810 variables. */
811
812static void
813gfc_add_assign_aux_vars (gfc_symbol * sym)
814{
815 tree addr;
816 tree length;
817 tree decl;
818
819 gcc_assert (sym->backend_decl);
820
821 decl = sym->backend_decl;
822 gfc_allocate_lang_decl (decl);
823 GFC_DECL_ASSIGN (decl) = 1;
824 length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
825 gfc_charlen_type_node);
826 addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
827 pvoid_type_node);
828 gfc_finish_var_decl (length, sym);
829 gfc_finish_var_decl (addr, sym);
830 /* STRING_LENGTH is also used as flag. Less than -1 means that
831 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
832 target label's address. Otherwise, value is the length of a format string
833 and ASSIGN_ADDR is its address. */
834 if (TREE_STATIC (length))
835 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
836 else
837 gfc_defer_symbol_init (sym);
838
839 GFC_DECL_STRING_LEN (decl) = length;
840 GFC_DECL_ASSIGN_ADDR (decl) = addr;
841}
6de9cd9a
DN		 842
843/* Return the decl for a gfc_symbol, create it if it doesn't already
844 exist. */
845
846tree
847gfc_get_symbol_decl (gfc_symbol * sym)
848{
849 tree decl;
850 tree length = NULL_TREE;
6de9cd9a
DN		 851 int byref;
852
61321991
PT		 853 gcc_assert (sym->attr.referenced
854 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
6de9cd9a
DN		 855
856 if (sym->ns && sym->ns->proc_name->attr.function)
857 byref = gfc_return_by_reference (sym->ns->proc_name);
858 else
859 byref = 0;
860
861 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
862 {
863 /* Return via extra parameter. */
864 if (sym->attr.result && byref
865 && !sym->backend_decl)
866 {
867 sym->backend_decl =
868 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
d198b59a
JJ		 869 /* For entry master function skip over the __entry
870 argument. */
871 if (sym->ns->proc_name->attr.entry_master)
872 sym->backend_decl = TREE_CHAIN (sym->backend_decl);
6de9cd9a
DN		 873 }
874
875 /* Dummy variables should already have been created. */
6e45f57b 876 gcc_assert (sym->backend_decl);
6de9cd9a
DN		 877
878 /* Create a character length variable. */
879 if (sym->ts.type == BT_CHARACTER)
880 {
881 if (sym->ts.cl->backend_decl == NULL_TREE)
417ab240
JJ		 882 length = gfc_create_string_length (sym);
883 else
884 length = sym->ts.cl->backend_decl;
885 if (TREE_CODE (length) == VAR_DECL
886 && DECL_CONTEXT (length) == NULL_TREE)
6de9cd9a 887 {
3e978d30
PT		 888 /* Add the string length to the same context as the symbol. */
889 if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
890 gfc_add_decl_to_function (length);
891 else
892 gfc_add_decl_to_parent_function (length);
893
894 gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
895 DECL_CONTEXT (length));
896
417ab240 897 gfc_defer_symbol_init (sym);
a41baa64 898 }
6de9cd9a
DN		 899 }
900
901 /* Use a copy of the descriptor for dummy arrays. */
902 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
903 {
3e978d30
PT		 904 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
905 /* Prevent the dummy from being detected as unused if it is copied. */
906 if (sym->backend_decl != NULL && decl != sym->backend_decl)
907 DECL_ARTIFICIAL (sym->backend_decl) = 1;
908 sym->backend_decl = decl;
6de9cd9a
DN		 909 }
910
911 TREE_USED (sym->backend_decl) = 1;
910450c1
FW		 912 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
913 {
914 gfc_add_assign_aux_vars (sym);
915 }
6de9cd9a
DN		 916 return sym->backend_decl;
917 }
918
919 if (sym->backend_decl)
920 return sym->backend_decl;
921
6de9cd9a
DN		 922 /* Catch function declarations. Only used for actual parameters. */
923 if (sym->attr.flavor == FL_PROCEDURE)
924 {
925 decl = gfc_get_extern_function_decl (sym);
926 return decl;
927 }
928
929 if (sym->attr.intrinsic)
930 internal_error ("intrinsic variable which isn't a procedure");
931
932 /* Create string length decl first so that they can be used in the
933 type declaration. */
934 if (sym->ts.type == BT_CHARACTER)
935 length = gfc_create_string_length (sym);
936
937 /* Create the decl for the variable. */
938 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
939
c8cc8542
PB		 940 gfc_set_decl_location (decl, &sym->declared_at);
941
f8d0aee5 942 /* Symbols from modules should have their assembler names mangled.
6de9cd9a
DN		 943 This is done here rather than in gfc_finish_var_decl because it
944 is different for string length variables. */
cb9e4f55 945 if (sym->module)
6de9cd9a
DN		 946 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
947
948 if (sym->attr.dimension)
949 {
950 /* Create variables to hold the non-constant bits of array info. */
951 gfc_build_qualified_array (decl, sym);
952
953 /* Remember this variable for allocation/cleanup. */
954 gfc_defer_symbol_init (sym);
955
956 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
957 GFC_DECL_PACKED_ARRAY (decl) = 1;
958 }
959
960 gfc_finish_var_decl (decl, sym);
961
597073ac 962 if (sym->ts.type == BT_CHARACTER)
6de9cd9a 963 {
6de9cd9a
DN		 964 /* Character variables need special handling. */
965 gfc_allocate_lang_decl (decl);
966
597073ac 967 if (TREE_CODE (length) != INTEGER_CST)
6de9cd9a
DN		 968 {
969 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
970
cb9e4f55 971 if (sym->module)
6de9cd9a
DN		 972 {
973 /* Also prefix the mangled name for symbols from modules. */
974 strcpy (&name[1], sym->name);
975 name[0] = '.';
976 strcpy (&name[1],
977 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
978 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
979 }
980 gfc_finish_var_decl (length, sym);
6e45f57b 981 gcc_assert (!sym->value);
6de9cd9a 982 }
6de9cd9a
DN		 983 }
984 sym->backend_decl = decl;
985
910450c1
FW		 986 if (sym->attr.assign)
987 {
988 gfc_add_assign_aux_vars (sym);
989 }
990
597073ac
PB		 991 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
992 {
993 /* Add static initializer. */
994 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
995 TREE_TYPE (decl), sym->attr.dimension,
996 sym->attr.pointer || sym->attr.allocatable);
997 }
998
6de9cd9a
DN		 999 return decl;
1000}
1001
1002
7b5b57b7
PB		 1003/* Substitute a temporary variable in place of the real one. */
1004
1005void
1006gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1007{
1008 save->attr = sym->attr;
1009 save->decl = sym->backend_decl;
1010
1011 gfc_clear_attr (&sym->attr);
1012 sym->attr.referenced = 1;
1013 sym->attr.flavor = FL_VARIABLE;
1014
1015 sym->backend_decl = decl;
1016}
1017
1018
1019/* Restore the original variable. */
1020
1021void
1022gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1023{
1024 sym->attr = save->attr;
1025 sym->backend_decl = save->decl;
1026}
1027
1028
6de9cd9a
DN		 1029/* Get a basic decl for an external function. */
1030
1031tree
1032gfc_get_extern_function_decl (gfc_symbol * sym)
1033{
1034 tree type;
1035 tree fndecl;
1036 gfc_expr e;
1037 gfc_intrinsic_sym *isym;
1038 gfc_expr argexpr;
973ff4c0 1039 char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'. */
6de9cd9a
DN		 1040 tree name;
1041 tree mangled_name;
1042
1043 if (sym->backend_decl)
1044 return sym->backend_decl;
1045
3d79abbd
PB		 1046 /* We should never be creating external decls for alternate entry points.
1047 The procedure may be an alternate entry point, but we don't want/need
1048 to know that. */
6e45f57b 1049 gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
3d79abbd 1050
6de9cd9a
DN		 1051 if (sym->attr.intrinsic)
1052 {
1053 /* Call the resolution function to get the actual name. This is
1054 a nasty hack which relies on the resolution functions only looking
1055 at the first argument. We pass NULL for the second argument
1056 otherwise things like AINT get confused. */
1057 isym = gfc_find_function (sym->name);
6e45f57b 1058 gcc_assert (isym->resolve.f0 != NULL);
6de9cd9a
DN		 1059
1060 memset (&e, 0, sizeof (e));
1061 e.expr_type = EXPR_FUNCTION;
1062
1063 memset (&argexpr, 0, sizeof (argexpr));
6e45f57b 1064 gcc_assert (isym->formal);
6de9cd9a
DN		 1065 argexpr.ts = isym->formal->ts;
1066
1067 if (isym->formal->next == NULL)
1068 isym->resolve.f1 (&e, &argexpr);
1069 else
1070 {
1071 /* All specific intrinsics take one or two arguments. */
6e45f57b 1072 gcc_assert (isym->formal->next->next == NULL);
6de9cd9a
DN		 1073 isym->resolve.f2 (&e, &argexpr, NULL);
1074 }
973ff4c0
TS		 1075
1076 if (gfc_option.flag_f2c
1077 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1078 || e.ts.type == BT_COMPLEX))
1079 {
1080 /* Specific which needs a different implementation if f2c
1081 calling conventions are used. */
1082 sprintf (s, "f2c_specific%s", e.value.function.name);
1083 }
1084 else
1085 sprintf (s, "specific%s", e.value.function.name);
1086
6de9cd9a
DN		 1087 name = get_identifier (s);
1088 mangled_name = name;
1089 }
1090 else
1091 {
1092 name = gfc_sym_identifier (sym);
1093 mangled_name = gfc_sym_mangled_function_id (sym);
1094 }
1095
1096 type = gfc_get_function_type (sym);
1097 fndecl = build_decl (FUNCTION_DECL, name, type);
1098
1099 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1100 /* If the return type is a pointer, avoid alias issues by setting
1101 DECL_IS_MALLOC to nonzero. This means that the function should be
1102 treated as if it were a malloc, meaning it returns a pointer that
1103 is not an alias. */
1104 if (POINTER_TYPE_P (type))
1105 DECL_IS_MALLOC (fndecl) = 1;
1106
1107 /* Set the context of this decl. */
1108 if (0 && sym->ns && sym->ns->proc_name)
1109 {
1110 /* TODO: Add external decls to the appropriate scope. */
1111 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1112 }
1113 else
1114 {
f8d0aee5 1115 /* Global declaration, e.g. intrinsic subroutine. */
6de9cd9a
DN		 1116 DECL_CONTEXT (fndecl) = NULL_TREE;
1117 }
1118
1119 DECL_EXTERNAL (fndecl) = 1;
1120
f8d0aee5 1121 /* This specifies if a function is globally addressable, i.e. it is
6de9cd9a
DN		 1122 the opposite of declaring static in C. */
1123 TREE_PUBLIC (fndecl) = 1;
1124
1125 /* Set attributes for PURE functions. A call to PURE function in the
1126 Fortran 95 sense is both pure and without side effects in the C
1127 sense. */
1128 if (sym->attr.pure || sym->attr.elemental)
1129 {
cf013e9f 1130 if (sym->attr.function && !gfc_return_by_reference (sym))
b7e6a6b3
TS		 1131 DECL_IS_PURE (fndecl) = 1;
1132 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1133 parameters and don't use alternate returns (is this
1134 allowed?). In that case, calls to them are meaningless, and
3d79abbd 1135 can be optimized away. See also in build_function_decl(). */
b7e6a6b3 1136 TREE_SIDE_EFFECTS (fndecl) = 0;
6de9cd9a
DN		 1137 }
1138
fe58e076
TK		 1139 /* Mark non-returning functions. */
1140 if (sym->attr.noreturn)
1141 TREE_THIS_VOLATILE(fndecl) = 1;
1142
6de9cd9a
DN		 1143 sym->backend_decl = fndecl;
1144
1145 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1146 pushdecl_top_level (fndecl);
1147
1148 return fndecl;
1149}
1150
1151
1152/* Create a declaration for a procedure. For external functions (in the C
3d79abbd
PB		 1153 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
1154 a master function with alternate entry points. */
6de9cd9a 1155
3d79abbd
PB		 1156static void
1157build_function_decl (gfc_symbol * sym)
6de9cd9a 1158{
3d79abbd 1159 tree fndecl, type;
6de9cd9a 1160 symbol_attribute attr;
3d79abbd 1161 tree result_decl;
6de9cd9a
DN		 1162 gfc_formal_arglist *f;
1163
6e45f57b
PB		 1164 gcc_assert (!sym->backend_decl);
1165 gcc_assert (!sym->attr.external);
6de9cd9a 1166
c8cc8542
PB		 1167 /* Set the line and filename. sym->declared_at seems to point to the
1168 last statement for subroutines, but it'll do for now. */
1169 gfc_set_backend_locus (&sym->declared_at);
1170
6de9cd9a 1171 /* Allow only one nesting level. Allow public declarations. */
6e45f57b 1172 gcc_assert (current_function_decl == NULL_TREE
6de9cd9a
DN		 1173 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1174
1175 type = gfc_get_function_type (sym);
1176 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1177
1178 /* Perform name mangling if this is a top level or module procedure. */
1179 if (current_function_decl == NULL_TREE)
1180 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1181
1182 /* Figure out the return type of the declared function, and build a
f8d0aee5 1183 RESULT_DECL for it. If this is a subroutine with alternate
6de9cd9a
DN		 1184 returns, build a RESULT_DECL for it. */
1185 attr = sym->attr;
1186
1187 result_decl = NULL_TREE;
1188 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1189 if (attr.function)
1190 {
1191 if (gfc_return_by_reference (sym))
1192 type = void_type_node;
1193 else
1194 {
1195 if (sym->result != sym)
1196 result_decl = gfc_sym_identifier (sym->result);
1197
1198 type = TREE_TYPE (TREE_TYPE (fndecl));
1199 }
1200 }
1201 else
1202 {
1203 /* Look for alternate return placeholders. */
1204 int has_alternate_returns = 0;
1205 for (f = sym->formal; f; f = f->next)
1206 {
1207 if (f->sym == NULL)
1208 {
1209 has_alternate_returns = 1;
1210 break;
1211 }
1212 }
1213
1214 if (has_alternate_returns)
1215 type = integer_type_node;
1216 else
1217 type = void_type_node;
1218 }
1219
1220 result_decl = build_decl (RESULT_DECL, result_decl, type);
b785f485
RH		 1221 DECL_ARTIFICIAL (result_decl) = 1;
1222 DECL_IGNORED_P (result_decl) = 1;
6de9cd9a
DN		 1223 DECL_CONTEXT (result_decl) = fndecl;
1224 DECL_RESULT (fndecl) = result_decl;
1225
1226 /* Don't call layout_decl for a RESULT_DECL.
f8d0aee5 1227 layout_decl (result_decl, 0); */
6de9cd9a
DN		 1228
1229 /* If the return type is a pointer, avoid alias issues by setting
1230 DECL_IS_MALLOC to nonzero. This means that the function should be
1231 treated as if it were a malloc, meaning it returns a pointer that
1232 is not an alias. */
1233 if (POINTER_TYPE_P (type))
1234 DECL_IS_MALLOC (fndecl) = 1;
1235
1236 /* Set up all attributes for the function. */
1237 DECL_CONTEXT (fndecl) = current_function_decl;
1238 DECL_EXTERNAL (fndecl) = 0;
1239
ae51017b 1240 /* This specifies if a function is globally visible, i.e. it is
472ca416 1241 the opposite of declaring static in C. */
3d79abbd
PB		 1242 if (DECL_CONTEXT (fndecl) == NULL_TREE
1243 && !sym->attr.entry_master)
6de9cd9a
DN		 1244 TREE_PUBLIC (fndecl) = 1;
1245
1246 /* TREE_STATIC means the function body is defined here. */
1d754240 1247 TREE_STATIC (fndecl) = 1;
6de9cd9a 1248
f8d0aee5 1249 /* Set attributes for PURE functions. A call to a PURE function in the
6de9cd9a
DN		 1250 Fortran 95 sense is both pure and without side effects in the C
1251 sense. */
1252 if (attr.pure || attr.elemental)
1253 {
b7e6a6b3
TS		 1254 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1255 including a alternate return. In that case it can also be
1f2959f0 1256 marked as PURE. See also in gfc_get_extern_function_decl(). */
a01db3bf 1257 if (attr.function && !gfc_return_by_reference (sym))
b7e6a6b3 1258 DECL_IS_PURE (fndecl) = 1;
6de9cd9a
DN		 1259 TREE_SIDE_EFFECTS (fndecl) = 0;
1260 }
1261
1262 /* Layout the function declaration and put it in the binding level
1263 of the current function. */
1d754240 1264 pushdecl (fndecl);
3d79abbd
PB		 1265
1266 sym->backend_decl = fndecl;
1267}
1268
1269
1270/* Create the DECL_ARGUMENTS for a procedure. */
1271
1272static void
1273create_function_arglist (gfc_symbol * sym)
1274{
1275 tree fndecl;
1276 gfc_formal_arglist *f;
417ab240
JJ		 1277 tree typelist, hidden_typelist;
1278 tree arglist, hidden_arglist;
3d79abbd
PB		 1279 tree type;
1280 tree parm;
1281
1282 fndecl = sym->backend_decl;
1283
1d754240
PB		 1284 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1285 the new FUNCTION_DECL node. */
1d754240 1286 arglist = NULL_TREE;
417ab240 1287 hidden_arglist = NULL_TREE;
1d754240 1288 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
3d79abbd
PB		 1289
1290 if (sym->attr.entry_master)
1291 {
1292 type = TREE_VALUE (typelist);
1293 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1294
1295 DECL_CONTEXT (parm) = fndecl;
1296 DECL_ARG_TYPE (parm) = type;
1297 TREE_READONLY (parm) = 1;
1298 gfc_finish_decl (parm, NULL_TREE);
3e978d30 1299 DECL_ARTIFICIAL (parm) = 1;
3d79abbd
PB		 1300
1301 arglist = chainon (arglist, parm);
1302 typelist = TREE_CHAIN (typelist);
1303 }
1304
1d754240 1305 if (gfc_return_by_reference (sym))
6de9cd9a 1306 {
417ab240 1307 tree type = TREE_VALUE (typelist), length = NULL;
6de9cd9a 1308
1d754240
PB		 1309 if (sym->ts.type == BT_CHARACTER)
1310 {
1d754240 1311 /* Length of character result. */
417ab240
JJ		 1312 tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1313 gcc_assert (len_type == gfc_charlen_type_node);
6de9cd9a 1314
1d754240
PB		 1315 length = build_decl (PARM_DECL,
1316 get_identifier (".__result"),
417ab240 1317 len_type);
1d754240
PB		 1318 if (!sym->ts.cl->length)
1319 {
1320 sym->ts.cl->backend_decl = length;
1321 TREE_USED (length) = 1;
6de9cd9a 1322 }
6e45f57b 1323 gcc_assert (TREE_CODE (length) == PARM_DECL);
1d754240 1324 DECL_CONTEXT (length) = fndecl;
417ab240 1325 DECL_ARG_TYPE (length) = len_type;
1d754240 1326 TREE_READONLY (length) = 1;
ca0e9281 1327 DECL_ARTIFICIAL (length) = 1;
1d754240 1328 gfc_finish_decl (length, NULL_TREE);
417ab240
JJ		 1329 if (sym->ts.cl->backend_decl == NULL
1330 || sym->ts.cl->backend_decl == length)
1331 {
1332 gfc_symbol *arg;
1333 tree backend_decl;
6de9cd9a 1334
417ab240
JJ		 1335 if (sym->ts.cl->backend_decl == NULL)
1336 {
1337 tree len = build_decl (VAR_DECL,
1338 get_identifier ("..__result"),
1339 gfc_charlen_type_node);
1340 DECL_ARTIFICIAL (len) = 1;
1341 TREE_USED (len) = 1;
1342 sym->ts.cl->backend_decl = len;
1343 }
6de9cd9a 1344
417ab240
JJ		 1345 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1346 arg = sym->result ? sym->result : sym;
1347 backend_decl = arg->backend_decl;
1348 /* Temporary clear it, so that gfc_sym_type creates complete
1349 type. */
1350 arg->backend_decl = NULL;
1351 type = gfc_sym_type (arg);
1352 arg->backend_decl = backend_decl;
1353 type = build_reference_type (type);
1354 }
1355 }
6de9cd9a 1356
417ab240 1357 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
6de9cd9a 1358
417ab240
JJ		 1359 DECL_CONTEXT (parm) = fndecl;
1360 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1361 TREE_READONLY (parm) = 1;
1362 DECL_ARTIFICIAL (parm) = 1;
1363 gfc_finish_decl (parm, NULL_TREE);
6de9cd9a 1364
417ab240
JJ		 1365 arglist = chainon (arglist, parm);
1366 typelist = TREE_CHAIN (typelist);
6de9cd9a 1367
417ab240
JJ		 1368 if (sym->ts.type == BT_CHARACTER)
1369 {
1370 gfc_allocate_lang_decl (parm);
1371 arglist = chainon (arglist, length);
1d754240
PB		 1372 typelist = TREE_CHAIN (typelist);
1373 }
1374 }
6de9cd9a 1375
417ab240
JJ		 1376 hidden_typelist = typelist;
1377 for (f = sym->formal; f; f = f->next)
1378 if (f->sym != NULL) /* Ignore alternate returns. */
1379 hidden_typelist = TREE_CHAIN (hidden_typelist);
1380
1d754240
PB		 1381 for (f = sym->formal; f; f = f->next)
1382 {
1383 char name[GFC_MAX_SYMBOL_LEN + 2];
417ab240 1384
1d754240
PB		 1385 /* Ignore alternate returns. */
1386 if (f->sym == NULL)
1387 continue;
6de9cd9a 1388
1d754240 1389 type = TREE_VALUE (typelist);
6de9cd9a 1390
417ab240
JJ		 1391 if (f->sym->ts.type == BT_CHARACTER)
1392 {
1393 tree len_type = TREE_VALUE (hidden_typelist);
1394 tree length = NULL_TREE;
1395 gcc_assert (len_type == gfc_charlen_type_node);
1396
1397 strcpy (&name[1], f->sym->name);
1398 name[0] = '_';
1399 length = build_decl (PARM_DECL, get_identifier (name), len_type);
6de9cd9a 1400
417ab240
JJ		 1401 hidden_arglist = chainon (hidden_arglist, length);
1402 DECL_CONTEXT (length) = fndecl;
1403 DECL_ARTIFICIAL (length) = 1;
1404 DECL_ARG_TYPE (length) = len_type;
1405 TREE_READONLY (length) = 1;
1406 gfc_finish_decl (length, NULL_TREE);
6de9cd9a 1407
417ab240 1408 /* TODO: Check string lengths when -fbounds-check. */
6de9cd9a 1409
417ab240
JJ		 1410 /* Use the passed value for assumed length variables. */
1411 if (!f->sym->ts.cl->length)
6de9cd9a 1412 {
417ab240
JJ		 1413 TREE_USED (length) = 1;
1414 if (!f->sym->ts.cl->backend_decl)
1415 f->sym->ts.cl->backend_decl = length;
1416 else
1417 {
1418 /* there is already another variable using this
1419 gfc_charlen node, build a new one for this variable
1420 and chain it into the list of gfc_charlens.
1421 This happens for e.g. in the case
1422 CHARACTER(*)::c1,c2
1423 since CHARACTER declarations on the same line share
1424 the same gfc_charlen node. */
1425 gfc_charlen *cl;
1d754240 1426
417ab240
JJ		 1427 cl = gfc_get_charlen ();
1428 cl->backend_decl = length;
1429 cl->next = f->sym->ts.cl->next;
1430 f->sym->ts.cl->next = cl;
1431 f->sym->ts.cl = cl;
1432 }
1433 }
1434
1435 hidden_typelist = TREE_CHAIN (hidden_typelist);
1436
1437 if (f->sym->ts.cl->backend_decl == NULL
1438 || f->sym->ts.cl->backend_decl == length)
1439 {
1440 if (f->sym->ts.cl->backend_decl == NULL)
1441 gfc_create_string_length (f->sym);
1442
1443 /* Make sure PARM_DECL type doesn't point to incomplete type. */
1444 if (f->sym->attr.flavor == FL_PROCEDURE)
1445 type = build_pointer_type (gfc_get_function_type (f->sym));
1446 else
1447 type = gfc_sym_type (f->sym);
6de9cd9a 1448 }
6de9cd9a
DN		 1449 }
1450
417ab240
JJ		 1451 /* For non-constant length array arguments, make sure they use
1452 a different type node from TYPE_ARG_TYPES type. */
1453 if (f->sym->attr.dimension
1454 && type == TREE_VALUE (typelist)
1455 && TREE_CODE (type) == POINTER_TYPE
1456 && GFC_ARRAY_TYPE_P (type)
1457 && f->sym->as->type != AS_ASSUMED_SIZE
1458 && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1459 {
1460 if (f->sym->attr.flavor == FL_PROCEDURE)
1461 type = build_pointer_type (gfc_get_function_type (f->sym));
1462 else
1463 type = gfc_sym_type (f->sym);
1464 }
1465
1466 /* Build a the argument declaration. */
1467 parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1468
1469 /* Fill in arg stuff. */
1470 DECL_CONTEXT (parm) = fndecl;
1471 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1472 /* All implementation args are read-only. */
1473 TREE_READONLY (parm) = 1;
1474
1475 gfc_finish_decl (parm, NULL_TREE);
1476
1477 f->sym->backend_decl = parm;
1478
1479 arglist = chainon (arglist, parm);
1d754240 1480 typelist = TREE_CHAIN (typelist);
6de9cd9a 1481 }
1d754240 1482
417ab240
JJ		 1483 /* Add the hidden string length parameters. */
1484 arglist = chainon (arglist, hidden_arglist);
1485
1486 gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
1d754240 1487 DECL_ARGUMENTS (fndecl) = arglist;
3d79abbd 1488}
1d754240 1489
3d79abbd
PB		 1490/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1491
1492static void
1493gfc_gimplify_function (tree fndecl)
1494{
1495 struct cgraph_node *cgn;
1496
1497 gimplify_function_tree (fndecl);
1498 dump_function (TDI_generic, fndecl);
1499
6c7a4dfd
JJ		 1500 /* Generate errors for structured block violations. */
1501 /* ??? Could be done as part of resolve_labels. */
1502 if (flag_openmp)
1503 diagnose_omp_structured_block_errors (fndecl);
1504
3d79abbd
PB		 1505 /* Convert all nested functions to GIMPLE now. We do things in this order
1506 so that items like VLA sizes are expanded properly in the context of the
1507 correct function. */
1508 cgn = cgraph_node (fndecl);
1509 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1510 gfc_gimplify_function (cgn->decl);
1511}
1512
1513
1514/* Do the setup necessary before generating the body of a function. */
1515
1516static void
1517trans_function_start (gfc_symbol * sym)
1518{
1519 tree fndecl;
1520
1521 fndecl = sym->backend_decl;
1522
f8d0aee5 1523 /* Let GCC know the current scope is this function. */
3d79abbd
PB		 1524 current_function_decl = fndecl;
1525
f8d0aee5 1526 /* Let the world know what we're about to do. */
3d79abbd
PB		 1527 announce_function (fndecl);
1528
1529 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1530 {
f8d0aee5 1531 /* Create RTL for function declaration. */
3d79abbd
PB		 1532 rest_of_decl_compilation (fndecl, 1, 0);
1533 }
1534
f8d0aee5 1535 /* Create RTL for function definition. */
3d79abbd
PB		 1536 make_decl_rtl (fndecl);
1537
3d79abbd
PB		 1538 init_function_start (fndecl);
1539
1540 /* Even though we're inside a function body, we still don't want to
1541 call expand_expr to calculate the size of a variable-sized array.
1542 We haven't necessarily assigned RTL to all variables yet, so it's
1543 not safe to try to expand expressions involving them. */
1544 cfun->x_dont_save_pending_sizes_p = 1;
1545
f8d0aee5 1546 /* function.c requires a push at the start of the function. */
3d79abbd
PB		 1547 pushlevel (0);
1548}
1549
1550/* Create thunks for alternate entry points. */
1551
1552static void
1553build_entry_thunks (gfc_namespace * ns)
1554{
1555 gfc_formal_arglist *formal;
1556 gfc_formal_arglist *thunk_formal;
1557 gfc_entry_list *el;
1558 gfc_symbol *thunk_sym;
1559 stmtblock_t body;
1560 tree thunk_fndecl;
1561 tree args;
1562 tree string_args;
1563 tree tmp;
c8cc8542 1564 locus old_loc;
3d79abbd
PB		 1565
1566 /* This should always be a toplevel function. */
6e45f57b 1567 gcc_assert (current_function_decl == NULL_TREE);
3d79abbd 1568
c8cc8542 1569 gfc_get_backend_locus (&old_loc);
3d79abbd
PB		 1570 for (el = ns->entries; el; el = el->next)
1571 {
1572 thunk_sym = el->sym;
1573
1574 build_function_decl (thunk_sym);
1575 create_function_arglist (thunk_sym);
1576
1577 trans_function_start (thunk_sym);
1578
1579 thunk_fndecl = thunk_sym->backend_decl;
1580
1581 gfc_start_block (&body);
1582
f8d0aee5 1583 /* Pass extra parameter identifying this entry point. */
7d60be94 1584 tmp = build_int_cst (gfc_array_index_type, el->id);
3d79abbd
PB		 1585 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1586 string_args = NULL_TREE;
1587
d198b59a
JJ		 1588 if (thunk_sym->attr.function)
1589 {
1590 if (gfc_return_by_reference (ns->proc_name))
1591 {
1592 tree ref = DECL_ARGUMENTS (current_function_decl);
1593 args = tree_cons (NULL_TREE, ref, args);
1594 if (ns->proc_name->ts.type == BT_CHARACTER)
1595 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1596 args);
1597 }
1598 }
1599
3d79abbd
PB		 1600 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1601 {
d198b59a
JJ		 1602 /* Ignore alternate returns. */
1603 if (formal->sym == NULL)
1604 continue;
1605
3d79abbd
PB		 1606 /* We don't have a clever way of identifying arguments, so resort to
1607 a brute-force search. */
1608 for (thunk_formal = thunk_sym->formal;
1609 thunk_formal;
1610 thunk_formal = thunk_formal->next)
1611 {
1612 if (thunk_formal->sym == formal->sym)
1613 break;
1614 }
1615
1616 if (thunk_formal)
1617 {
1618 /* Pass the argument. */
3e978d30 1619 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
3d79abbd
PB		 1620 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1621 args);
1622 if (formal->sym->ts.type == BT_CHARACTER)
1623 {
1624 tmp = thunk_formal->sym->ts.cl->backend_decl;
1625 string_args = tree_cons (NULL_TREE, tmp, string_args);
1626 }
1627 }
1628 else
1629 {
1630 /* Pass NULL for a missing argument. */
1631 args = tree_cons (NULL_TREE, null_pointer_node, args);
1632 if (formal->sym->ts.type == BT_CHARACTER)
1633 {
c3238e32 1634 tmp = build_int_cst (gfc_charlen_type_node, 0);
3d79abbd
PB		 1635 string_args = tree_cons (NULL_TREE, tmp, string_args);
1636 }
1637 }
1638 }
1639
1640 /* Call the master function. */
1641 args = nreverse (args);
1642 args = chainon (args, nreverse (string_args));
1643 tmp = ns->proc_name->backend_decl;
3380b802 1644 tmp = build_function_call_expr (tmp, args);
d198b59a
JJ		 1645 if (ns->proc_name->attr.mixed_entry_master)
1646 {
1647 tree union_decl, field;
1648 tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1649
1650 union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1651 TREE_TYPE (master_type));
1652 DECL_ARTIFICIAL (union_decl) = 1;
1653 DECL_EXTERNAL (union_decl) = 0;
1654 TREE_PUBLIC (union_decl) = 0;
1655 TREE_USED (union_decl) = 1;
1656 layout_decl (union_decl, 0);
1657 pushdecl (union_decl);
1658
1659 DECL_CONTEXT (union_decl) = current_function_decl;
1660 tmp = build2 (MODIFY_EXPR,
1661 TREE_TYPE (union_decl),
1662 union_decl, tmp);
1663 gfc_add_expr_to_block (&body, tmp);
1664
1665 for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1666 field; field = TREE_CHAIN (field))
1667 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1668 thunk_sym->result->name) == 0)
1669 break;
1670 gcc_assert (field != NULL_TREE);
1671 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1672 NULL_TREE);
1673 tmp = build2 (MODIFY_EXPR,
1674 TREE_TYPE (DECL_RESULT (current_function_decl)),
1675 DECL_RESULT (current_function_decl), tmp);
1676 tmp = build1_v (RETURN_EXPR, tmp);
1677 }
1678 else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1679 != void_type_node)
1680 {
1681 tmp = build2 (MODIFY_EXPR,
1682 TREE_TYPE (DECL_RESULT (current_function_decl)),
1683 DECL_RESULT (current_function_decl), tmp);
1684 tmp = build1_v (RETURN_EXPR, tmp);
1685 }
3d79abbd
PB		 1686 gfc_add_expr_to_block (&body, tmp);
1687
1688 /* Finish off this function and send it for code generation. */
1689 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1690 poplevel (1, 0, 1);
1691 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1692
1693 /* Output the GENERIC tree. */
1694 dump_function (TDI_original, thunk_fndecl);
1695
1696 /* Store the end of the function, so that we get good line number
1697 info for the epilogue. */
1698 cfun->function_end_locus = input_location;
1699
1700 /* We're leaving the context of this function, so zap cfun.
1701 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1702 tree_rest_of_compilation. */
1703 cfun = NULL;
1704
1705 current_function_decl = NULL_TREE;
1706
1707 gfc_gimplify_function (thunk_fndecl);
8f235343 1708 cgraph_finalize_function (thunk_fndecl, false);
3d79abbd
PB		 1709
1710 /* We share the symbols in the formal argument list with other entry
1711 points and the master function. Clear them so that they are
1712 recreated for each function. */
1713 for (formal = thunk_sym->formal; formal; formal = formal->next)
d198b59a
JJ		 1714 if (formal->sym != NULL) /* Ignore alternate returns. */
1715 {
1716 formal->sym->backend_decl = NULL_TREE;
1717 if (formal->sym->ts.type == BT_CHARACTER)
1718 formal->sym->ts.cl->backend_decl = NULL_TREE;
1719 }
1720
1721 if (thunk_sym->attr.function)
3d79abbd 1722 {
d198b59a
JJ		 1723 if (thunk_sym->ts.type == BT_CHARACTER)
1724 thunk_sym->ts.cl->backend_decl = NULL_TREE;
1725 if (thunk_sym->result->ts.type == BT_CHARACTER)
1726 thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
3d79abbd
PB		 1727 }
1728 }
c8cc8542
PB		 1729
1730 gfc_set_backend_locus (&old_loc);
3d79abbd
PB		 1731}
1732
1733
1734/* Create a decl for a function, and create any thunks for alternate entry
1735 points. */
1736
1737void
1738gfc_create_function_decl (gfc_namespace * ns)
1739{
1740 /* Create a declaration for the master function. */
1741 build_function_decl (ns->proc_name);
1742
f8d0aee5 1743 /* Compile the entry thunks. */
3d79abbd
PB		 1744 if (ns->entries)
1745 build_entry_thunks (ns);
1746
1747 /* Now create the read argument list. */
1748 create_function_arglist (ns->proc_name);
1749}
1750
5f20c93a
PT		 1751/* Return the decl used to hold the function return value. If
1752 parent_flag is set, the context is the parent_scope*/
6de9cd9a
DN		 1753
1754tree
5f20c93a 1755gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
6de9cd9a 1756{
5f20c93a
PT		 1757 tree decl;
1758 tree length;
1759 tree this_fake_result_decl;
1760 tree this_function_decl;
6de9cd9a
DN		 1761
1762 char name[GFC_MAX_SYMBOL_LEN + 10];
1763
5f20c93a
PT		 1764 if (parent_flag)
1765 {
1766 this_fake_result_decl = parent_fake_result_decl;
1767 this_function_decl = DECL_CONTEXT (current_function_decl);
1768 }
1769 else
1770 {
1771 this_fake_result_decl = current_fake_result_decl;
1772 this_function_decl = current_function_decl;
1773 }
1774
d198b59a 1775 if (sym
5f20c93a 1776 && sym->ns->proc_name->backend_decl == this_function_decl
417ab240 1777 && sym->ns->proc_name->attr.entry_master
d198b59a
JJ		 1778 && sym != sym->ns->proc_name)
1779 {
417ab240 1780 tree t = NULL, var;
5f20c93a
PT		 1781 if (this_fake_result_decl != NULL)
1782 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
417ab240
JJ		 1783 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1784 break;
1785 if (t)
1786 return TREE_VALUE (t);
5f20c93a
PT		 1787 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1788
1789 if (parent_flag)
1790 this_fake_result_decl = parent_fake_result_decl;
1791 else
1792 this_fake_result_decl = current_fake_result_decl;
1793
417ab240 1794 if (decl && sym->ns->proc_name->attr.mixed_entry_master)
d198b59a
JJ		 1795 {
1796 tree field;
1797
1798 for (field = TYPE_FIELDS (TREE_TYPE (decl));
1799 field; field = TREE_CHAIN (field))
1800 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1801 sym->name) == 0)
1802 break;
1803
1804 gcc_assert (field != NULL_TREE);
1805 decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1806 NULL_TREE);
1807 }
5f20c93a
PT		 1808
1809 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1810 if (parent_flag)
1811 gfc_add_decl_to_parent_function (var);
1812 else
1813 gfc_add_decl_to_function (var);
1814
417ab240
JJ		 1815 SET_DECL_VALUE_EXPR (var, decl);
1816 DECL_HAS_VALUE_EXPR_P (var) = 1;
4b8ae4db 1817 GFC_DECL_RESULT (var) = 1;
5f20c93a
PT		 1818
1819 TREE_CHAIN (this_fake_result_decl)
1820 = tree_cons (get_identifier (sym->name), var,
1821 TREE_CHAIN (this_fake_result_decl));
417ab240 1822 return var;
d198b59a
JJ		 1823 }
1824
5f20c93a
PT		 1825 if (this_fake_result_decl != NULL_TREE)
1826 return TREE_VALUE (this_fake_result_decl);
6de9cd9a
DN		 1827
1828 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1829 sym is NULL. */
1830 if (!sym)
1831 return NULL_TREE;
1832
417ab240 1833 if (sym->ts.type == BT_CHARACTER)
6de9cd9a 1834 {
417ab240
JJ		 1835 if (sym->ts.cl->backend_decl == NULL_TREE)
1836 length = gfc_create_string_length (sym);
1837 else
1838 length = sym->ts.cl->backend_decl;
1839 if (TREE_CODE (length) == VAR_DECL
1840 && DECL_CONTEXT (length) == NULL_TREE)
a7d6b765 1841 gfc_add_decl_to_function (length);
6de9cd9a
DN		 1842 }
1843
1844 if (gfc_return_by_reference (sym))
1845 {
5f20c93a 1846 decl = DECL_ARGUMENTS (this_function_decl);
d198b59a 1847
5f20c93a 1848 if (sym->ns->proc_name->backend_decl == this_function_decl
d198b59a
JJ		 1849 && sym->ns->proc_name->attr.entry_master)
1850 decl = TREE_CHAIN (decl);
6de9cd9a
DN		 1851
1852 TREE_USED (decl) = 1;
1853 if (sym->as)
1854 decl = gfc_build_dummy_array_decl (sym, decl);
1855 }
1856 else
1857 {
1858 sprintf (name, "__result_%.20s",
5f20c93a 1859 IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
6de9cd9a
DN		 1860
1861 decl = build_decl (VAR_DECL, get_identifier (name),
5f20c93a 1862 TREE_TYPE (TREE_TYPE (this_function_decl)));
6de9cd9a
DN		 1863
1864 DECL_ARTIFICIAL (decl) = 1;
1865 DECL_EXTERNAL (decl) = 0;
1866 TREE_PUBLIC (decl) = 0;
1867 TREE_USED (decl) = 1;
6c7a4dfd 1868 GFC_DECL_RESULT (decl) = 1;
6de9cd9a
DN		 1869
1870 layout_decl (decl, 0);
1871
5f20c93a
PT		 1872 if (parent_flag)
1873 gfc_add_decl_to_parent_function (decl);
1874 else
1875 gfc_add_decl_to_function (decl);
6de9cd9a
DN		 1876 }
1877
5f20c93a
PT		 1878 if (parent_flag)
1879 parent_fake_result_decl = build_tree_list (NULL, decl);
1880 else
1881 current_fake_result_decl = build_tree_list (NULL, decl);
6de9cd9a
DN		 1882
1883 return decl;
1884}
1885
1886
1887/* Builds a function decl. The remaining parameters are the types of the
1888 function arguments. Negative nargs indicates a varargs function. */
1889
1890tree
1891gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1892{
1893 tree arglist;
1894 tree argtype;
1895 tree fntype;
1896 tree fndecl;
1897 va_list p;
1898 int n;
1899
1900 /* Library functions must be declared with global scope. */
6e45f57b 1901 gcc_assert (current_function_decl == NULL_TREE);
6de9cd9a
DN		 1902
1903 va_start (p, nargs);
1904
1905
1906 /* Create a list of the argument types. */
1907 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1908 {
1909 argtype = va_arg (p, tree);
1910 arglist = gfc_chainon_list (arglist, argtype);
1911 }
1912
1913 if (nargs >= 0)
1914 {
1915 /* Terminate the list. */
1916 arglist = gfc_chainon_list (arglist, void_type_node);
1917 }
1918
1919 /* Build the function type and decl. */
1920 fntype = build_function_type (rettype, arglist);
1921 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1922
1923 /* Mark this decl as external. */
1924 DECL_EXTERNAL (fndecl) = 1;
1925 TREE_PUBLIC (fndecl) = 1;
1926
1927 va_end (p);
1928
1929 pushdecl (fndecl);
1930
0e6df31e 1931 rest_of_decl_compilation (fndecl, 1, 0);
6de9cd9a
DN		 1932
1933 return fndecl;
1934}
1935
1936static void
1937gfc_build_intrinsic_function_decls (void)
1938{
e2cad04b
RH		 1939 tree gfc_int4_type_node = gfc_get_int_type (4);
1940 tree gfc_int8_type_node = gfc_get_int_type (8);
644cb69f 1941 tree gfc_int16_type_node = gfc_get_int_type (16);
e2cad04b
RH		 1942 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1943 tree gfc_real4_type_node = gfc_get_real_type (4);
1944 tree gfc_real8_type_node = gfc_get_real_type (8);
644cb69f
FXC		 1945 tree gfc_real10_type_node = gfc_get_real_type (10);
1946 tree gfc_real16_type_node = gfc_get_real_type (16);
e2cad04b
RH		 1947 tree gfc_complex4_type_node = gfc_get_complex_type (4);
1948 tree gfc_complex8_type_node = gfc_get_complex_type (8);
644cb69f
FXC		 1949 tree gfc_complex10_type_node = gfc_get_complex_type (10);
1950 tree gfc_complex16_type_node = gfc_get_complex_type (16);
25fc05eb 1951 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
e2cad04b 1952
6de9cd9a 1953 /* String functions. */
6de9cd9a
DN		 1954 gfor_fndecl_compare_string =
1955 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1956 gfc_int4_type_node,
1957 4,
d7177ab2
TS		 1958 gfc_charlen_type_node, pchar_type_node,
1959 gfc_charlen_type_node, pchar_type_node);
6de9cd9a
DN		 1960
1961 gfor_fndecl_concat_string =
1962 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1963 void_type_node,
1964 6,
d7177ab2
TS		 1965 gfc_charlen_type_node, pchar_type_node,
1966 gfc_charlen_type_node, pchar_type_node,
1967 gfc_charlen_type_node, pchar_type_node);
6de9cd9a
DN		 1968
1969 gfor_fndecl_string_len_trim =
1970 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1971 gfc_int4_type_node,
d7177ab2 1972 2, gfc_charlen_type_node,
6de9cd9a
DN		 1973 pchar_type_node);
1974
1975 gfor_fndecl_string_index =
1976 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1977 gfc_int4_type_node,
d7177ab2
TS		 1978 5, gfc_charlen_type_node, pchar_type_node,
1979 gfc_charlen_type_node, pchar_type_node,
6de9cd9a
DN		 1980 gfc_logical4_type_node);
1981
1982 gfor_fndecl_string_scan =
1983 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1984 gfc_int4_type_node,
d7177ab2
TS		 1985 5, gfc_charlen_type_node, pchar_type_node,
1986 gfc_charlen_type_node, pchar_type_node,
6de9cd9a
DN		 1987 gfc_logical4_type_node);
1988
1989 gfor_fndecl_string_verify =
1990 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1991 gfc_int4_type_node,
d7177ab2
TS		 1992 5, gfc_charlen_type_node, pchar_type_node,
1993 gfc_charlen_type_node, pchar_type_node,
6de9cd9a
DN		 1994 gfc_logical4_type_node);
1995
1996 gfor_fndecl_string_trim =
1997 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1998 void_type_node,
1999 4,
d7177ab2 2000 build_pointer_type (gfc_charlen_type_node),
6de9cd9a 2001 ppvoid_type_node,
d7177ab2 2002 gfc_charlen_type_node,
6de9cd9a
DN		 2003 pchar_type_node);
2004
2005 gfor_fndecl_string_repeat =
2006 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
2007 void_type_node,
2008 4,
2009 pchar_type_node,
d7177ab2 2010 gfc_charlen_type_node,
6de9cd9a
DN		 2011 pchar_type_node,
2012 gfc_int4_type_node);
2013
25fc05eb
FXC		 2014 gfor_fndecl_ttynam =
2015 gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2016 void_type_node,
2017 3,
2018 pchar_type_node,
2019 gfc_charlen_type_node,
2020 gfc_c_int_type_node);
2021
35059811
FXC		 2022 gfor_fndecl_fdate =
2023 gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2024 void_type_node,
2025 2,
2026 pchar_type_node,
2027 gfc_charlen_type_node);
2028
2029 gfor_fndecl_ctime =
2030 gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2031 void_type_node,
2032 3,
2033 pchar_type_node,
2034 gfc_charlen_type_node,
2035 gfc_int8_type_node);
2036
6de9cd9a
DN		 2037 gfor_fndecl_adjustl =
2038 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2039 void_type_node,
2040 3,
2041 pchar_type_node,
d7177ab2 2042 gfc_charlen_type_node, pchar_type_node);
6de9cd9a
DN		 2043
2044 gfor_fndecl_adjustr =
2045 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2046 void_type_node,
2047 3,
2048 pchar_type_node,
d7177ab2 2049 gfc_charlen_type_node, pchar_type_node);
6de9cd9a
DN		 2050
2051 gfor_fndecl_si_kind =
2052 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
2053 gfc_int4_type_node,
2054 1,
2055 pvoid_type_node);
2056
2057 gfor_fndecl_sr_kind =
2058 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
2059 gfc_int4_type_node,
2060 2, pvoid_type_node,
2061 pvoid_type_node);
2062
6de9cd9a 2063 /* Power functions. */
5b200ac2 2064 {
644cb69f
FXC		 2065 tree ctype, rtype, itype, jtype;
2066 int rkind, ikind, jkind;
2067#define NIKINDS 3
2068#define NRKINDS 4
2069 static int ikinds[NIKINDS] = {4, 8, 16};
2070 static int rkinds[NRKINDS] = {4, 8, 10, 16};
2071 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2072
2073 for (ikind=0; ikind < NIKINDS; ikind++)
5b200ac2 2074 {
644cb69f
FXC		 2075 itype = gfc_get_int_type (ikinds[ikind]);
2076
2077 for (jkind=0; jkind < NIKINDS; jkind++)
2078 {
2079 jtype = gfc_get_int_type (ikinds[jkind]);
2080 if (itype && jtype)
2081 {
2082 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2083 ikinds[jkind]);
2084 gfor_fndecl_math_powi[jkind][ikind].integer =
2085 gfc_build_library_function_decl (get_identifier (name),
2086 jtype, 2, jtype, itype);
2087 }
2088 }
2089
2090 for (rkind = 0; rkind < NRKINDS; rkind ++)
5b200ac2 2091 {
644cb69f
FXC		 2092 rtype = gfc_get_real_type (rkinds[rkind]);
2093 if (rtype && itype)
2094 {
2095 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2096 ikinds[ikind]);
2097 gfor_fndecl_math_powi[rkind][ikind].real =
2098 gfc_build_library_function_decl (get_identifier (name),
2099 rtype, 2, rtype, itype);
2100 }
2101
2102 ctype = gfc_get_complex_type (rkinds[rkind]);
2103 if (ctype && itype)
2104 {
2105 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2106 ikinds[ikind]);
2107 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2108 gfc_build_library_function_decl (get_identifier (name),
2109 ctype, 2,ctype, itype);
2110 }
5b200ac2
FW		 2111 }
2112 }
644cb69f
FXC		 2113#undef NIKINDS
2114#undef NRKINDS
5b200ac2
FW		 2115 }
2116
6de9cd9a
DN		 2117 gfor_fndecl_math_cpowf =
2118 gfc_build_library_function_decl (get_identifier ("cpowf"),
2119 gfc_complex4_type_node,
2120 1, gfc_complex4_type_node);
2121 gfor_fndecl_math_cpow =
2122 gfc_build_library_function_decl (get_identifier ("cpow"),
2123 gfc_complex8_type_node,
2124 1, gfc_complex8_type_node);
644cb69f
FXC		 2125 if (gfc_complex10_type_node)
2126 gfor_fndecl_math_cpowl10 =
2127 gfc_build_library_function_decl (get_identifier ("cpowl"),
2128 gfc_complex10_type_node, 1,
2129 gfc_complex10_type_node);
2130 if (gfc_complex16_type_node)
2131 gfor_fndecl_math_cpowl16 =
2132 gfc_build_library_function_decl (get_identifier ("cpowl"),
2133 gfc_complex16_type_node, 1,
2134 gfc_complex16_type_node);
2135
6de9cd9a
DN		 2136 gfor_fndecl_math_ishftc4 =
2137 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2138 gfc_int4_type_node,
2139 3, gfc_int4_type_node,
2140 gfc_int4_type_node, gfc_int4_type_node);
2141 gfor_fndecl_math_ishftc8 =
2142 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2143 gfc_int8_type_node,
2144 3, gfc_int8_type_node,
644cb69f
FXC		 2145 gfc_int4_type_node, gfc_int4_type_node);
2146 if (gfc_int16_type_node)
2147 gfor_fndecl_math_ishftc16 =
2148 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2149 gfc_int16_type_node, 3,
2150 gfc_int16_type_node,
2151 gfc_int4_type_node,
2152 gfc_int4_type_node);
2153
6de9cd9a
DN		 2154 gfor_fndecl_math_exponent4 =
2155 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2156 gfc_int4_type_node,
2157 1, gfc_real4_type_node);
2158 gfor_fndecl_math_exponent8 =
2159 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2160 gfc_int4_type_node,
2161 1, gfc_real8_type_node);
644cb69f
FXC		 2162 if (gfc_real10_type_node)
2163 gfor_fndecl_math_exponent10 =
2164 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2165 gfc_int4_type_node, 1,
2166 gfc_real10_type_node);
2167 if (gfc_real16_type_node)
2168 gfor_fndecl_math_exponent16 =
2169 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2170 gfc_int4_type_node, 1,
2171 gfc_real16_type_node);
6de9cd9a
DN		 2172
2173 /* Other functions. */
2174 gfor_fndecl_size0 =
2175 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2176 gfc_array_index_type,
2177 1, pvoid_type_node);
2178 gfor_fndecl_size1 =
2179 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2180 gfc_array_index_type,
2181 2, pvoid_type_node,
2182 gfc_array_index_type);
b41b2534
JB		 2183
2184 gfor_fndecl_iargc =
2185 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2186 gfc_int4_type_node,
2187 0);
6de9cd9a
DN		 2188}
2189
2190
2191/* Make prototypes for runtime library functions. */
2192
2193void
2194gfc_build_builtin_function_decls (void)
2195{
944b8b35 2196 tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
e2cad04b
RH		 2197 tree gfc_int4_type_node = gfc_get_int_type (4);
2198 tree gfc_int8_type_node = gfc_get_int_type (8);
2199 tree gfc_logical4_type_node = gfc_get_logical_type (4);
364667a1 2200 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
e2cad04b 2201
16275f18 2202 /* Treat these two internal malloc wrappers as malloc. */
6de9cd9a
DN		 2203 gfor_fndecl_internal_malloc =
2204 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
2205 pvoid_type_node, 1, gfc_int4_type_node);
16275f18 2206 DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
6de9cd9a
DN		 2207
2208 gfor_fndecl_internal_malloc64 =
2209 gfc_build_library_function_decl (get_identifier
2210 (PREFIX("internal_malloc64")),
2211 pvoid_type_node, 1, gfc_int8_type_node);
16275f18 2212 DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
6de9cd9a 2213
ec25720b
RS		 2214 gfor_fndecl_internal_realloc =
2215 gfc_build_library_function_decl (get_identifier
2216 (PREFIX("internal_realloc")),
2217 pvoid_type_node, 2, pvoid_type_node,
2218 gfc_int4_type_node);
2219
2220 gfor_fndecl_internal_realloc64 =
2221 gfc_build_library_function_decl (get_identifier
2222 (PREFIX("internal_realloc64")),
2223 pvoid_type_node, 2, pvoid_type_node,
2224 gfc_int8_type_node);
2225
6de9cd9a
DN		 2226 gfor_fndecl_internal_free =
2227 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
2228 void_type_node, 1, pvoid_type_node);
2229
2230 gfor_fndecl_allocate =
2231 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
2232 void_type_node, 2, ppvoid_type_node,
2233 gfc_int4_type_node);
2234
2235 gfor_fndecl_allocate64 =
2236 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
2237 void_type_node, 2, ppvoid_type_node,
2238 gfc_int8_type_node);
2239
5b725b8d
TK		 2240 gfor_fndecl_allocate_array =
2241 gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
2242 void_type_node, 2, ppvoid_type_node,
2243 gfc_int4_type_node);
2244
2245 gfor_fndecl_allocate64_array =
2246 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64_array")),
2247 void_type_node, 2, ppvoid_type_node,
2248 gfc_int8_type_node);
2249
6de9cd9a
DN		 2250 gfor_fndecl_deallocate =
2251 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
364667a1
SK		 2252 void_type_node, 2, ppvoid_type_node,
2253 gfc_pint4_type_node);
6de9cd9a
DN		 2254
2255 gfor_fndecl_stop_numeric =
2256 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2257 void_type_node, 1, gfc_int4_type_node);
2258
eed61baa
TK		 2259 /* Stop doesn't return. */
2260 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2261
6de9cd9a
DN		 2262 gfor_fndecl_stop_string =
2263 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2264 void_type_node, 2, pchar_type_node,
2265 gfc_int4_type_node);
eed61baa
TK		 2266 /* Stop doesn't return. */
2267 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
6de9cd9a
DN		 2268
2269 gfor_fndecl_pause_numeric =
2270 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2271 void_type_node, 1, gfc_int4_type_node);
2272
2273 gfor_fndecl_pause_string =
2274 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2275 void_type_node, 2, pchar_type_node,
2276 gfc_int4_type_node);
2277
2278 gfor_fndecl_select_string =
2279 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2280 pvoid_type_node, 0);
2281
2282 gfor_fndecl_runtime_error =
2283 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
dd18a33b 2284 void_type_node, 1, pchar_type_node);
16275f18
SB		 2285 /* The runtime_error function does not return. */
2286 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
6de9cd9a 2287
944b8b35
FXC		 2288 gfor_fndecl_set_fpe =
2289 gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2290 void_type_node, 1, gfc_c_int_type_node);
2291
8b67b708
FXC		 2292 gfor_fndecl_set_std =
2293 gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
2294 void_type_node,
5f8f5313
FXC		 2295 3,
2296 gfc_int4_type_node,
8b67b708
FXC		 2297 gfc_int4_type_node,
2298 gfc_int4_type_node);
2299
eaa90d25
TK		 2300 gfor_fndecl_set_convert =
2301 gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2302 void_type_node, 1, gfc_c_int_type_node);
2303
d67ab5ee
TK		 2304 gfor_fndecl_set_record_marker =
2305 gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2306 void_type_node, 1, gfc_c_int_type_node);
2307
6de9cd9a
DN		 2308 gfor_fndecl_in_pack = gfc_build_library_function_decl (
2309 get_identifier (PREFIX("internal_pack")),
2310 pvoid_type_node, 1, pvoid_type_node);
2311
2312 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2313 get_identifier (PREFIX("internal_unpack")),
2314 pvoid_type_node, 1, pvoid_type_node);
2315
2316 gfor_fndecl_associated =
2317 gfc_build_library_function_decl (
2318 get_identifier (PREFIX("associated")),
2319 gfc_logical4_type_node,
2320 2,
2321 ppvoid_type_node,
2322 ppvoid_type_node);
2323
2324 gfc_build_intrinsic_function_decls ();
2325 gfc_build_intrinsic_lib_fndecls ();
2326 gfc_build_io_library_fndecls ();
2327}
2328
2329
1f2959f0 2330/* Evaluate the length of dummy character variables. */
6de9cd9a
DN		 2331
2332static tree
417ab240 2333gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
6de9cd9a
DN		 2334{
2335 stmtblock_t body;
2336
2337 gfc_finish_decl (cl->backend_decl, NULL_TREE);
2338
2339 gfc_start_block (&body);
2340
2341 /* Evaluate the string length expression. */
2342 gfc_trans_init_string_length (cl, &body);
417ab240
JJ		 2343
2344 gfc_trans_vla_type_sizes (sym, &body);
2345
6de9cd9a
DN		 2346 gfc_add_expr_to_block (&body, fnbody);
2347 return gfc_finish_block (&body);
2348}
2349
2350
2351/* Allocate and cleanup an automatic character variable. */
2352
2353static tree
2354gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2355{
2356 stmtblock_t body;
2357 tree decl;
6de9cd9a
DN		 2358 tree tmp;
2359
6e45f57b
PB		 2360 gcc_assert (sym->backend_decl);
2361 gcc_assert (sym->ts.cl && sym->ts.cl->length);
6de9cd9a
DN		 2362
2363 gfc_start_block (&body);
2364
2365 /* Evaluate the string length expression. */
2366 gfc_trans_init_string_length (sym->ts.cl, &body);
2367
417ab240
JJ		 2368 gfc_trans_vla_type_sizes (sym, &body);
2369
6de9cd9a
DN		 2370 decl = sym->backend_decl;
2371
1a186ec5 2372 /* Emit a DECL_EXPR for this variable, which will cause the
4ab2db93 2373 gimplifier to allocate storage, and all that good stuff. */
923ab88c 2374 tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
6de9cd9a 2375 gfc_add_expr_to_block (&body, tmp);
1a186ec5 2376
6de9cd9a
DN		 2377 gfc_add_expr_to_block (&body, fnbody);
2378 return gfc_finish_block (&body);
2379}
2380
910450c1
FW		 2381/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
2382
2383static tree
2384gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2385{
2386 stmtblock_t body;
2387
2388 gcc_assert (sym->backend_decl);
2389 gfc_start_block (&body);
2390
2391 /* Set the initial value to length. See the comments in
2392 function gfc_add_assign_aux_vars in this file. */
2393 gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2394 build_int_cst (NULL_TREE, -2));
2395
2396 gfc_add_expr_to_block (&body, fnbody);
2397 return gfc_finish_block (&body);
2398}
2399
417ab240
JJ		 2400static void
2401gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2402{
2403 tree t = *tp, var, val;
2404
2405 if (t == NULL || t == error_mark_node)
2406 return;
2407 if (TREE_CONSTANT (t) || DECL_P (t))
2408 return;
2409
2410 if (TREE_CODE (t) == SAVE_EXPR)
2411 {
2412 if (SAVE_EXPR_RESOLVED_P (t))
2413 {
2414 *tp = TREE_OPERAND (t, 0);
2415 return;
2416 }
2417 val = TREE_OPERAND (t, 0);
2418 }
2419 else
2420 val = t;
2421
2422 var = gfc_create_var_np (TREE_TYPE (t), NULL);
2423 gfc_add_decl_to_function (var);
2424 gfc_add_modify_expr (body, var, val);
2425 if (TREE_CODE (t) == SAVE_EXPR)
2426 TREE_OPERAND (t, 0) = var;
2427 *tp = var;
2428}
2429
2430static void
2431gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2432{
2433 tree t;
2434
2435 if (type == NULL || type == error_mark_node)
2436 return;
2437
2438 type = TYPE_MAIN_VARIANT (type);
2439
2440 if (TREE_CODE (type) == INTEGER_TYPE)
2441 {
2442 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2443 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2444
2445 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2446 {
2447 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2448 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2449 }
2450 }
2451 else if (TREE_CODE (type) == ARRAY_TYPE)
2452 {
2453 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2454 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2455 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2456 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2457
2458 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2459 {
2460 TYPE_SIZE (t) = TYPE_SIZE (type);
2461 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2462 }
2463 }
2464}
2465
2466/* Make sure all type sizes and array domains are either constant,
2467 or variable or parameter decls. This is a simplified variant
2468 of gimplify_type_sizes, but we can't use it here, as none of the
2469 variables in the expressions have been gimplified yet.
2470 As type sizes and domains for various variable length arrays
2471 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2472 time, without this routine gimplify_type_sizes in the middle-end
2473 could result in the type sizes being gimplified earlier than where
2474 those variables are initialized. */
2475
2476void
2477gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2478{
2479 tree type = TREE_TYPE (sym->backend_decl);
2480
2481 if (TREE_CODE (type) == FUNCTION_TYPE
2482 && (sym->attr.function || sym->attr.result || sym->attr.entry))
2483 {
2484 if (! current_fake_result_decl)
2485 return;
2486
2487 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2488 }
2489
2490 while (POINTER_TYPE_P (type))
2491 type = TREE_TYPE (type);
2492
2493 if (GFC_DESCRIPTOR_TYPE_P (type))
2494 {
2495 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2496
2497 while (POINTER_TYPE_P (etype))
2498 etype = TREE_TYPE (etype);
2499
2500 gfc_trans_vla_type_sizes_1 (etype, body);
2501 }
2502
2503 gfc_trans_vla_type_sizes_1 (type, body);
2504}
2505
6de9cd9a
DN		 2506
2507/* Generate function entry and exit code, and add it to the function body.
2508 This includes:
f8d0aee5 2509 Allocation and initialization of array variables.
6de9cd9a 2510 Allocation of character string variables.
910450c1
FW		 2511 Initialization and possibly repacking of dummy arrays.
2512 Initialization of ASSIGN statement auxiliary variable. */
6de9cd9a
DN		 2513
2514static tree
2515gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2516{
2517 locus loc;
2518 gfc_symbol *sym;
417ab240
JJ		 2519 gfc_formal_arglist *f;
2520 stmtblock_t body;
6de9cd9a
DN		 2521
2522 /* Deal with implicit return variables. Explicit return variables will
2523 already have been added. */
2524 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2525 {
2526 if (!current_fake_result_decl)
2527 {
d198b59a
JJ		 2528 gfc_entry_list *el = NULL;
2529 if (proc_sym->attr.entry_master)
2530 {
2531 for (el = proc_sym->ns->entries; el; el = el->next)
2532 if (el->sym != el->sym->result)
2533 break;
2534 }
2535 if (el == NULL)
2536 warning (0, "Function does not return a value");
6de9cd9a 2537 }
d198b59a 2538 else if (proc_sym->as)
6de9cd9a 2539 {
417ab240
JJ		 2540 tree result = TREE_VALUE (current_fake_result_decl);
2541 fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
f5f701ad
PT		 2542
2543 /* An automatic character length, pointer array result. */
2544 if (proc_sym->ts.type == BT_CHARACTER
2545 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2546 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2547 fnbody);
6de9cd9a
DN		 2548 }
2549 else if (proc_sym->ts.type == BT_CHARACTER)
2550 {
2551 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
417ab240
JJ		 2552 fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2553 fnbody);
6de9cd9a
DN		 2554 }
2555 else
973ff4c0
TS		 2556 gcc_assert (gfc_option.flag_f2c
2557 && proc_sym->ts.type == BT_COMPLEX);
6de9cd9a
DN		 2558 }
2559
2560 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2561 {
2562 if (sym->attr.dimension)
2563 {
2564 switch (sym->as->type)
2565 {
2566 case AS_EXPLICIT:
2567 if (sym->attr.dummy || sym->attr.result)
2568 fnbody =
2569 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2570 else if (sym->attr.pointer || sym->attr.allocatable)
2571 {
2572 if (TREE_STATIC (sym->backend_decl))
2573 gfc_trans_static_array_pointer (sym);
2574 else
2575 fnbody = gfc_trans_deferred_array (sym, fnbody);
2576 }
2577 else
2578 {
2579 gfc_get_backend_locus (&loc);
2580 gfc_set_backend_locus (&sym->declared_at);
2581 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2582 sym, fnbody);
2583 gfc_set_backend_locus (&loc);
2584 }
2585 break;
2586
2587 case AS_ASSUMED_SIZE:
2588 /* Must be a dummy parameter. */
6e45f57b 2589 gcc_assert (sym->attr.dummy);
6de9cd9a
DN		 2590
2591 /* We should always pass assumed size arrays the g77 way. */
6de9cd9a
DN		 2592 fnbody = gfc_trans_g77_array (sym, fnbody);
2593 break;
2594
2595 case AS_ASSUMED_SHAPE:
2596 /* Must be a dummy parameter. */
6e45f57b 2597 gcc_assert (sym->attr.dummy);
6de9cd9a
DN		 2598
2599 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2600 fnbody);
2601 break;
2602
2603 case AS_DEFERRED:
2604 fnbody = gfc_trans_deferred_array (sym, fnbody);
2605 break;
2606
2607 default:
6e45f57b 2608 gcc_unreachable ();
6de9cd9a
DN		 2609 }
2610 }
2611 else if (sym->ts.type == BT_CHARACTER)
2612 {
2613 gfc_get_backend_locus (&loc);
2614 gfc_set_backend_locus (&sym->declared_at);
2615 if (sym->attr.dummy || sym->attr.result)
417ab240 2616 fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
6de9cd9a
DN		 2617 else
2618 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2619 gfc_set_backend_locus (&loc);
2620 }
910450c1
FW		 2621 else if (sym->attr.assign)
2622 {
2623 gfc_get_backend_locus (&loc);
2624 gfc_set_backend_locus (&sym->declared_at);
2625 fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2626 gfc_set_backend_locus (&loc);
2627 }
6de9cd9a 2628 else
6e45f57b 2629 gcc_unreachable ();
6de9cd9a
DN		 2630 }
2631
417ab240
JJ		 2632 gfc_init_block (&body);
2633
2634 for (f = proc_sym->formal; f; f = f->next)
2635 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2636 {
2637 gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2638 if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2639 gfc_trans_vla_type_sizes (f->sym, &body);
2640 }
2641
2642 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2643 && current_fake_result_decl != NULL)
2644 {
2645 gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2646 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2647 gfc_trans_vla_type_sizes (proc_sym, &body);
2648 }
2649
2650 gfc_add_expr_to_block (&body, fnbody);
2651 return gfc_finish_block (&body);
6de9cd9a
DN		 2652}
2653
2654
2655/* Output an initialized decl for a module variable. */
2656
2657static void
2658gfc_create_module_variable (gfc_symbol * sym)
2659{
2660 tree decl;
6de9cd9a 2661
1a492601
PT		 2662 /* Module functions with alternate entries are dealt with later and
2663 would get caught by the next condition. */
2664 if (sym->attr.entry)
2665 return;
2666
6de9cd9a
DN		 2667 /* Only output symbols from this module. */
2668 if (sym->ns != module_namespace)
2669 {
2670 /* I don't think this should ever happen. */
2671 internal_error ("module symbol %s in wrong namespace", sym->name);
2672 }
2673
e7dc5b4f 2674 /* Only output variables and array valued parameters. */
6de9cd9a
DN		 2675 if (sym->attr.flavor != FL_VARIABLE
2676 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2677 return;
2678
9cbf8b41
TS		 2679 /* Don't generate variables from other modules. Variables from
2680 COMMONs will already have been generated. */
2681 if (sym->attr.use_assoc || sym->attr.in_common)
6de9cd9a
DN		 2682 return;
2683
30aabb86 2684 /* Equivalenced variables arrive here after creation. */
b95605fb
PT		 2685 if (sym->backend_decl
2686 && (sym->equiv_built || sym->attr.in_equivalence))
30aabb86
PT		 2687 return;
2688
6de9cd9a
DN		 2689 if (sym->backend_decl)
2690 internal_error ("backend decl for module variable %s already exists",
2691 sym->name);
2692
2693 /* We always want module variables to be created. */
2694 sym->attr.referenced = 1;
2695 /* Create the decl. */
2696 decl = gfc_get_symbol_decl (sym);
2697
6de9cd9a
DN		 2698 /* Create the variable. */
2699 pushdecl (decl);
0e6df31e 2700 rest_of_decl_compilation (decl, 1, 0);
6de9cd9a
DN		 2701
2702 /* Also add length of strings. */
2703 if (sym->ts.type == BT_CHARACTER)
2704 {
2705 tree length;
2706
2707 length = sym->ts.cl->backend_decl;
2708 if (!INTEGER_CST_P (length))
2709 {
2710 pushdecl (length);
0e6df31e 2711 rest_of_decl_compilation (length, 1, 0);
6de9cd9a
DN		 2712 }
2713 }
2714}
2715
2716
2717/* Generate all the required code for module variables. */
2718
2719void
2720gfc_generate_module_vars (gfc_namespace * ns)
2721{
2722 module_namespace = ns;
2723
472ca416 2724 /* Check if the frontend left the namespace in a reasonable state. */
6e45f57b 2725 gcc_assert (ns->proc_name && !ns->proc_name->tlink);
6de9cd9a 2726
9cbf8b41
TS		 2727 /* Generate COMMON blocks. */
2728 gfc_trans_common (ns);
2729
472ca416 2730 /* Create decls for all the module variables. */
6de9cd9a
DN		 2731 gfc_traverse_ns (ns, gfc_create_module_variable);
2732}
2733
2734static void
2735gfc_generate_contained_functions (gfc_namespace * parent)
2736{
2737 gfc_namespace *ns;
2738
2739 /* We create all the prototypes before generating any code. */
2740 for (ns = parent->contained; ns; ns = ns->sibling)
2741 {
2742 /* Skip namespaces from used modules. */
2743 if (ns->parent != parent)
2744 continue;
2745
3d79abbd 2746 gfc_create_function_decl (ns);
6de9cd9a
DN		 2747 }
2748
2749 for (ns = parent->contained; ns; ns = ns->sibling)
2750 {
2751 /* Skip namespaces from used modules. */
2752 if (ns->parent != parent)
2753 continue;
2754
2755 gfc_generate_function_code (ns);
2756 }
2757}
2758
2759
3e978d30
PT		 2760/* Drill down through expressions for the array specification bounds and
2761 character length calling generate_local_decl for all those variables
2762 that have not already been declared. */
2763
2764static void
2765generate_local_decl (gfc_symbol *);
2766
2767static void
2768generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
2769{
2770 gfc_actual_arglist *arg;
2771 gfc_ref *ref;
2772 int i;
2773
2774 if (e == NULL)
2775 return;
2776
2777 switch (e->expr_type)
2778 {
2779 case EXPR_FUNCTION:
2780 for (arg = e->value.function.actual; arg; arg = arg->next)
2781 generate_expr_decls (sym, arg->expr);
2782 break;
2783
2784 /* If the variable is not the same as the dependent, 'sym', and
2785 it is not marked as being declared and it is in the same
2786 namespace as 'sym', add it to the local declarations. */
2787 case EXPR_VARIABLE:
2788 if (sym == e->symtree->n.sym
2789 || e->symtree->n.sym->mark
2790 || e->symtree->n.sym->ns != sym->ns)
2791 return;
2792
2793 generate_local_decl (e->symtree->n.sym);
2794 break;
2795
2796 case EXPR_OP:
2797 generate_expr_decls (sym, e->value.op.op1);
2798 generate_expr_decls (sym, e->value.op.op2);
2799 break;
2800
2801 default:
2802 break;
2803 }
2804
2805 if (e->ref)
2806 {
2807 for (ref = e->ref; ref; ref = ref->next)
2808 {
2809 switch (ref->type)
2810 {
2811 case REF_ARRAY:
2812 for (i = 0; i < ref->u.ar.dimen; i++)
2813 {
2814 generate_expr_decls (sym, ref->u.ar.start[i]);
2815 generate_expr_decls (sym, ref->u.ar.end[i]);
2816 generate_expr_decls (sym, ref->u.ar.stride[i]);
2817 }
2818 break;
2819
2820 case REF_SUBSTRING:
2821 generate_expr_decls (sym, ref->u.ss.start);
2822 generate_expr_decls (sym, ref->u.ss.end);
2823 break;
2824
2825 case REF_COMPONENT:
2826 if (ref->u.c.component->ts.type == BT_CHARACTER
2827 && ref->u.c.component->ts.cl->length->expr_type
2828 != EXPR_CONSTANT)
2829 generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
2830
2831 if (ref->u.c.component->as)
2832 for (i = 0; i < ref->u.c.component->as->rank; i++)
2833 {
2834 generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
2835 generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
2836 }
2837 break;
2838 }
2839 }
2840 }
2841}
2842
2843
2844/* Check for dependencies in the character length and array spec. */
2845
2846static void
2847generate_dependency_declarations (gfc_symbol *sym)
2848{
2849 int i;
2850
2851 if (sym->ts.type == BT_CHARACTER
2852 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
2853 generate_expr_decls (sym, sym->ts.cl->length);
2854
2855 if (sym->as && sym->as->rank)
2856 {
2857 for (i = 0; i < sym->as->rank; i++)
2858 {
2859 generate_expr_decls (sym, sym->as->lower[i]);
2860 generate_expr_decls (sym, sym->as->upper[i]);
2861 }
2862 }
2863}
2864
2865
6de9cd9a
DN		 2866/* Generate decls for all local variables. We do this to ensure correct
2867 handling of expressions which only appear in the specification of
2868 other functions. */
2869
2870static void
2871generate_local_decl (gfc_symbol * sym)
2872{
2873 if (sym->attr.flavor == FL_VARIABLE)
2874 {
3e978d30
PT		 2875 /* Check for dependencies in the array specification and string
2876 length, adding the necessary declarations to the function. We
2877 mark the symbol now, as well as in traverse_ns, to prevent
2878 getting stuck in a circular dependency. */
2879 sym->mark = 1;
2880 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
2881 generate_dependency_declarations (sym);
2882
6de9cd9a
DN		 2883 if (sym->attr.referenced)
2884 gfc_get_symbol_decl (sym);
19e4c59d 2885 else if (sym->attr.dummy && warn_unused_parameter)
80f2bb6e
PT		 2886 gfc_warning ("Unused parameter %s declared at %L", sym->name,
2887 &sym->declared_at);
f8d0aee5 2888 /* Warn for unused variables, but not if they're inside a common
19e4c59d 2889 block or are use-associated. */
ce738b86
TS		 2890 else if (warn_unused_variable
2891 && !(sym->attr.in_common || sym->attr.use_assoc))
80f2bb6e
PT		 2892 gfc_warning ("Unused variable %s declared at %L", sym->name,
2893 &sym->declared_at);
417ab240
JJ		 2894 /* For variable length CHARACTER parameters, the PARM_DECL already
2895 references the length variable, so force gfc_get_symbol_decl
2896 even when not referenced. If optimize > 0, it will be optimized
2897 away anyway. But do this only after emitting -Wunused-parameter
2898 warning if requested. */
2899 if (sym->attr.dummy && ! sym->attr.referenced
2900 && sym->ts.type == BT_CHARACTER
2901 && sym->ts.cl->backend_decl != NULL
2902 && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
2903 {
2904 sym->attr.referenced = 1;
2905 gfc_get_symbol_decl (sym);
2906 }
6de9cd9a
DN		 2907 }
2908}
2909
2910static void
2911generate_local_vars (gfc_namespace * ns)
2912{
2913 gfc_traverse_ns (ns, generate_local_decl);
2914}
2915
2916
3d79abbd
PB		 2917/* Generate a switch statement to jump to the correct entry point. Also
2918 creates the label decls for the entry points. */
6de9cd9a 2919
3d79abbd
PB		 2920static tree
2921gfc_trans_entry_master_switch (gfc_entry_list * el)
6de9cd9a 2922{
3d79abbd
PB		 2923 stmtblock_t block;
2924 tree label;
2925 tree tmp;
2926 tree val;
6de9cd9a 2927
3d79abbd
PB		 2928 gfc_init_block (&block);
2929 for (; el; el = el->next)
2930 {
2931 /* Add the case label. */
c006df4e 2932 label = gfc_build_label_decl (NULL_TREE);
7d60be94 2933 val = build_int_cst (gfc_array_index_type, el->id);
923ab88c 2934 tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3d79abbd
PB		 2935 gfc_add_expr_to_block (&block, tmp);
2936
2937 /* And jump to the actual entry point. */
2938 label = gfc_build_label_decl (NULL_TREE);
3d79abbd
PB		 2939 tmp = build1_v (GOTO_EXPR, label);
2940 gfc_add_expr_to_block (&block, tmp);
2941
2942 /* Save the label decl. */
2943 el->label = label;
2944 }
2945 tmp = gfc_finish_block (&block);
2946 /* The first argument selects the entry point. */
2947 val = DECL_ARGUMENTS (current_function_decl);
923ab88c 2948 tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3d79abbd 2949 return tmp;
6de9cd9a
DN		 2950}
2951
44de5aeb 2952
6de9cd9a
DN		 2953/* Generate code for a function. */
2954
2955void
2956gfc_generate_function_code (gfc_namespace * ns)
2957{
2958 tree fndecl;
2959 tree old_context;
2960 tree decl;
2961 tree tmp;
2962 stmtblock_t block;
2963 stmtblock_t body;
2964 tree result;
2965 gfc_symbol *sym;
2966
2967 sym = ns->proc_name;
3d79abbd 2968
6de9cd9a 2969 /* Check that the frontend isn't still using this. */
6e45f57b 2970 gcc_assert (sym->tlink == NULL);
6de9cd9a
DN		 2971 sym->tlink = sym;
2972
2973 /* Create the declaration for functions with global scope. */
2974 if (!sym->backend_decl)
3d79abbd 2975 gfc_create_function_decl (ns);
6de9cd9a
DN		 2976
2977 fndecl = sym->backend_decl;
2978 old_context = current_function_decl;
2979
2980 if (old_context)
2981 {
2982 push_function_context ();
2983 saved_parent_function_decls = saved_function_decls;
2984 saved_function_decls = NULL_TREE;
2985 }
2986
3d79abbd 2987 trans_function_start (sym);
6de9cd9a 2988
6de9cd9a
DN		 2989 gfc_start_block (&block);
2990
d198b59a
JJ		 2991 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2992 {
2993 /* Copy length backend_decls to all entry point result
2994 symbols. */
2995 gfc_entry_list *el;
2996 tree backend_decl;
2997
2998 gfc_conv_const_charlen (ns->proc_name->ts.cl);
2999 backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3000 for (el = ns->entries; el; el = el->next)
3001 el->sym->result->ts.cl->backend_decl = backend_decl;
3002 }
3003
6de9cd9a
DN		 3004 /* Translate COMMON blocks. */
3005 gfc_trans_common (ns);
3006
5f20c93a
PT		 3007 /* Null the parent fake result declaration if this namespace is
3008 a module function or an external procedures. */
3009 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3010 || ns->parent == NULL)
3011 parent_fake_result_decl = NULL_TREE;
3012
30aabb86
PT		 3013 gfc_generate_contained_functions (ns);
3014
6de9cd9a 3015 generate_local_vars (ns);
90b2f8b6 3016
5f20c93a
PT		 3017 /* Keep the parent fake result declaration in module functions
3018 or external procedures. */
3019 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3020 || ns->parent == NULL)
3021 current_fake_result_decl = parent_fake_result_decl;
3022 else
3023 current_fake_result_decl = NULL_TREE;
3024
6de9cd9a
DN		 3025 current_function_return_label = NULL;
3026
3027 /* Now generate the code for the body of this function. */
3028 gfc_init_block (&body);
3029
5f8f5313
FXC		 3030 /* If this is the main program, add a call to set_std to set up the
3031 runtime library Fortran language standard parameters. */
3032
3033 if (sym->attr.is_main_program)
8b67b708
FXC		 3034 {
3035 tree arglist, gfc_int4_type_node;
3036
3037 gfc_int4_type_node = gfc_get_int_type (4);
3038 arglist = gfc_chainon_list (NULL_TREE,
3039 build_int_cst (gfc_int4_type_node,
3040 gfc_option.warn_std));
3041 arglist = gfc_chainon_list (arglist,
3042 build_int_cst (gfc_int4_type_node,
3043 gfc_option.allow_std));
5f8f5313
FXC		 3044 arglist = gfc_chainon_list (arglist,
3045 build_int_cst (gfc_int4_type_node,
3046 pedantic));
3380b802 3047 tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
8b67b708
FXC		 3048 gfc_add_expr_to_block (&body, tmp);
3049 }
3050
944b8b35
FXC		 3051 /* If this is the main program and a -ffpe-trap option was provided,
3052 add a call to set_fpe so that the library will raise a FPE when
3053 needed. */
3054 if (sym->attr.is_main_program && gfc_option.fpe != 0)
3055 {
3056 tree arglist, gfc_c_int_type_node;
3057
3058 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3059 arglist = gfc_chainon_list (NULL_TREE,
3060 build_int_cst (gfc_c_int_type_node,
3061 gfc_option.fpe));
3380b802 3062 tmp = build_function_call_expr (gfor_fndecl_set_fpe, arglist);
944b8b35
FXC		 3063 gfc_add_expr_to_block (&body, tmp);
3064 }
3065
eaa90d25
TK		 3066 /* If this is the main program and an -fconvert option was provided,
3067 add a call to set_convert. */
3068
3069 if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
3070 {
3071 tree arglist, gfc_c_int_type_node;
3072
3073 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3074 arglist = gfc_chainon_list (NULL_TREE,
3075 build_int_cst (gfc_c_int_type_node,
3076 gfc_option.convert));
3077 tmp = build_function_call_expr (gfor_fndecl_set_convert, arglist);
3078 gfc_add_expr_to_block (&body, tmp);
3079 }
3080
d67ab5ee
TK		 3081 /* If this is the main program and an -frecord-marker option was provided,
3082 add a call to set_record_marker. */
3083
3084 if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3085 {
3086 tree arglist, gfc_c_int_type_node;
3087
3088 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3089 arglist = gfc_chainon_list (NULL_TREE,
3090 build_int_cst (gfc_c_int_type_node,
3091 gfc_option.record_marker));
3092 tmp = build_function_call_expr (gfor_fndecl_set_record_marker, arglist);
3093 gfc_add_expr_to_block (&body, tmp);
3094
3095 }
eaa90d25 3096
6de9cd9a
DN		 3097 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3098 && sym->attr.subroutine)
3099 {
3100 tree alternate_return;
5f20c93a 3101 alternate_return = gfc_get_fake_result_decl (sym, 0);
6de9cd9a
DN		 3102 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
3103 }
3104
3d79abbd
PB		 3105 if (ns->entries)
3106 {
3107 /* Jump to the correct entry point. */
3108 tmp = gfc_trans_entry_master_switch (ns->entries);
3109 gfc_add_expr_to_block (&body, tmp);
3110 }
3111
6de9cd9a
DN		 3112 tmp = gfc_trans_code (ns->code);
3113 gfc_add_expr_to_block (&body, tmp);
3114
3115 /* Add a return label if needed. */
3116 if (current_function_return_label)
3117 {
3118 tmp = build1_v (LABEL_EXPR, current_function_return_label);
3119 gfc_add_expr_to_block (&body, tmp);
3120 }
3121
3122 tmp = gfc_finish_block (&body);
3123 /* Add code to create and cleanup arrays. */
3124 tmp = gfc_trans_deferred_vars (sym, tmp);
3125 gfc_add_expr_to_block (&block, tmp);
3126
3127 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3128 {
19e4c59d 3129 if (sym->attr.subroutine || sym == sym->result)
6de9cd9a 3130 {
417ab240
JJ		 3131 if (current_fake_result_decl != NULL)
3132 result = TREE_VALUE (current_fake_result_decl);
3133 else
3134 result = NULL_TREE;
6de9cd9a
DN		 3135 current_fake_result_decl = NULL_TREE;
3136 }
3137 else
3138 result = sym->result->backend_decl;
3139
3140 if (result == NULL_TREE)
d4ee4d25 3141 warning (0, "Function return value not set");
6de9cd9a
DN		 3142 else
3143 {
f8d0aee5 3144 /* Set the return value to the dummy result variable. */
923ab88c
TS		 3145 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
3146 DECL_RESULT (fndecl), result);
3147 tmp = build1_v (RETURN_EXPR, tmp);
6de9cd9a
DN		 3148 gfc_add_expr_to_block (&block, tmp);
3149 }
3150 }
3151
3152 /* Add all the decls we created during processing. */
3153 decl = saved_function_decls;
3154 while (decl)
3155 {
3156 tree next;
3157
3158 next = TREE_CHAIN (decl);
3159 TREE_CHAIN (decl) = NULL_TREE;
3160 pushdecl (decl);
3161 decl = next;
3162 }
3163 saved_function_decls = NULL_TREE;
3164
3165 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3166
3167 /* Finish off this function and send it for code generation. */
3168 poplevel (1, 0, 1);
3169 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3170
3171 /* Output the GENERIC tree. */
3172 dump_function (TDI_original, fndecl);
3173
3174 /* Store the end of the function, so that we get good line number
3175 info for the epilogue. */
3176 cfun->function_end_locus = input_location;
3177
3178 /* We're leaving the context of this function, so zap cfun.
3179 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3180 tree_rest_of_compilation. */
3181 cfun = NULL;
3182
3183 if (old_context)
3184 {
3185 pop_function_context ();
3186 saved_function_decls = saved_parent_function_decls;
3187 }
3188 current_function_decl = old_context;
3189
3190 if (decl_function_context (fndecl))
44de5aeb
RK		 3191 /* Register this function with cgraph just far enough to get it
3192 added to our parent's nested function list. */
3193 (void) cgraph_node (fndecl);
6de9cd9a
DN		 3194 else
3195 {
44de5aeb 3196 gfc_gimplify_function (fndecl);
8f235343 3197 cgraph_finalize_function (fndecl, false);
6de9cd9a
DN		 3198 }
3199}
3200
6de9cd9a
DN		 3201void
3202gfc_generate_constructors (void)
3203{
6e45f57b 3204 gcc_assert (gfc_static_ctors == NULL_TREE);
6de9cd9a
DN		 3205#if 0
3206 tree fnname;
3207 tree type;
3208 tree fndecl;
3209 tree decl;
3210 tree tmp;
3211
3212 if (gfc_static_ctors == NULL_TREE)
3213 return;
3214
3215 fnname = get_file_function_name ('I');
3216 type = build_function_type (void_type_node,
3217 gfc_chainon_list (NULL_TREE, void_type_node));
3218
3219 fndecl = build_decl (FUNCTION_DECL, fnname, type);
3220 TREE_PUBLIC (fndecl) = 1;
3221
3222 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
b785f485
RH		 3223 DECL_ARTIFICIAL (decl) = 1;
3224 DECL_IGNORED_P (decl) = 1;
6de9cd9a
DN		 3225 DECL_CONTEXT (decl) = fndecl;
3226 DECL_RESULT (fndecl) = decl;
3227
3228 pushdecl (fndecl);
3229
3230 current_function_decl = fndecl;
3231
0e6df31e 3232 rest_of_decl_compilation (fndecl, 1, 0);
6de9cd9a 3233
0e6df31e 3234 make_decl_rtl (fndecl);
6de9cd9a 3235
c8cc8542 3236 init_function_start (fndecl);
6de9cd9a 3237
6de9cd9a
DN		 3238 pushlevel (0);
3239
3240 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3241 {
3242 tmp =
3380b802 3243 build_function_call_expr (TREE_VALUE (gfc_static_ctors), NULL_TREE);
6de9cd9a
DN		 3244 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3245 }
3246
3247 poplevel (1, 0, 1);
3248
3249 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3250
3251 free_after_parsing (cfun);
3252 free_after_compilation (cfun);
3253
0f0377f6 3254 tree_rest_of_compilation (fndecl);
6de9cd9a
DN		 3255
3256 current_function_decl = NULL_TREE;
3257#endif
3258}
3259
0de4325e
TS		 3260/* Translates a BLOCK DATA program unit. This means emitting the
3261 commons contained therein plus their initializations. We also emit
3262 a globally visible symbol to make sure that each BLOCK DATA program
3263 unit remains unique. */
3264
3265void
3266gfc_generate_block_data (gfc_namespace * ns)
3267{
3268 tree decl;
3269 tree id;
3270
c8cc8542
PB		 3271 /* Tell the backend the source location of the block data. */
3272 if (ns->proc_name)
3273 gfc_set_backend_locus (&ns->proc_name->declared_at);
3274 else
3275 gfc_set_backend_locus (&gfc_current_locus);
3276
3277 /* Process the DATA statements. */
0de4325e
TS		 3278 gfc_trans_common (ns);
3279
c8cc8542
PB		 3280 /* Create a global symbol with the mane of the block data. This is to
3281 generate linker errors if the same name is used twice. It is never
3282 really used. */
0de4325e
TS		 3283 if (ns->proc_name)
3284 id = gfc_sym_mangled_function_id (ns->proc_name);
3285 else
3286 id = get_identifier ("__BLOCK_DATA__");
3287
3288 decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3289 TREE_PUBLIC (decl) = 1;
3290 TREE_STATIC (decl) = 1;
3291
3292 pushdecl (decl);
3293 rest_of_decl_compilation (decl, 1, 0);
3294}
3295
83d890b9 3296
6de9cd9a 3297#include "gt-fortran-trans-decl.h"
GNU Compiler Collection
This page took 1.143576 seconds and 5 git commands to generate.