]> 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
locale_facets.tcc (num_put<>::do_put(bool)): Cast to a signed type, long according...
[gcc.git] / gcc / fortran / trans-decl.c
CommitLineData
6de9cd9a
DN		 1/* Backend function setup
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS		 7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 2, or (at your option) any later
10version.
6de9cd9a 11
9fc4d79b
TS		 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
6de9cd9a
DN		 16
17You should have received a copy of the GNU General Public License
9fc4d79b
TS		 18along with GCC; see the file COPYING. If not, write to the Free
19Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-1307, USA. */
6de9cd9a
DN		 21
22/* trans-decl.c -- Handling of backend function and variable decls, etc */
23
24#include "config.h"
25#include "system.h"
26#include "coretypes.h"
27#include "tree.h"
28#include "tree-dump.h"
eadf906f 29#include "tree-gimple.h"
6de9cd9a
DN		 30#include "ggc.h"
31#include "toplev.h"
32#include "tm.h"
33#include "target.h"
34#include "function.h"
35#include "errors.h"
36#include "flags.h"
37#include "cgraph.h"
38#include <assert.h>
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;
53
54static GTY(()) tree current_function_return_label;
55
56
57/* Holds the variable DECLs for the current function. */
58
59static GTY(()) tree saved_function_decls = NULL_TREE;
60static GTY(()) tree saved_parent_function_decls = NULL_TREE;
61
62
63/* The namespace of the module we're currently generating. Only used while
64 outputting decls for module variables. Do not rely on this being set. */
65
66static gfc_namespace *module_namespace;
67
68
69/* List of static constructor functions. */
70
71tree gfc_static_ctors;
72
73
74/* Function declarations for builtin library functions. */
75
76tree gfor_fndecl_internal_malloc;
77tree gfor_fndecl_internal_malloc64;
78tree gfor_fndecl_internal_free;
79tree gfor_fndecl_allocate;
80tree gfor_fndecl_allocate64;
81tree gfor_fndecl_deallocate;
82tree gfor_fndecl_pause_numeric;
83tree gfor_fndecl_pause_string;
84tree gfor_fndecl_stop_numeric;
85tree gfor_fndecl_stop_string;
86tree gfor_fndecl_select_string;
87tree gfor_fndecl_runtime_error;
88tree gfor_fndecl_in_pack;
89tree gfor_fndecl_in_unpack;
90tree gfor_fndecl_associated;
91
92
93/* Math functions. Many other math functions are handled in
94 trans-intrinsic.c. */
95
5b200ac2 96gfc_powdecl_list gfor_fndecl_math_powi[3][2];
6de9cd9a
DN		 97tree gfor_fndecl_math_cpowf;
98tree gfor_fndecl_math_cpow;
6de9cd9a
DN		 99tree gfor_fndecl_math_ishftc4;
100tree gfor_fndecl_math_ishftc8;
101tree gfor_fndecl_math_exponent4;
102tree gfor_fndecl_math_exponent8;
103
104
105/* String functions. */
106
107tree gfor_fndecl_copy_string;
108tree gfor_fndecl_compare_string;
109tree gfor_fndecl_concat_string;
110tree gfor_fndecl_string_len_trim;
111tree gfor_fndecl_string_index;
112tree gfor_fndecl_string_scan;
113tree gfor_fndecl_string_verify;
114tree gfor_fndecl_string_trim;
115tree gfor_fndecl_string_repeat;
116tree gfor_fndecl_adjustl;
117tree gfor_fndecl_adjustr;
118
119
120/* Other misc. runtime library functions. */
121
122tree gfor_fndecl_size0;
123tree gfor_fndecl_size1;
b41b2534 124tree gfor_fndecl_iargc;
6de9cd9a
DN		 125
126/* Intrinsic functions implemented in FORTRAN. */
127tree gfor_fndecl_si_kind;
128tree gfor_fndecl_sr_kind;
129
130
131static void
132gfc_add_decl_to_parent_function (tree decl)
133{
134 assert (decl);
135 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
136 DECL_NONLOCAL (decl) = 1;
137 TREE_CHAIN (decl) = saved_parent_function_decls;
138 saved_parent_function_decls = decl;
139}
140
141void
142gfc_add_decl_to_function (tree decl)
143{
144 assert (decl);
145 TREE_USED (decl) = 1;
146 DECL_CONTEXT (decl) = current_function_decl;
147 TREE_CHAIN (decl) = saved_function_decls;
148 saved_function_decls = decl;
149}
150
151
152/* Build a backend label declaration.
153 Set TREE_USED for named lables. For artificial labels it's up to the
154 caller to mark the label as used. */
155
156tree
157gfc_build_label_decl (tree label_id)
158{
159 /* 2^32 temporaries should be enough. */
160 static unsigned int tmp_num = 1;
161 tree label_decl;
162 char *label_name;
163
164 if (label_id == NULL_TREE)
165 {
166 /* Build an internal label name. */
167 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
168 label_id = get_identifier (label_name);
169 }
170 else
171 label_name = NULL;
172
173 /* Build the LABEL_DECL node. Labels have no type. */
174 label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
175 DECL_CONTEXT (label_decl) = current_function_decl;
176 DECL_MODE (label_decl) = VOIDmode;
177
178 if (label_name)
179 {
180 DECL_ARTIFICIAL (label_decl) = 1;
181 }
182 else
183 {
184 /* We always define the label as used, even if the original source
185 file never references the label. We don't want all kinds of
186 spurious warnings for old-style Fortran code with too many
187 labels. */
188 TREE_USED (label_decl) = 1;
189 }
190
191 return label_decl;
192}
193
194
195/* Returns the return label for the current function. */
196
197tree
198gfc_get_return_label (void)
199{
200 char name[GFC_MAX_SYMBOL_LEN + 10];
201
202 if (current_function_return_label)
203 return current_function_return_label;
204
205 sprintf (name, "__return_%s",
206 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
207
208 current_function_return_label =
209 gfc_build_label_decl (get_identifier (name));
210
211 DECL_ARTIFICIAL (current_function_return_label) = 1;
212
213 return current_function_return_label;
214}
215
216
217/* Return the backend label declaration for a given label structure,
218 or create it if it doesn't exist yet. */
219
220tree
221gfc_get_label_decl (gfc_st_label * lp)
222{
223
224 if (lp->backend_decl)
225 return lp->backend_decl;
226 else
227 {
228 char label_name[GFC_MAX_SYMBOL_LEN + 1];
229 tree label_decl;
230
231 /* Validate the label declaration from the front end. */
232 assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
233
234 /* Build a mangled name for the label. */
235 sprintf (label_name, "__label_%.6d", lp->value);
236
237 /* Build the LABEL_DECL node. */
238 label_decl = gfc_build_label_decl (get_identifier (label_name));
239
240 /* Tell the debugger where the label came from. */
241 if (lp->value <= MAX_LABEL_VALUE) /* An internal label */
242 {
d4fa05b9
TS		 243 DECL_SOURCE_LINE (label_decl) = lp->where.lb->linenum;
244 DECL_SOURCE_FILE (label_decl) = lp->where.lb->file->filename;
6de9cd9a
DN		 245 }
246 else
247 DECL_ARTIFICIAL (label_decl) = 1;
248
249 /* Store the label in the label list and return the LABEL_DECL. */
250 lp->backend_decl = label_decl;
251 return label_decl;
252 }
253}
254
255
256/* Convert a gfc_symbol to an identifier of the same name. */
257
258static tree
259gfc_sym_identifier (gfc_symbol * sym)
260{
261 return (get_identifier (sym->name));
262}
263
264
265/* Construct mangled name from symbol name. */
266
267static tree
268gfc_sym_mangled_identifier (gfc_symbol * sym)
269{
270 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
271
272 if (sym->module[0] == 0)
273 return gfc_sym_identifier (sym);
274 else
275 {
276 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
277 return get_identifier (name);
278 }
279}
280
281
282/* Construct mangled function name from symbol name. */
283
284static tree
285gfc_sym_mangled_function_id (gfc_symbol * sym)
286{
287 int has_underscore;
288 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
289
290 if (sym->module[0] == 0 || sym->attr.proc == PROC_EXTERNAL
291 || (sym->module[0] != 0 && sym->attr.if_source == IFSRC_IFBODY))
292 {
293 if (strcmp (sym->name, "MAIN__") == 0
294 || sym->attr.proc == PROC_INTRINSIC)
295 return get_identifier (sym->name);
296
297 if (gfc_option.flag_underscoring)
298 {
299 has_underscore = strchr (sym->name, '_') != 0;
300 if (gfc_option.flag_second_underscore && has_underscore)
301 snprintf (name, sizeof name, "%s__", sym->name);
302 else
303 snprintf (name, sizeof name, "%s_", sym->name);
304 return get_identifier (name);
305 }
306 else
307 return get_identifier (sym->name);
308 }
309 else
310 {
311 snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
312 return get_identifier (name);
313 }
314}
315
316
317/* Finish processing of a declaration and install its initial value. */
318
319static void
320gfc_finish_decl (tree decl, tree init)
321{
322 if (TREE_CODE (decl) == PARM_DECL)
323 assert (init == NULL_TREE);
324 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
325 -- it overlaps DECL_ARG_TYPE. */
326 else if (init == NULL_TREE)
327 assert (DECL_INITIAL (decl) == NULL_TREE);
328 else
329 assert (DECL_INITIAL (decl) == error_mark_node);
330
331 if (init != NULL_TREE)
332 {
333 if (TREE_CODE (decl) != TYPE_DECL)
334 DECL_INITIAL (decl) = init;
335 else
336 {
337 /* typedef foo = bar; store the type of bar as the type of foo. */
338 TREE_TYPE (decl) = TREE_TYPE (init);
339 DECL_INITIAL (decl) = init = 0;
340 }
341 }
342
343 if (TREE_CODE (decl) == VAR_DECL)
344 {
345 if (DECL_SIZE (decl) == NULL_TREE
346 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
347 layout_decl (decl, 0);
348
349 /* A static variable with an incomplete type is an error if it is
350 initialized. Also if it is not file scope. Otherwise, let it
351 through, but if it is not `extern' then it may cause an error
352 message later. */
353 /* An automatic variable with an incomplete type is an error. */
354 if (DECL_SIZE (decl) == NULL_TREE
355 && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
356 || DECL_CONTEXT (decl) != 0)
357 : !DECL_EXTERNAL (decl)))
358 {
359 gfc_fatal_error ("storage size not known");
360 }
361
362 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
363 && (DECL_SIZE (decl) != 0)
364 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
365 {
366 gfc_fatal_error ("storage size not constant");
367 }
368 }
369
370}
371
372
373/* Apply symbol attributes to a variable, and add it to the function scope. */
374
375static void
376gfc_finish_var_decl (tree decl, gfc_symbol * sym)
377{
378 /* TREE_ADDRESSABLE means the address of this variable is acualy needed.
379 This is the equivalent of the TARGET variables.
380 We also need to set this if the variable is passed by reference in a
381 CALL statement. */
382 if (sym->attr.target)
383 TREE_ADDRESSABLE (decl) = 1;
384 /* If it wasn't used we wouldn't be getting it. */
385 TREE_USED (decl) = 1;
386
387 /* Chain this decl to the pending declarations. Don't do pushdecl()
388 because this would add them to the current scope rather than the
389 function scope. */
390 if (current_function_decl != NULL_TREE)
391 {
392 if (sym->ns->proc_name->backend_decl == current_function_decl)
393 gfc_add_decl_to_function (decl);
394 else
395 gfc_add_decl_to_parent_function (decl);
396 }
397
398 /* If a variable is USE associated, it's always external. */
399 if (sym->attr.use_assoc)
400 {
401 DECL_EXTERNAL (decl) = 1;
402 TREE_PUBLIC (decl) = 1;
403 }
404 else if (sym->module[0] && !sym->attr.result)
405 {
406 /* TODO: Don't set sym->module for result variables. */
407 assert (current_function_decl == NULL_TREE);
408 /* This is the declaration of a module variable. */
409 TREE_PUBLIC (decl) = 1;
410 TREE_STATIC (decl) = 1;
411 }
412
413 if ((sym->attr.save || sym->attr.data || sym->value)
414 && !sym->attr.use_assoc)
415 TREE_STATIC (decl) = 1;
416
417 /* Keep variables larger than max-stack-var-size off stack. */
418 if (!sym->ns->proc_name->attr.recursive
419 && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
420 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
421 TREE_STATIC (decl) = 1;
422}
423
424
425/* Allocate the lang-specific part of a decl. */
426
427void
428gfc_allocate_lang_decl (tree decl)
429{
430 DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
431 ggc_alloc_cleared (sizeof (struct lang_decl));
432}
433
434/* Remember a symbol to generate initialization/cleanup code at function
435 entry/exit. */
436
437static void
438gfc_defer_symbol_init (gfc_symbol * sym)
439{
440 gfc_symbol *p;
441 gfc_symbol *last;
442 gfc_symbol *head;
443
444 /* Don't add a symbol twice. */
445 if (sym->tlink)
446 return;
447
448 last = head = sym->ns->proc_name;
449 p = last->tlink;
450
451 /* Make sure that setup code for dummy variables which are used in the
452 setup of other variables is generated first. */
453 if (sym->attr.dummy)
454 {
455 /* Find the first dummy arg seen after us, or the first non-dummy arg.
456 This is a circular list, so don't go past the head. */
457 while (p != head
458 && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
459 {
460 last = p;
461 p = p->tlink;
462 }
463 }
464 /* Insert in between last and p. */
465 last->tlink = sym;
466 sym->tlink = p;
467}
468
469
470/* Create an array index type variable with function scope. */
471
472static tree
473create_index_var (const char * pfx, int nest)
474{
475 tree decl;
476
477 decl = gfc_create_var_np (gfc_array_index_type, pfx);
478 if (nest)
479 gfc_add_decl_to_parent_function (decl);
480 else
481 gfc_add_decl_to_function (decl);
482 return decl;
483}
484
485
486/* Create variables to hold all the non-constant bits of info for a
487 descriptorless array. Remember these in the lang-specific part of the
488 type. */
489
490static void
491gfc_build_qualified_array (tree decl, gfc_symbol * sym)
492{
493 tree type;
494 int dim;
495 int nest;
496
497 type = TREE_TYPE (decl);
498
499 /* We just use the descriptor, if there is one. */
500 if (GFC_DESCRIPTOR_TYPE_P (type))
501 return;
502
503 assert (GFC_ARRAY_TYPE_P (type));
504 nest = (sym->ns->proc_name->backend_decl != current_function_decl)
505 && !sym->attr.contained;
506
507 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
508 {
509 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
510 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
511 /* Don't try to use the unkown bound for assumed shape arrays. */
512 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
513 && (sym->as->type != AS_ASSUMED_SIZE
514 || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
515 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
516
517 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
518 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
519 }
520 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
521 {
522 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
523 "offset");
524 if (nest)
525 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
526 else
527 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
528 }
529}
530
531
532/* For some dummy arguments we don't use the actual argument directly.
533 Instead we create a local decl and use that. This allows us to preform
534 initialization, and construct full type information. */
535
536static tree
537gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
538{
539 tree decl;
540 tree type;
541 gfc_array_spec *as;
542 char *name;
543 int packed;
544 int n;
545 bool known_size;
546
547 if (sym->attr.pointer || sym->attr.allocatable)
548 return dummy;
549
550 /* Add to list of variables if not a fake result variable. */
551 if (sym->attr.result || sym->attr.dummy)
552 gfc_defer_symbol_init (sym);
553
554 type = TREE_TYPE (dummy);
555 assert (TREE_CODE (dummy) == PARM_DECL
556 && POINTER_TYPE_P (type));
557
558 /* Do we know the element size. */
559 known_size = sym->ts.type != BT_CHARACTER
560 || INTEGER_CST_P (sym->ts.cl->backend_decl);
561
562 if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
563 {
564 /* For descriptorless arrays with known element size the actual
565 argument is sufficient. */
566 assert (GFC_ARRAY_TYPE_P (type));
567 gfc_build_qualified_array (dummy, sym);
568 return dummy;
569 }
570
571 type = TREE_TYPE (type);
572 if (GFC_DESCRIPTOR_TYPE_P (type))
573 {
574 /* Create a decriptorless array pointer. */
575 as = sym->as;
576 packed = 0;
577 if (!gfc_option.flag_repack_arrays)
578 {
579 if (as->type == AS_ASSUMED_SIZE)
580 packed = 2;
581 }
582 else
583 {
584 if (as->type == AS_EXPLICIT)
585 {
586 packed = 2;
587 for (n = 0; n < as->rank; n++)
588 {
589 if (!(as->upper[n]
590 && as->lower[n]
591 && as->upper[n]->expr_type == EXPR_CONSTANT
592 && as->lower[n]->expr_type == EXPR_CONSTANT))
593 packed = 1;
594 }
595 }
596 else
597 packed = 1;
598 }
599
600 type = gfc_typenode_for_spec (&sym->ts);
601 type = gfc_get_nodesc_array_type (type, sym->as, packed);
602 }
603 else
604 {
605 /* We now have an expression for the element size, so create a fully
606 qualified type. Reset sym->backend decl or this will just return the
607 old type. */
608 sym->backend_decl = NULL_TREE;
609 type = gfc_sym_type (sym);
610 packed = 2;
611 }
612
613 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
614 decl = build_decl (VAR_DECL, get_identifier (name), type);
615
616 DECL_ARTIFICIAL (decl) = 1;
617 TREE_PUBLIC (decl) = 0;
618 TREE_STATIC (decl) = 0;
619 DECL_EXTERNAL (decl) = 0;
620
621 /* We should never get deferred shape arrays here. We used to because of
622 frontend bugs. */
623 assert (sym->as->type != AS_DEFERRED);
624
625 switch (packed)
626 {
627 case 1:
628 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
629 break;
630
631 case 2:
632 GFC_DECL_PACKED_ARRAY (decl) = 1;
633 break;
634 }
635
636 gfc_build_qualified_array (decl, sym);
637
638 if (DECL_LANG_SPECIFIC (dummy))
639 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
640 else
641 gfc_allocate_lang_decl (decl);
642
643 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
644
645 if (sym->ns->proc_name->backend_decl == current_function_decl
646 || sym->attr.contained)
647 gfc_add_decl_to_function (decl);
648 else
649 gfc_add_decl_to_parent_function (decl);
650
651 return decl;
652}
653
654
655/* Return a constant or a variable to use as a string length. Does not
656 add the decl to the current scope. */
657
658static tree
659gfc_create_string_length (gfc_symbol * sym)
660{
661 tree length;
662
663 assert (sym->ts.cl);
664 gfc_conv_const_charlen (sym->ts.cl);
665
666 if (sym->ts.cl->backend_decl == NULL_TREE)
667 {
668 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
669
670 /* Also prefix the mangled name. */
671 strcpy (&name[1], sym->name);
672 name[0] = '.';
673 length = build_decl (VAR_DECL, get_identifier (name),
674 gfc_strlen_type_node);
675 DECL_ARTIFICIAL (length) = 1;
676 TREE_USED (length) = 1;
677 gfc_defer_symbol_init (sym);
678 sym->ts.cl->backend_decl = length;
679 }
680
681 return sym->ts.cl->backend_decl;
682}
683
684
685/* Return the decl for a gfc_symbol, create it if it doesn't already
686 exist. */
687
688tree
689gfc_get_symbol_decl (gfc_symbol * sym)
690{
691 tree decl;
692 tree length = NULL_TREE;
6de9cd9a
DN		 693 int byref;
694
695 assert (sym->attr.referenced);
696
697 if (sym->ns && sym->ns->proc_name->attr.function)
698 byref = gfc_return_by_reference (sym->ns->proc_name);
699 else
700 byref = 0;
701
702 if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
703 {
704 /* Return via extra parameter. */
705 if (sym->attr.result && byref
706 && !sym->backend_decl)
707 {
708 sym->backend_decl =
709 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
710 }
711
712 /* Dummy variables should already have been created. */
713 assert (sym->backend_decl);
714
715 /* Create a character length variable. */
716 if (sym->ts.type == BT_CHARACTER)
717 {
718 if (sym->ts.cl->backend_decl == NULL_TREE)
719 {
720 length = gfc_create_string_length (sym);
721 if (TREE_CODE (length) != INTEGER_CST)
722 {
723 gfc_finish_var_decl (length, sym);
724 gfc_defer_symbol_init (sym);
725 }
726 }
727 }
728
729 /* Use a copy of the descriptor for dummy arrays. */
730 if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
731 {
732 sym->backend_decl =
733 gfc_build_dummy_array_decl (sym, sym->backend_decl);
734 }
735
736 TREE_USED (sym->backend_decl) = 1;
737 return sym->backend_decl;
738 }
739
740 if (sym->backend_decl)
741 return sym->backend_decl;
742
6de9cd9a
DN		 743 /* Catch function declarations. Only used for actual parameters. */
744 if (sym->attr.flavor == FL_PROCEDURE)
745 {
746 decl = gfc_get_extern_function_decl (sym);
747 return decl;
748 }
749
750 if (sym->attr.intrinsic)
751 internal_error ("intrinsic variable which isn't a procedure");
752
753 /* Create string length decl first so that they can be used in the
754 type declaration. */
755 if (sym->ts.type == BT_CHARACTER)
756 length = gfc_create_string_length (sym);
757
758 /* Create the decl for the variable. */
759 decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
760
761 /* Symbols from modules have its assembler name should be mangled.
762 This is done here rather than in gfc_finish_var_decl because it
763 is different for string length variables. */
764 if (sym->module[0])
765 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
766
767 if (sym->attr.dimension)
768 {
769 /* Create variables to hold the non-constant bits of array info. */
770 gfc_build_qualified_array (decl, sym);
771
772 /* Remember this variable for allocation/cleanup. */
773 gfc_defer_symbol_init (sym);
774
775 if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
776 GFC_DECL_PACKED_ARRAY (decl) = 1;
777 }
778
779 gfc_finish_var_decl (decl, sym);
780
781 if (sym->attr.assign)
782 {
783 gfc_allocate_lang_decl (decl);
784 GFC_DECL_ASSIGN (decl) = 1;
785 length = gfc_create_var (gfc_strlen_type_node, sym->name);
786 GFC_DECL_STRING_LEN (decl) = length;
787 GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
788 /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
789 TREE_STATIC (length) = TREE_STATIC (decl);
790 /* STRING_LENGTH is also used as flag. Less than -1 means that
791 ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
792 target label's address. Other value is the length of format string
793 and ASSIGN_ADDR is the address of format string. */
4a90aeeb 794 DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2, -1);
6de9cd9a
DN		 795 }
796
597073ac 797 if (sym->ts.type == BT_CHARACTER)
6de9cd9a 798 {
6de9cd9a
DN		 799 /* Character variables need special handling. */
800 gfc_allocate_lang_decl (decl);
801
597073ac 802 if (TREE_CODE (length) != INTEGER_CST)
6de9cd9a
DN		 803 {
804 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
805
806 if (sym->module[0])
807 {
808 /* Also prefix the mangled name for symbols from modules. */
809 strcpy (&name[1], sym->name);
810 name[0] = '.';
811 strcpy (&name[1],
812 IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
813 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
814 }
815 gfc_finish_var_decl (length, sym);
816 assert (!sym->value);
817 }
6de9cd9a
DN		 818 }
819 sym->backend_decl = decl;
820
597073ac
PB		 821 if (TREE_STATIC (decl) && !sym->attr.use_assoc)
822 {
823 /* Add static initializer. */
824 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
825 TREE_TYPE (decl), sym->attr.dimension,
826 sym->attr.pointer || sym->attr.allocatable);
827 }
828
6de9cd9a
DN		 829 return decl;
830}
831
832
7b5b57b7
PB		 833/* Substitute a temporary variable in place of the real one. */
834
835void
836gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
837{
838 save->attr = sym->attr;
839 save->decl = sym->backend_decl;
840
841 gfc_clear_attr (&sym->attr);
842 sym->attr.referenced = 1;
843 sym->attr.flavor = FL_VARIABLE;
844
845 sym->backend_decl = decl;
846}
847
848
849/* Restore the original variable. */
850
851void
852gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
853{
854 sym->attr = save->attr;
855 sym->backend_decl = save->decl;
856}
857
858
6de9cd9a
DN		 859/* Get a basic decl for an external function. */
860
861tree
862gfc_get_extern_function_decl (gfc_symbol * sym)
863{
864 tree type;
865 tree fndecl;
866 gfc_expr e;
867 gfc_intrinsic_sym *isym;
868 gfc_expr argexpr;
869 char s[GFC_MAX_SYMBOL_LEN];
870 tree name;
871 tree mangled_name;
872
873 if (sym->backend_decl)
874 return sym->backend_decl;
875
3d79abbd
PB		 876 /* We should never be creating external decls for alternate entry points.
877 The procedure may be an alternate entry point, but we don't want/need
878 to know that. */
879 assert (!(sym->attr.entry || sym->attr.entry_master));
880
6de9cd9a
DN		 881 if (sym->attr.intrinsic)
882 {
883 /* Call the resolution function to get the actual name. This is
884 a nasty hack which relies on the resolution functions only looking
885 at the first argument. We pass NULL for the second argument
886 otherwise things like AINT get confused. */
887 isym = gfc_find_function (sym->name);
888 assert (isym->resolve.f0 != NULL);
889
890 memset (&e, 0, sizeof (e));
891 e.expr_type = EXPR_FUNCTION;
892
893 memset (&argexpr, 0, sizeof (argexpr));
894 assert (isym->formal);
895 argexpr.ts = isym->formal->ts;
896
897 if (isym->formal->next == NULL)
898 isym->resolve.f1 (&e, &argexpr);
899 else
900 {
901 /* All specific intrinsics take one or two arguments. */
902 assert (isym->formal->next->next == NULL);
903 isym->resolve.f2 (&e, &argexpr, NULL);
904 }
905 sprintf (s, "specific%s", e.value.function.name);
906 name = get_identifier (s);
907 mangled_name = name;
908 }
909 else
910 {
911 name = gfc_sym_identifier (sym);
912 mangled_name = gfc_sym_mangled_function_id (sym);
913 }
914
915 type = gfc_get_function_type (sym);
916 fndecl = build_decl (FUNCTION_DECL, name, type);
917
918 SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
919 /* If the return type is a pointer, avoid alias issues by setting
920 DECL_IS_MALLOC to nonzero. This means that the function should be
921 treated as if it were a malloc, meaning it returns a pointer that
922 is not an alias. */
923 if (POINTER_TYPE_P (type))
924 DECL_IS_MALLOC (fndecl) = 1;
925
926 /* Set the context of this decl. */
927 if (0 && sym->ns && sym->ns->proc_name)
928 {
929 /* TODO: Add external decls to the appropriate scope. */
930 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
931 }
932 else
933 {
934 /* Global declaration, eg. intrinsic subroutine. */
935 DECL_CONTEXT (fndecl) = NULL_TREE;
936 }
937
938 DECL_EXTERNAL (fndecl) = 1;
939
940 /* This specifies if a function is globaly addressable, ie. it is
941 the opposite of declaring static in C. */
942 TREE_PUBLIC (fndecl) = 1;
943
944 /* Set attributes for PURE functions. A call to PURE function in the
945 Fortran 95 sense is both pure and without side effects in the C
946 sense. */
947 if (sym->attr.pure || sym->attr.elemental)
948 {
b7e6a6b3
TS		 949 if (sym->attr.function)
950 DECL_IS_PURE (fndecl) = 1;
951 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
952 parameters and don't use alternate returns (is this
953 allowed?). In that case, calls to them are meaningless, and
3d79abbd 954 can be optimized away. See also in build_function_decl(). */
b7e6a6b3 955 TREE_SIDE_EFFECTS (fndecl) = 0;
6de9cd9a
DN		 956 }
957
958 sym->backend_decl = fndecl;
959
960 if (DECL_CONTEXT (fndecl) == NULL_TREE)
961 pushdecl_top_level (fndecl);
962
963 return fndecl;
964}
965
966
967/* Create a declaration for a procedure. For external functions (in the C
3d79abbd
PB		 968 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
969 a master function with alternate entry points. */
6de9cd9a 970
3d79abbd
PB		 971static void
972build_function_decl (gfc_symbol * sym)
6de9cd9a 973{
3d79abbd 974 tree fndecl, type;
6de9cd9a 975 symbol_attribute attr;
3d79abbd 976 tree result_decl;
6de9cd9a
DN		 977 gfc_formal_arglist *f;
978
979 assert (!sym->backend_decl);
980 assert (!sym->attr.external);
981
982 /* Allow only one nesting level. Allow public declarations. */
983 assert (current_function_decl == NULL_TREE
984 || DECL_CONTEXT (current_function_decl) == NULL_TREE);
985
986 type = gfc_get_function_type (sym);
987 fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
988
989 /* Perform name mangling if this is a top level or module procedure. */
990 if (current_function_decl == NULL_TREE)
991 SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
992
993 /* Figure out the return type of the declared function, and build a
994 RESULT_DECL for it. If this is subroutine with alternate
995 returns, build a RESULT_DECL for it. */
996 attr = sym->attr;
997
998 result_decl = NULL_TREE;
999 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
1000 if (attr.function)
1001 {
1002 if (gfc_return_by_reference (sym))
1003 type = void_type_node;
1004 else
1005 {
1006 if (sym->result != sym)
1007 result_decl = gfc_sym_identifier (sym->result);
1008
1009 type = TREE_TYPE (TREE_TYPE (fndecl));
1010 }
1011 }
1012 else
1013 {
1014 /* Look for alternate return placeholders. */
1015 int has_alternate_returns = 0;
1016 for (f = sym->formal; f; f = f->next)
1017 {
1018 if (f->sym == NULL)
1019 {
1020 has_alternate_returns = 1;
1021 break;
1022 }
1023 }
1024
1025 if (has_alternate_returns)
1026 type = integer_type_node;
1027 else
1028 type = void_type_node;
1029 }
1030
1031 result_decl = build_decl (RESULT_DECL, result_decl, type);
b785f485
RH		 1032 DECL_ARTIFICIAL (result_decl) = 1;
1033 DECL_IGNORED_P (result_decl) = 1;
6de9cd9a
DN		 1034 DECL_CONTEXT (result_decl) = fndecl;
1035 DECL_RESULT (fndecl) = result_decl;
1036
1037 /* Don't call layout_decl for a RESULT_DECL.
1038 layout_decl (result_decl, 0); */
1039
1040 /* If the return type is a pointer, avoid alias issues by setting
1041 DECL_IS_MALLOC to nonzero. This means that the function should be
1042 treated as if it were a malloc, meaning it returns a pointer that
1043 is not an alias. */
1044 if (POINTER_TYPE_P (type))
1045 DECL_IS_MALLOC (fndecl) = 1;
1046
1047 /* Set up all attributes for the function. */
1048 DECL_CONTEXT (fndecl) = current_function_decl;
1049 DECL_EXTERNAL (fndecl) = 0;
1050
1d754240 1051 /* This specifies if a function is globaly visible, ie. it is
472ca416 1052 the opposite of declaring static in C. */
3d79abbd
PB		 1053 if (DECL_CONTEXT (fndecl) == NULL_TREE
1054 && !sym->attr.entry_master)
6de9cd9a
DN		 1055 TREE_PUBLIC (fndecl) = 1;
1056
1057 /* TREE_STATIC means the function body is defined here. */
1d754240 1058 TREE_STATIC (fndecl) = 1;
6de9cd9a
DN		 1059
1060 /* Set attributes for PURE functions. A call to PURE function in the
1061 Fortran 95 sense is both pure and without side effects in the C
1062 sense. */
1063 if (attr.pure || attr.elemental)
1064 {
b7e6a6b3
TS		 1065 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1066 including a alternate return. In that case it can also be
1067 marked as PURE. See also in gfc_get_extern_fucntion_decl(). */
1068 if (attr.function)
1069 DECL_IS_PURE (fndecl) = 1;
6de9cd9a
DN		 1070 TREE_SIDE_EFFECTS (fndecl) = 0;
1071 }
1072
1073 /* Layout the function declaration and put it in the binding level
1074 of the current function. */
1d754240 1075 pushdecl (fndecl);
3d79abbd
PB		 1076
1077 sym->backend_decl = fndecl;
1078}
1079
1080
1081/* Create the DECL_ARGUMENTS for a procedure. */
1082
1083static void
1084create_function_arglist (gfc_symbol * sym)
1085{
1086 tree fndecl;
1087 gfc_formal_arglist *f;
1088 tree typelist;
1089 tree arglist;
1090 tree length;
1091 tree type;
1092 tree parm;
1093
1094 fndecl = sym->backend_decl;
1095
1d754240
PB		 1096 /* Build formal argument list. Make sure that their TREE_CONTEXT is
1097 the new FUNCTION_DECL node. */
1d754240
PB		 1098 arglist = NULL_TREE;
1099 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
3d79abbd
PB		 1100
1101 if (sym->attr.entry_master)
1102 {
1103 type = TREE_VALUE (typelist);
1104 parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1105
1106 DECL_CONTEXT (parm) = fndecl;
1107 DECL_ARG_TYPE (parm) = type;
1108 TREE_READONLY (parm) = 1;
1109 gfc_finish_decl (parm, NULL_TREE);
1110
1111 arglist = chainon (arglist, parm);
1112 typelist = TREE_CHAIN (typelist);
1113 }
1114
1d754240 1115 if (gfc_return_by_reference (sym))
6de9cd9a 1116 {
1d754240
PB		 1117 type = TREE_VALUE (typelist);
1118 parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
6de9cd9a 1119
1d754240
PB		 1120 DECL_CONTEXT (parm) = fndecl;
1121 DECL_ARG_TYPE (parm) = type;
1122 TREE_READONLY (parm) = 1;
1123 gfc_finish_decl (parm, NULL_TREE);
6de9cd9a 1124
1d754240
PB		 1125 arglist = chainon (arglist, parm);
1126 typelist = TREE_CHAIN (typelist);
6de9cd9a 1127
1d754240
PB		 1128 if (sym->ts.type == BT_CHARACTER)
1129 {
1130 gfc_allocate_lang_decl (parm);
6de9cd9a 1131
1d754240
PB		 1132 /* Length of character result. */
1133 type = TREE_VALUE (typelist);
1134 assert (type == gfc_strlen_type_node);
6de9cd9a 1135
1d754240
PB		 1136 length = build_decl (PARM_DECL,
1137 get_identifier (".__result"),
1138 type);
1139 if (!sym->ts.cl->length)
1140 {
1141 sym->ts.cl->backend_decl = length;
1142 TREE_USED (length) = 1;
6de9cd9a 1143 }
1d754240
PB		 1144 assert (TREE_CODE (length) == PARM_DECL);
1145 arglist = chainon (arglist, length);
1146 typelist = TREE_CHAIN (typelist);
1147 DECL_CONTEXT (length) = fndecl;
1148 DECL_ARG_TYPE (length) = type;
1149 TREE_READONLY (length) = 1;
1150 gfc_finish_decl (length, NULL_TREE);
6de9cd9a 1151 }
1d754240 1152 }
6de9cd9a 1153
1d754240
PB		 1154 for (f = sym->formal; f; f = f->next)
1155 {
1156 if (f->sym != NULL) /* ignore alternate returns. */
6de9cd9a 1157 {
1d754240 1158 length = NULL_TREE;
6de9cd9a 1159
1d754240 1160 type = TREE_VALUE (typelist);
6de9cd9a 1161
1d754240
PB		 1162 /* Build a the argument declaration. */
1163 parm = build_decl (PARM_DECL,
1164 gfc_sym_identifier (f->sym), type);
6de9cd9a 1165
1d754240
PB		 1166 /* Fill in arg stuff. */
1167 DECL_CONTEXT (parm) = fndecl;
1168 DECL_ARG_TYPE (parm) = type;
1169 DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
1170 /* All implementation args are read-only. */
1171 TREE_READONLY (parm) = 1;
6de9cd9a 1172
1d754240 1173 gfc_finish_decl (parm, NULL_TREE);
6de9cd9a 1174
1d754240 1175 f->sym->backend_decl = parm;
6de9cd9a 1176
1d754240
PB		 1177 arglist = chainon (arglist, parm);
1178 typelist = TREE_CHAIN (typelist);
1179 }
1180 }
6de9cd9a 1181
1d754240
PB		 1182 /* Add the hidden string length parameters. */
1183 parm = arglist;
1184 for (f = sym->formal; f; f = f->next)
1185 {
1186 char name[GFC_MAX_SYMBOL_LEN + 2];
1187 /* Ignore alternate returns. */
1188 if (f->sym == NULL)
1189 continue;
6de9cd9a 1190
1d754240
PB		 1191 if (f->sym->ts.type != BT_CHARACTER)
1192 continue;
6de9cd9a 1193
1d754240
PB		 1194 parm = f->sym->backend_decl;
1195 type = TREE_VALUE (typelist);
1196 assert (type == gfc_strlen_type_node);
6de9cd9a 1197
1d754240
PB		 1198 strcpy (&name[1], f->sym->name);
1199 name[0] = '_';
1200 length = build_decl (PARM_DECL, get_identifier (name), type);
6de9cd9a 1201
1d754240
PB		 1202 arglist = chainon (arglist, length);
1203 DECL_CONTEXT (length) = fndecl;
1204 DECL_ARG_TYPE (length) = type;
1205 TREE_READONLY (length) = 1;
1206 gfc_finish_decl (length, NULL_TREE);
6de9cd9a 1207
1d754240 1208 /* TODO: Check string lengths when -fbounds-check. */
6de9cd9a 1209
1d754240
PB		 1210 /* Use the passed value for assumed length variables. */
1211 if (!f->sym->ts.cl->length)
1212 {
1213 TREE_USED (length) = 1;
1214 if (!f->sym->ts.cl->backend_decl)
1215 f->sym->ts.cl->backend_decl = length;
1216 else
6de9cd9a 1217 {
1d754240
PB		 1218 /* there is already another variable using this
1219 gfc_charlen node, build a new one for this variable
1220 and chain it into the list of gfc_charlens.
1221 This happens for e.g. in the case
1222 CHARACTER(*)::c1,c2
1223 since CHARACTER declarations on the same line share
1224 the same gfc_charlen node. */
1225 gfc_charlen *cl;
1226
1227 cl = gfc_get_charlen ();
1228 cl->backend_decl = length;
1229 cl->next = f->sym->ts.cl->next;
1230 f->sym->ts.cl->next = cl;
1231 f->sym->ts.cl = cl;
6de9cd9a 1232 }
6de9cd9a
DN		 1233 }
1234
1d754240
PB		 1235 parm = TREE_CHAIN (parm);
1236 typelist = TREE_CHAIN (typelist);
6de9cd9a 1237 }
1d754240
PB		 1238
1239 assert (TREE_VALUE (typelist) == void_type_node);
1240 DECL_ARGUMENTS (fndecl) = arglist;
3d79abbd 1241}
1d754240 1242
1d754240 1243
3d79abbd
PB		 1244/* Finalize DECL and all nested functions with cgraph. */
1245
1246static void
1247gfc_finalize (tree decl)
1248{
1249 struct cgraph_node *cgn;
1250
1251 cgn = cgraph_node (decl);
1252 for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
1253 gfc_finalize (cgn->decl);
1254
1255 cgraph_finalize_function (decl, false);
6de9cd9a
DN		 1256}
1257
1258
3d79abbd
PB		 1259/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
1260
1261static void
1262gfc_gimplify_function (tree fndecl)
1263{
1264 struct cgraph_node *cgn;
1265
1266 gimplify_function_tree (fndecl);
1267 dump_function (TDI_generic, fndecl);
1268
1269 /* Convert all nested functions to GIMPLE now. We do things in this order
1270 so that items like VLA sizes are expanded properly in the context of the
1271 correct function. */
1272 cgn = cgraph_node (fndecl);
1273 for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1274 gfc_gimplify_function (cgn->decl);
1275}
1276
1277
1278/* Do the setup necessary before generating the body of a function. */
1279
1280static void
1281trans_function_start (gfc_symbol * sym)
1282{
1283 tree fndecl;
1284
1285 fndecl = sym->backend_decl;
1286
1287 /* let GCC know the current scope is this function */
1288 current_function_decl = fndecl;
1289
1290 /* Let the world know what e're about to do. */
1291 announce_function (fndecl);
1292
1293 if (DECL_CONTEXT (fndecl) == NULL_TREE)
1294 {
1295 /* create RTL for function declaration */
1296 rest_of_decl_compilation (fndecl, 1, 0);
1297 }
1298
1299 /* create RTL for function definition */
1300 make_decl_rtl (fndecl);
1301
1302 /* Set the line and filename. sym->decalred_at seems to point to the
1303 last statement for subroutines, but it'll do for now. */
1304 gfc_set_backend_locus (&sym->declared_at);
1305
1306 init_function_start (fndecl);
1307
1308 /* Even though we're inside a function body, we still don't want to
1309 call expand_expr to calculate the size of a variable-sized array.
1310 We haven't necessarily assigned RTL to all variables yet, so it's
1311 not safe to try to expand expressions involving them. */
1312 cfun->x_dont_save_pending_sizes_p = 1;
1313
1314 /* function.c requires a push at the start of the function */
1315 pushlevel (0);
1316}
1317
1318/* Create thunks for alternate entry points. */
1319
1320static void
1321build_entry_thunks (gfc_namespace * ns)
1322{
1323 gfc_formal_arglist *formal;
1324 gfc_formal_arglist *thunk_formal;
1325 gfc_entry_list *el;
1326 gfc_symbol *thunk_sym;
1327 stmtblock_t body;
1328 tree thunk_fndecl;
1329 tree args;
1330 tree string_args;
1331 tree tmp;
1332
1333 /* This should always be a toplevel function. */
1334 assert (current_function_decl == NULL_TREE);
1335
1336 /* Remeber the master function argument decls. */
1337 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1338 {
1339 }
1340
1341 for (el = ns->entries; el; el = el->next)
1342 {
1343 thunk_sym = el->sym;
1344
1345 build_function_decl (thunk_sym);
1346 create_function_arglist (thunk_sym);
1347
1348 trans_function_start (thunk_sym);
1349
1350 thunk_fndecl = thunk_sym->backend_decl;
1351
1352 gfc_start_block (&body);
1353
1354 /* Pass extra parater identifying this entry point. */
1355 tmp = build_int_cst (gfc_array_index_type, el->id, 0);
1356 args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1357 string_args = NULL_TREE;
1358
1359 /* TODO: Pass return by reference parameters. */
1360 if (ns->proc_name->attr.function)
1361 gfc_todo_error ("Functons with multiple entry points");
1362
1363 for (formal = ns->proc_name->formal; formal; formal = formal->next)
1364 {
1365 /* We don't have a clever way of identifying arguments, so resort to
1366 a brute-force search. */
1367 for (thunk_formal = thunk_sym->formal;
1368 thunk_formal;
1369 thunk_formal = thunk_formal->next)
1370 {
1371 if (thunk_formal->sym == formal->sym)
1372 break;
1373 }
1374
1375 if (thunk_formal)
1376 {
1377 /* Pass the argument. */
1378 args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1379 args);
1380 if (formal->sym->ts.type == BT_CHARACTER)
1381 {
1382 tmp = thunk_formal->sym->ts.cl->backend_decl;
1383 string_args = tree_cons (NULL_TREE, tmp, string_args);
1384 }
1385 }
1386 else
1387 {
1388 /* Pass NULL for a missing argument. */
1389 args = tree_cons (NULL_TREE, null_pointer_node, args);
1390 if (formal->sym->ts.type == BT_CHARACTER)
1391 {
1392 tmp = convert (gfc_strlen_type_node, integer_zero_node);
1393 string_args = tree_cons (NULL_TREE, tmp, string_args);
1394 }
1395 }
1396 }
1397
1398 /* Call the master function. */
1399 args = nreverse (args);
1400 args = chainon (args, nreverse (string_args));
1401 tmp = ns->proc_name->backend_decl;
1402 tmp = gfc_build_function_call (tmp, args);
1403 /* TODO: function return value. */
1404 gfc_add_expr_to_block (&body, tmp);
1405
1406 /* Finish off this function and send it for code generation. */
1407 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1408 poplevel (1, 0, 1);
1409 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1410
1411 /* Output the GENERIC tree. */
1412 dump_function (TDI_original, thunk_fndecl);
1413
1414 /* Store the end of the function, so that we get good line number
1415 info for the epilogue. */
1416 cfun->function_end_locus = input_location;
1417
1418 /* We're leaving the context of this function, so zap cfun.
1419 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1420 tree_rest_of_compilation. */
1421 cfun = NULL;
1422
1423 current_function_decl = NULL_TREE;
1424
1425 gfc_gimplify_function (thunk_fndecl);
1426 lower_nested_functions (thunk_fndecl);
1427 gfc_finalize (thunk_fndecl);
1428
1429 /* We share the symbols in the formal argument list with other entry
1430 points and the master function. Clear them so that they are
1431 recreated for each function. */
1432 for (formal = thunk_sym->formal; formal; formal = formal->next)
1433 {
1434 formal->sym->backend_decl = NULL_TREE;
1435 if (formal->sym->ts.type == BT_CHARACTER)
1436 formal->sym->ts.cl->backend_decl = NULL_TREE;
1437 }
1438 }
1439}
1440
1441
1442/* Create a decl for a function, and create any thunks for alternate entry
1443 points. */
1444
1445void
1446gfc_create_function_decl (gfc_namespace * ns)
1447{
1448 /* Create a declaration for the master function. */
1449 build_function_decl (ns->proc_name);
1450
1451 /* Compile teh entry thunks. */
1452 if (ns->entries)
1453 build_entry_thunks (ns);
1454
1455 /* Now create the read argument list. */
1456 create_function_arglist (ns->proc_name);
1457}
1458
6de9cd9a
DN		 1459/* Return the decl used to hold the function return value. */
1460
1461tree
1462gfc_get_fake_result_decl (gfc_symbol * sym)
1463{
1464 tree decl;
1465 tree length;
1466
1467 char name[GFC_MAX_SYMBOL_LEN + 10];
1468
1469 if (current_fake_result_decl != NULL_TREE)
1470 return current_fake_result_decl;
1471
1472 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1473 sym is NULL. */
1474 if (!sym)
1475 return NULL_TREE;
1476
1477 if (sym->ts.type == BT_CHARACTER
1478 && !sym->ts.cl->backend_decl)
1479 {
1480 length = gfc_create_string_length (sym);
1481 gfc_finish_var_decl (length, sym);
1482 }
1483
1484 if (gfc_return_by_reference (sym))
1485 {
1486 decl = DECL_ARGUMENTS (sym->backend_decl);
1487
1488 TREE_USED (decl) = 1;
1489 if (sym->as)
1490 decl = gfc_build_dummy_array_decl (sym, decl);
1491 }
1492 else
1493 {
1494 sprintf (name, "__result_%.20s",
1495 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1496
1497 decl = build_decl (VAR_DECL, get_identifier (name),
1498 TREE_TYPE (TREE_TYPE (current_function_decl)));
1499
1500 DECL_ARTIFICIAL (decl) = 1;
1501 DECL_EXTERNAL (decl) = 0;
1502 TREE_PUBLIC (decl) = 0;
1503 TREE_USED (decl) = 1;
1504
1505 layout_decl (decl, 0);
1506
1507 gfc_add_decl_to_function (decl);
1508 }
1509
1510 current_fake_result_decl = decl;
1511
1512 return decl;
1513}
1514
1515
1516/* Builds a function decl. The remaining parameters are the types of the
1517 function arguments. Negative nargs indicates a varargs function. */
1518
1519tree
1520gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1521{
1522 tree arglist;
1523 tree argtype;
1524 tree fntype;
1525 tree fndecl;
1526 va_list p;
1527 int n;
1528
1529 /* Library functions must be declared with global scope. */
1530 assert (current_function_decl == NULL_TREE);
1531
1532 va_start (p, nargs);
1533
1534
1535 /* Create a list of the argument types. */
1536 for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1537 {
1538 argtype = va_arg (p, tree);
1539 arglist = gfc_chainon_list (arglist, argtype);
1540 }
1541
1542 if (nargs >= 0)
1543 {
1544 /* Terminate the list. */
1545 arglist = gfc_chainon_list (arglist, void_type_node);
1546 }
1547
1548 /* Build the function type and decl. */
1549 fntype = build_function_type (rettype, arglist);
1550 fndecl = build_decl (FUNCTION_DECL, name, fntype);
1551
1552 /* Mark this decl as external. */
1553 DECL_EXTERNAL (fndecl) = 1;
1554 TREE_PUBLIC (fndecl) = 1;
1555
1556 va_end (p);
1557
1558 pushdecl (fndecl);
1559
0e6df31e 1560 rest_of_decl_compilation (fndecl, 1, 0);
6de9cd9a
DN		 1561
1562 return fndecl;
1563}
1564
1565static void
1566gfc_build_intrinsic_function_decls (void)
1567{
1568 /* String functions. */
1569 gfor_fndecl_copy_string =
1570 gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1571 void_type_node,
1572 4,
1573 gfc_strlen_type_node, pchar_type_node,
1574 gfc_strlen_type_node, pchar_type_node);
1575
1576 gfor_fndecl_compare_string =
1577 gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1578 gfc_int4_type_node,
1579 4,
1580 gfc_strlen_type_node, pchar_type_node,
1581 gfc_strlen_type_node, pchar_type_node);
1582
1583 gfor_fndecl_concat_string =
1584 gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1585 void_type_node,
1586 6,
1587 gfc_strlen_type_node, pchar_type_node,
1588 gfc_strlen_type_node, pchar_type_node,
1589 gfc_strlen_type_node, pchar_type_node);
1590
1591 gfor_fndecl_string_len_trim =
1592 gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1593 gfc_int4_type_node,
1594 2, gfc_strlen_type_node,
1595 pchar_type_node);
1596
1597 gfor_fndecl_string_index =
1598 gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1599 gfc_int4_type_node,
1600 5, gfc_strlen_type_node, pchar_type_node,
1601 gfc_strlen_type_node, pchar_type_node,
1602 gfc_logical4_type_node);
1603
1604 gfor_fndecl_string_scan =
1605 gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1606 gfc_int4_type_node,
1607 5, gfc_strlen_type_node, pchar_type_node,
1608 gfc_strlen_type_node, pchar_type_node,
1609 gfc_logical4_type_node);
1610
1611 gfor_fndecl_string_verify =
1612 gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1613 gfc_int4_type_node,
1614 5, gfc_strlen_type_node, pchar_type_node,
1615 gfc_strlen_type_node, pchar_type_node,
1616 gfc_logical4_type_node);
1617
1618 gfor_fndecl_string_trim =
1619 gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1620 void_type_node,
1621 4,
1622 build_pointer_type (gfc_strlen_type_node),
1623 ppvoid_type_node,
1624 gfc_strlen_type_node,
1625 pchar_type_node);
1626
1627 gfor_fndecl_string_repeat =
1628 gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1629 void_type_node,
1630 4,
1631 pchar_type_node,
1632 gfc_strlen_type_node,
1633 pchar_type_node,
1634 gfc_int4_type_node);
1635
1636 gfor_fndecl_adjustl =
1637 gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1638 void_type_node,
1639 3,
1640 pchar_type_node,
1641 gfc_strlen_type_node, pchar_type_node);
1642
1643 gfor_fndecl_adjustr =
1644 gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1645 void_type_node,
1646 3,
1647 pchar_type_node,
1648 gfc_strlen_type_node, pchar_type_node);
1649
1650 gfor_fndecl_si_kind =
1651 gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1652 gfc_int4_type_node,
1653 1,
1654 pvoid_type_node);
1655
1656 gfor_fndecl_sr_kind =
1657 gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1658 gfc_int4_type_node,
1659 2, pvoid_type_node,
1660 pvoid_type_node);
1661
1662
1663 /* Power functions. */
5b200ac2
FW		 1664 {
1665 tree type;
1666 tree itype;
1667 int kind;
1668 int ikind;
1669 static int kinds[2] = {4, 8};
1670 char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1671
1672 for (ikind=0; ikind < 2; ikind++)
1673 {
1674 itype = gfc_get_int_type (kinds[ikind]);
1675 for (kind = 0; kind < 2; kind ++)
1676 {
1677 type = gfc_get_int_type (kinds[kind]);
1678 sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1679 gfor_fndecl_math_powi[kind][ikind].integer =
1680 gfc_build_library_function_decl (get_identifier (name),
1681 type, 2, type, itype);
1682
1683 type = gfc_get_real_type (kinds[kind]);
1684 sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1685 gfor_fndecl_math_powi[kind][ikind].real =
1686 gfc_build_library_function_decl (get_identifier (name),
1687 type, 2, type, itype);
1688
1689 type = gfc_get_complex_type (kinds[kind]);
1690 sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1691 gfor_fndecl_math_powi[kind][ikind].cmplx =
1692 gfc_build_library_function_decl (get_identifier (name),
1693 type, 2, type, itype);
1694 }
1695 }
1696 }
1697
6de9cd9a
DN		 1698 gfor_fndecl_math_cpowf =
1699 gfc_build_library_function_decl (get_identifier ("cpowf"),
1700 gfc_complex4_type_node,
1701 1, gfc_complex4_type_node);
1702 gfor_fndecl_math_cpow =
1703 gfc_build_library_function_decl (get_identifier ("cpow"),
1704 gfc_complex8_type_node,
1705 1, gfc_complex8_type_node);
6de9cd9a
DN		 1706 gfor_fndecl_math_ishftc4 =
1707 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1708 gfc_int4_type_node,
1709 3, gfc_int4_type_node,
1710 gfc_int4_type_node, gfc_int4_type_node);
1711 gfor_fndecl_math_ishftc8 =
1712 gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1713 gfc_int8_type_node,
1714 3, gfc_int8_type_node,
1715 gfc_int8_type_node, gfc_int8_type_node);
1716 gfor_fndecl_math_exponent4 =
1717 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1718 gfc_int4_type_node,
1719 1, gfc_real4_type_node);
1720 gfor_fndecl_math_exponent8 =
1721 gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1722 gfc_int4_type_node,
1723 1, gfc_real8_type_node);
1724
1725 /* Other functions. */
1726 gfor_fndecl_size0 =
1727 gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1728 gfc_array_index_type,
1729 1, pvoid_type_node);
1730 gfor_fndecl_size1 =
1731 gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1732 gfc_array_index_type,
1733 2, pvoid_type_node,
1734 gfc_array_index_type);
b41b2534
JB		 1735
1736 gfor_fndecl_iargc =
1737 gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1738 gfc_int4_type_node,
1739 0);
6de9cd9a
DN		 1740}
1741
1742
1743/* Make prototypes for runtime library functions. */
1744
1745void
1746gfc_build_builtin_function_decls (void)
1747{
1748 gfor_fndecl_internal_malloc =
1749 gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1750 pvoid_type_node, 1, gfc_int4_type_node);
1751
1752 gfor_fndecl_internal_malloc64 =
1753 gfc_build_library_function_decl (get_identifier
1754 (PREFIX("internal_malloc64")),
1755 pvoid_type_node, 1, gfc_int8_type_node);
1756
1757 gfor_fndecl_internal_free =
1758 gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1759 void_type_node, 1, pvoid_type_node);
1760
1761 gfor_fndecl_allocate =
1762 gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1763 void_type_node, 2, ppvoid_type_node,
1764 gfc_int4_type_node);
1765
1766 gfor_fndecl_allocate64 =
1767 gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1768 void_type_node, 2, ppvoid_type_node,
1769 gfc_int8_type_node);
1770
1771 gfor_fndecl_deallocate =
1772 gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1773 void_type_node, 1, ppvoid_type_node);
1774
1775 gfor_fndecl_stop_numeric =
1776 gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1777 void_type_node, 1, gfc_int4_type_node);
1778
1779 gfor_fndecl_stop_string =
1780 gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1781 void_type_node, 2, pchar_type_node,
1782 gfc_int4_type_node);
1783
1784 gfor_fndecl_pause_numeric =
1785 gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1786 void_type_node, 1, gfc_int4_type_node);
1787
1788 gfor_fndecl_pause_string =
1789 gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1790 void_type_node, 2, pchar_type_node,
1791 gfc_int4_type_node);
1792
1793 gfor_fndecl_select_string =
1794 gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1795 pvoid_type_node, 0);
1796
1797 gfor_fndecl_runtime_error =
1798 gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1799 void_type_node,
1800 3,
1801 pchar_type_node, pchar_type_node,
1802 gfc_int4_type_node);
1803
1804 gfor_fndecl_in_pack = gfc_build_library_function_decl (
1805 get_identifier (PREFIX("internal_pack")),
1806 pvoid_type_node, 1, pvoid_type_node);
1807
1808 gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1809 get_identifier (PREFIX("internal_unpack")),
1810 pvoid_type_node, 1, pvoid_type_node);
1811
1812 gfor_fndecl_associated =
1813 gfc_build_library_function_decl (
1814 get_identifier (PREFIX("associated")),
1815 gfc_logical4_type_node,
1816 2,
1817 ppvoid_type_node,
1818 ppvoid_type_node);
1819
1820 gfc_build_intrinsic_function_decls ();
1821 gfc_build_intrinsic_lib_fndecls ();
1822 gfc_build_io_library_fndecls ();
1823}
1824
1825
1826/* Exaluate the length of dummy character variables. */
1827
1828static tree
1829gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1830{
1831 stmtblock_t body;
1832
1833 gfc_finish_decl (cl->backend_decl, NULL_TREE);
1834
1835 gfc_start_block (&body);
1836
1837 /* Evaluate the string length expression. */
1838 gfc_trans_init_string_length (cl, &body);
1839
1840 gfc_add_expr_to_block (&body, fnbody);
1841 return gfc_finish_block (&body);
1842}
1843
1844
1845/* Allocate and cleanup an automatic character variable. */
1846
1847static tree
1848gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1849{
1850 stmtblock_t body;
1851 tree decl;
6de9cd9a
DN		 1852 tree tmp;
1853
1854 assert (sym->backend_decl);
1855 assert (sym->ts.cl && sym->ts.cl->length);
1856
1857 gfc_start_block (&body);
1858
1859 /* Evaluate the string length expression. */
1860 gfc_trans_init_string_length (sym->ts.cl, &body);
1861
1862 decl = sym->backend_decl;
1863
1a186ec5 1864 /* Emit a DECL_EXPR for this variable, which will cause the
4ab2db93 1865 gimplifier to allocate storage, and all that good stuff. */
1a186ec5 1866 tmp = build (DECL_EXPR, TREE_TYPE (decl), decl);
6de9cd9a 1867 gfc_add_expr_to_block (&body, tmp);
1a186ec5 1868
6de9cd9a
DN		 1869 gfc_add_expr_to_block (&body, fnbody);
1870 return gfc_finish_block (&body);
1871}
1872
1873
1874/* Generate function entry and exit code, and add it to the function body.
1875 This includes:
1876 Allocation and initialisation of array variables.
1877 Allocation of character string variables.
1878 Initialization and possibly repacking of dummy arrays. */
1879
1880static tree
1881gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
1882{
1883 locus loc;
1884 gfc_symbol *sym;
1885
1886 /* Deal with implicit return variables. Explicit return variables will
1887 already have been added. */
1888 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
1889 {
1890 if (!current_fake_result_decl)
1891 {
1892 warning ("Function does not return a value");
1893 return fnbody;
1894 }
1895
1896 if (proc_sym->as)
1897 {
1898 fnbody = gfc_trans_dummy_array_bias (proc_sym,
1899 current_fake_result_decl,
1900 fnbody);
1901 }
1902 else if (proc_sym->ts.type == BT_CHARACTER)
1903 {
1904 if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
1905 fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
1906 }
1907 else
1908 gfc_todo_error ("Deferred non-array return by reference");
1909 }
1910
1911 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
1912 {
1913 if (sym->attr.dimension)
1914 {
1915 switch (sym->as->type)
1916 {
1917 case AS_EXPLICIT:
1918 if (sym->attr.dummy || sym->attr.result)
1919 fnbody =
1920 gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
1921 else if (sym->attr.pointer || sym->attr.allocatable)
1922 {
1923 if (TREE_STATIC (sym->backend_decl))
1924 gfc_trans_static_array_pointer (sym);
1925 else
1926 fnbody = gfc_trans_deferred_array (sym, fnbody);
1927 }
1928 else
1929 {
1930 gfc_get_backend_locus (&loc);
1931 gfc_set_backend_locus (&sym->declared_at);
1932 fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
1933 sym, fnbody);
1934 gfc_set_backend_locus (&loc);
1935 }
1936 break;
1937
1938 case AS_ASSUMED_SIZE:
1939 /* Must be a dummy parameter. */
1940 assert (sym->attr.dummy);
1941
1942 /* We should always pass assumed size arrays the g77 way. */
6de9cd9a
DN		 1943 fnbody = gfc_trans_g77_array (sym, fnbody);
1944 break;
1945
1946 case AS_ASSUMED_SHAPE:
1947 /* Must be a dummy parameter. */
1948 assert (sym->attr.dummy);
1949
1950 fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
1951 fnbody);
1952 break;
1953
1954 case AS_DEFERRED:
1955 fnbody = gfc_trans_deferred_array (sym, fnbody);
1956 break;
1957
1958 default:
1959 abort ();
1960 }
1961 }
1962 else if (sym->ts.type == BT_CHARACTER)
1963 {
1964 gfc_get_backend_locus (&loc);
1965 gfc_set_backend_locus (&sym->declared_at);
1966 if (sym->attr.dummy || sym->attr.result)
1967 fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
1968 else
1969 fnbody = gfc_trans_auto_character_variable (sym, fnbody);
1970 gfc_set_backend_locus (&loc);
1971 }
1972 else
1973 abort ();
1974 }
1975
1976 return fnbody;
1977}
1978
1979
1980/* Output an initialized decl for a module variable. */
1981
1982static void
1983gfc_create_module_variable (gfc_symbol * sym)
1984{
1985 tree decl;
6de9cd9a
DN		 1986
1987 /* Only output symbols from this module. */
1988 if (sym->ns != module_namespace)
1989 {
1990 /* I don't think this should ever happen. */
1991 internal_error ("module symbol %s in wrong namespace", sym->name);
1992 }
1993
6de9cd9a
DN		 1994 /* Only output variables and array valued parametes. */
1995 if (sym->attr.flavor != FL_VARIABLE
1996 && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
1997 return;
1998
9cbf8b41
TS		 1999 /* Don't generate variables from other modules. Variables from
2000 COMMONs will already have been generated. */
2001 if (sym->attr.use_assoc || sym->attr.in_common)
6de9cd9a
DN		 2002 return;
2003
2004 if (sym->backend_decl)
2005 internal_error ("backend decl for module variable %s already exists",
2006 sym->name);
2007
2008 /* We always want module variables to be created. */
2009 sym->attr.referenced = 1;
2010 /* Create the decl. */
2011 decl = gfc_get_symbol_decl (sym);
2012
6de9cd9a
DN		 2013 /* Create the variable. */
2014 pushdecl (decl);
0e6df31e 2015 rest_of_decl_compilation (decl, 1, 0);
6de9cd9a
DN		 2016
2017 /* Also add length of strings. */
2018 if (sym->ts.type == BT_CHARACTER)
2019 {
2020 tree length;
2021
2022 length = sym->ts.cl->backend_decl;
2023 if (!INTEGER_CST_P (length))
2024 {
2025 pushdecl (length);
0e6df31e 2026 rest_of_decl_compilation (length, 1, 0);
6de9cd9a
DN		 2027 }
2028 }
2029}
2030
2031
2032/* Generate all the required code for module variables. */
2033
2034void
2035gfc_generate_module_vars (gfc_namespace * ns)
2036{
2037 module_namespace = ns;
2038
472ca416 2039 /* Check if the frontend left the namespace in a reasonable state. */
6de9cd9a
DN		 2040 assert (ns->proc_name && !ns->proc_name->tlink);
2041
9cbf8b41
TS		 2042 /* Generate COMMON blocks. */
2043 gfc_trans_common (ns);
2044
472ca416 2045 /* Create decls for all the module variables. */
6de9cd9a
DN		 2046 gfc_traverse_ns (ns, gfc_create_module_variable);
2047}
2048
2049static void
2050gfc_generate_contained_functions (gfc_namespace * parent)
2051{
2052 gfc_namespace *ns;
2053
2054 /* We create all the prototypes before generating any code. */
2055 for (ns = parent->contained; ns; ns = ns->sibling)
2056 {
2057 /* Skip namespaces from used modules. */
2058 if (ns->parent != parent)
2059 continue;
2060
3d79abbd 2061 gfc_create_function_decl (ns);
6de9cd9a
DN		 2062 }
2063
2064 for (ns = parent->contained; ns; ns = ns->sibling)
2065 {
2066 /* Skip namespaces from used modules. */
2067 if (ns->parent != parent)
2068 continue;
2069
2070 gfc_generate_function_code (ns);
2071 }
2072}
2073
2074
2075/* Generate decls for all local variables. We do this to ensure correct
2076 handling of expressions which only appear in the specification of
2077 other functions. */
2078
2079static void
2080generate_local_decl (gfc_symbol * sym)
2081{
2082 if (sym->attr.flavor == FL_VARIABLE)
2083 {
6de9cd9a
DN		 2084 if (sym->attr.referenced)
2085 gfc_get_symbol_decl (sym);
2086 else if (sym->attr.dummy)
2087 {
2088 if (warn_unused_parameter)
2089 warning ("unused parameter `%s'", sym->name);
2090 }
ce8fc97b 2091 /* warn for unused variables, but not if they're inside a common
ce738b86
TS		 2092 block or are use_associated. */
2093 else if (warn_unused_variable
2094 && !(sym->attr.in_common || sym->attr.use_assoc))
2095 warning ("unused variable `%s'", sym->name);
6de9cd9a
DN		 2096 }
2097}
2098
2099static void
2100generate_local_vars (gfc_namespace * ns)
2101{
2102 gfc_traverse_ns (ns, generate_local_decl);
2103}
2104
2105
3d79abbd
PB		 2106/* Generate a switch statement to jump to the correct entry point. Also
2107 creates the label decls for the entry points. */
6de9cd9a 2108
3d79abbd
PB		 2109static tree
2110gfc_trans_entry_master_switch (gfc_entry_list * el)
6de9cd9a 2111{
3d79abbd
PB		 2112 stmtblock_t block;
2113 tree label;
2114 tree tmp;
2115 tree val;
6de9cd9a 2116
3d79abbd
PB		 2117 gfc_init_block (&block);
2118 for (; el; el = el->next)
2119 {
2120 /* Add the case label. */
2121 label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2122 DECL_CONTEXT (label) = current_function_decl;
2123 val = build_int_cst (gfc_array_index_type, el->id, 0);
2124 tmp = build_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2125 gfc_add_expr_to_block (&block, tmp);
2126
2127 /* And jump to the actual entry point. */
2128 label = gfc_build_label_decl (NULL_TREE);
2129 TREE_USED (label) = 1;
2130 DECL_CONTEXT (label) = current_function_decl;
2131 tmp = build1_v (GOTO_EXPR, label);
2132 gfc_add_expr_to_block (&block, tmp);
2133
2134 /* Save the label decl. */
2135 el->label = label;
2136 }
2137 tmp = gfc_finish_block (&block);
2138 /* The first argument selects the entry point. */
2139 val = DECL_ARGUMENTS (current_function_decl);
2140 tmp = build_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2141 return tmp;
6de9cd9a
DN		 2142}
2143
44de5aeb 2144
6de9cd9a
DN		 2145/* Generate code for a function. */
2146
2147void
2148gfc_generate_function_code (gfc_namespace * ns)
2149{
2150 tree fndecl;
2151 tree old_context;
2152 tree decl;
2153 tree tmp;
2154 stmtblock_t block;
2155 stmtblock_t body;
2156 tree result;
2157 gfc_symbol *sym;
2158
2159 sym = ns->proc_name;
3d79abbd 2160
6de9cd9a
DN		 2161 /* Check that the frontend isn't still using this. */
2162 assert (sym->tlink == NULL);
6de9cd9a
DN		 2163 sym->tlink = sym;
2164
2165 /* Create the declaration for functions with global scope. */
2166 if (!sym->backend_decl)
3d79abbd 2167 gfc_create_function_decl (ns);
6de9cd9a
DN		 2168
2169 fndecl = sym->backend_decl;
2170 old_context = current_function_decl;
2171
2172 if (old_context)
2173 {
2174 push_function_context ();
2175 saved_parent_function_decls = saved_function_decls;
2176 saved_function_decls = NULL_TREE;
2177 }
2178
3d79abbd 2179 trans_function_start (sym);
6de9cd9a
DN		 2180
2181 /* Will be created as needed. */
2182 current_fake_result_decl = NULL_TREE;
2183
6de9cd9a
DN		 2184 gfc_start_block (&block);
2185
2186 gfc_generate_contained_functions (ns);
2187
2188 /* Translate COMMON blocks. */
2189 gfc_trans_common (ns);
2190
2191 generate_local_vars (ns);
2192
2193 current_function_return_label = NULL;
2194
2195 /* Now generate the code for the body of this function. */
2196 gfc_init_block (&body);
2197
2198 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2199 && sym->attr.subroutine)
2200 {
2201 tree alternate_return;
2202 alternate_return = gfc_get_fake_result_decl (sym);
2203 gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2204 }
2205
3d79abbd
PB		 2206 if (ns->entries)
2207 {
2208 /* Jump to the correct entry point. */
2209 tmp = gfc_trans_entry_master_switch (ns->entries);
2210 gfc_add_expr_to_block (&body, tmp);
2211 }
2212
6de9cd9a
DN		 2213 tmp = gfc_trans_code (ns->code);
2214 gfc_add_expr_to_block (&body, tmp);
2215
2216 /* Add a return label if needed. */
2217 if (current_function_return_label)
2218 {
2219 tmp = build1_v (LABEL_EXPR, current_function_return_label);
2220 gfc_add_expr_to_block (&body, tmp);
2221 }
2222
2223 tmp = gfc_finish_block (&body);
2224 /* Add code to create and cleanup arrays. */
2225 tmp = gfc_trans_deferred_vars (sym, tmp);
2226 gfc_add_expr_to_block (&block, tmp);
2227
2228 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2229 {
2230 if (sym->attr.subroutine ||sym == sym->result)
2231 {
2232 result = current_fake_result_decl;
2233 current_fake_result_decl = NULL_TREE;
2234 }
2235 else
2236 result = sym->result->backend_decl;
2237
2238 if (result == NULL_TREE)
2239 warning ("Function return value not set");
2240 else
2241 {
2242 /* Set the return value to the the dummy result variable. */
2243 tmp = build (MODIFY_EXPR, TREE_TYPE (result),
2244 DECL_RESULT (fndecl), result);
2245 tmp = build_v (RETURN_EXPR, tmp);
2246 gfc_add_expr_to_block (&block, tmp);
2247 }
2248 }
2249
2250 /* Add all the decls we created during processing. */
2251 decl = saved_function_decls;
2252 while (decl)
2253 {
2254 tree next;
2255
2256 next = TREE_CHAIN (decl);
2257 TREE_CHAIN (decl) = NULL_TREE;
2258 pushdecl (decl);
2259 decl = next;
2260 }
2261 saved_function_decls = NULL_TREE;
2262
2263 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2264
2265 /* Finish off this function and send it for code generation. */
2266 poplevel (1, 0, 1);
2267 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2268
2269 /* Output the GENERIC tree. */
2270 dump_function (TDI_original, fndecl);
2271
2272 /* Store the end of the function, so that we get good line number
2273 info for the epilogue. */
2274 cfun->function_end_locus = input_location;
2275
2276 /* We're leaving the context of this function, so zap cfun.
2277 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2278 tree_rest_of_compilation. */
2279 cfun = NULL;
2280
2281 if (old_context)
2282 {
2283 pop_function_context ();
2284 saved_function_decls = saved_parent_function_decls;
2285 }
2286 current_function_decl = old_context;
2287
2288 if (decl_function_context (fndecl))
44de5aeb
RK		 2289 /* Register this function with cgraph just far enough to get it
2290 added to our parent's nested function list. */
2291 (void) cgraph_node (fndecl);
6de9cd9a
DN		 2292 else
2293 {
44de5aeb
RK		 2294 gfc_gimplify_function (fndecl);
2295 lower_nested_functions (fndecl);
6de9cd9a
DN		 2296 gfc_finalize (fndecl);
2297 }
2298}
2299
6de9cd9a
DN		 2300void
2301gfc_generate_constructors (void)
2302{
2303 if (gfc_static_ctors != NULL_TREE)
2304 abort ();
2305#if 0
2306 tree fnname;
2307 tree type;
2308 tree fndecl;
2309 tree decl;
2310 tree tmp;
2311
2312 if (gfc_static_ctors == NULL_TREE)
2313 return;
2314
2315 fnname = get_file_function_name ('I');
2316 type = build_function_type (void_type_node,
2317 gfc_chainon_list (NULL_TREE, void_type_node));
2318
2319 fndecl = build_decl (FUNCTION_DECL, fnname, type);
2320 TREE_PUBLIC (fndecl) = 1;
2321
2322 decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
b785f485
RH		 2323 DECL_ARTIFICIAL (decl) = 1;
2324 DECL_IGNORED_P (decl) = 1;
6de9cd9a
DN		 2325 DECL_CONTEXT (decl) = fndecl;
2326 DECL_RESULT (fndecl) = decl;
2327
2328 pushdecl (fndecl);
2329
2330 current_function_decl = fndecl;
2331
0e6df31e 2332 rest_of_decl_compilation (fndecl, 1, 0);
6de9cd9a 2333
0e6df31e 2334 make_decl_rtl (fndecl);
6de9cd9a
DN		 2335
2336 init_function_start (fndecl, input_filename, input_line);
2337
6de9cd9a
DN		 2338 pushlevel (0);
2339
2340 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2341 {
2342 tmp =
2343 gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2344 DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2345 }
2346
2347 poplevel (1, 0, 1);
2348
2349 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2350
2351 free_after_parsing (cfun);
2352 free_after_compilation (cfun);
2353
2354 tree_rest_of_compilation (fndecl, 0);
2355
2356 current_function_decl = NULL_TREE;
2357#endif
2358}
2359
2360#include "gt-fortran-trans-decl.h"
GNU Compiler Collection
This page took 0.39847 seconds and 5 git commands to generate.