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