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