]>
Commit | Line | Data |
---|---|---|
f36327db | 1 | /* gfortran backend interface |
ec378180 | 2 | Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, |
9fc4d79b | 3 | Inc. |
6de9cd9a DN |
4 | Contributed by Paul Brook. |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
10 | Software Foundation; either version 2, or (at your option) any later | |
11 | version. | |
6de9cd9a | 12 | |
9fc4d79b TS |
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
9fc4d79b TS |
19 | along with GCC; see the file COPYING. If not, write to the Free |
20 | Software Foundation, 59 Temple Place - Suite 330, Boston, MA | |
21 | 02111-1307, USA. */ | |
6de9cd9a DN |
22 | |
23 | /* f95-lang.c-- GCC backend interface stuff */ | |
24 | ||
25 | /* declare required prototypes: */ | |
26 | ||
27 | #include "config.h" | |
d22e4895 | 28 | #include "system.h" |
6de9cd9a DN |
29 | #include "ansidecl.h" |
30 | #include "system.h" | |
31 | #include "coretypes.h" | |
32 | #include "tree.h" | |
eadf906f | 33 | #include "tree-gimple.h" |
6de9cd9a DN |
34 | #include "flags.h" |
35 | #include "langhooks.h" | |
36 | #include "langhooks-def.h" | |
37 | #include "timevar.h" | |
38 | #include "tm.h" | |
39 | #include "function.h" | |
40 | #include "ggc.h" | |
41 | #include "toplev.h" | |
42 | #include "target.h" | |
43 | #include "debug.h" | |
44 | #include "diagnostic.h" | |
45 | #include "tree-dump.h" | |
46 | #include "cgraph.h" | |
47 | ||
48 | #include "gfortran.h" | |
49 | #include "trans.h" | |
50 | #include "trans-types.h" | |
51 | #include "trans-const.h" | |
52 | ||
6de9cd9a DN |
53 | /* Language-dependent contents of an identifier. */ |
54 | ||
55 | struct lang_identifier | |
56 | GTY(()) | |
57 | { | |
58 | struct tree_identifier common; | |
59 | }; | |
60 | ||
61 | /* The resulting tree type. */ | |
62 | ||
63 | union lang_tree_node | |
f88cf205 AP |
64 | GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), |
65 | chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)"))) | |
6de9cd9a DN |
66 | { |
67 | union tree_node GTY((tag ("0"), | |
68 | desc ("tree_node_structure (&%h)"))) generic; | |
69 | struct lang_identifier GTY((tag ("1"))) identifier; | |
70 | }; | |
71 | ||
72 | /* Save and restore the variables in this file and elsewhere | |
73 | that keep track of the progress of compilation of the current function. | |
74 | Used for nested functions. */ | |
75 | ||
76 | struct language_function | |
77 | GTY(()) | |
78 | { | |
79 | /* struct gfc_language_function base; */ | |
80 | tree named_labels; | |
81 | tree shadowed_labels; | |
82 | int returns_value; | |
83 | int returns_abnormally; | |
84 | int warn_about_return_type; | |
85 | int extern_inline; | |
86 | struct binding_level *binding_level; | |
87 | }; | |
88 | ||
89 | /* We don't have a lex/yacc lexer/parser, but toplev expects these to | |
90 | exist anyway. */ | |
91 | void yyerror (const char *str); | |
92 | int yylex (void); | |
93 | ||
94 | static void gfc_init_decl_processing (void); | |
95 | static void gfc_init_builtin_functions (void); | |
96 | ||
97 | /* Each front end provides its own. */ | |
98 | static bool gfc_init (void); | |
99 | static void gfc_finish (void); | |
100 | static void gfc_print_identifier (FILE *, tree, int); | |
101 | static bool gfc_mark_addressable (tree); | |
102 | void do_function_end (void); | |
103 | int global_bindings_p (void); | |
104 | void insert_block (tree); | |
9dcf6e73 | 105 | static void gfc_clear_binding_stack (void); |
6de9cd9a DN |
106 | static void gfc_be_parse_file (int); |
107 | static void gfc_expand_function (tree); | |
108 | ||
109 | #undef LANG_HOOKS_NAME | |
110 | #undef LANG_HOOKS_INIT | |
111 | #undef LANG_HOOKS_FINISH | |
112 | #undef LANG_HOOKS_INIT_OPTIONS | |
113 | #undef LANG_HOOKS_HANDLE_OPTION | |
114 | #undef LANG_HOOKS_POST_OPTIONS | |
115 | #undef LANG_HOOKS_PRINT_IDENTIFIER | |
116 | #undef LANG_HOOKS_PARSE_FILE | |
117 | #undef LANG_HOOKS_TRUTHVALUE_CONVERSION | |
118 | #undef LANG_HOOKS_MARK_ADDRESSABLE | |
119 | #undef LANG_HOOKS_TYPE_FOR_MODE | |
120 | #undef LANG_HOOKS_TYPE_FOR_SIZE | |
121 | #undef LANG_HOOKS_UNSIGNED_TYPE | |
122 | #undef LANG_HOOKS_SIGNED_TYPE | |
123 | #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE | |
6de9cd9a | 124 | #undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION |
9dcf6e73 | 125 | #undef LANG_HOOKS_CLEAR_BINDING_STACK |
6de9cd9a DN |
126 | |
127 | /* Define lang hooks. */ | |
128 | #define LANG_HOOKS_NAME "GNU F95" | |
129 | #define LANG_HOOKS_INIT gfc_init | |
130 | #define LANG_HOOKS_FINISH gfc_finish | |
131 | #define LANG_HOOKS_INIT_OPTIONS gfc_init_options | |
132 | #define LANG_HOOKS_HANDLE_OPTION gfc_handle_option | |
133 | #define LANG_HOOKS_POST_OPTIONS gfc_post_options | |
134 | #define LANG_HOOKS_PRINT_IDENTIFIER gfc_print_identifier | |
135 | #define LANG_HOOKS_PARSE_FILE gfc_be_parse_file | |
136 | #define LANG_HOOKS_TRUTHVALUE_CONVERSION gfc_truthvalue_conversion | |
137 | #define LANG_HOOKS_MARK_ADDRESSABLE gfc_mark_addressable | |
138 | #define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode | |
139 | #define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size | |
140 | #define LANG_HOOKS_UNSIGNED_TYPE gfc_unsigned_type | |
141 | #define LANG_HOOKS_SIGNED_TYPE gfc_signed_type | |
142 | #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type | |
6de9cd9a | 143 | #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function |
9dcf6e73 | 144 | #define LANG_HOOKS_CLEAR_BINDING_STACK gfc_clear_binding_stack |
6de9cd9a DN |
145 | |
146 | const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; | |
147 | ||
148 | /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function | |
149 | that have names. Here so we can clear out their names' definitions | |
150 | at the end of the function. */ | |
151 | ||
152 | /* Tree code classes. */ | |
153 | ||
154 | #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, | |
155 | ||
6615c446 | 156 | const enum tree_code_class tree_code_type[] = { |
6de9cd9a DN |
157 | #include "tree.def" |
158 | }; | |
159 | #undef DEFTREECODE | |
160 | ||
161 | /* Table indexed by tree code giving number of expression | |
162 | operands beyond the fixed part of the node structure. | |
163 | Not used for types or decls. */ | |
164 | ||
165 | #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, | |
166 | ||
167 | const unsigned char tree_code_length[] = { | |
168 | #include "tree.def" | |
169 | }; | |
170 | #undef DEFTREECODE | |
171 | ||
172 | /* Names of tree components. | |
173 | Used for printing out the tree and error messages. */ | |
174 | #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, | |
175 | ||
176 | const char *const tree_code_name[] = { | |
177 | #include "tree.def" | |
178 | }; | |
179 | #undef DEFTREECODE | |
180 | ||
181 | static tree named_labels; | |
182 | ||
183 | #define NULL_BINDING_LEVEL (struct binding_level *) NULL | |
184 | ||
185 | /* A chain of binding_level structures awaiting reuse. */ | |
186 | ||
187 | static GTY(()) struct binding_level *free_binding_level; | |
188 | ||
189 | /* The elements of `ridpointers' are identifier nodes | |
190 | for the reserved type names and storage classes. | |
191 | It is indexed by a RID_... value. */ | |
192 | tree *ridpointers = NULL; | |
193 | ||
194 | /* language-specific flags. */ | |
195 | ||
196 | static void | |
197 | gfc_expand_function (tree fndecl) | |
198 | { | |
0f0377f6 | 199 | tree_rest_of_compilation (fndecl); |
6de9cd9a DN |
200 | } |
201 | \f | |
202 | ||
203 | /* Prepare expr to be an argument of a TRUTH_NOT_EXPR, | |
204 | or validate its data type for an `if' or `while' statement or ?..: exp. | |
205 | ||
206 | This preparation consists of taking the ordinary | |
207 | representation of an expression expr and producing a valid tree | |
208 | boolean expression describing whether expr is nonzero. We could | |
209 | simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1), | |
210 | but we optimize comparisons, &&, ||, and !. | |
211 | ||
212 | The resulting type should always be `boolean_type_node'. | |
213 | This is much simpler than the corresponding C version because we have a | |
214 | distinct boolean type. */ | |
215 | ||
216 | tree | |
217 | gfc_truthvalue_conversion (tree expr) | |
218 | { | |
219 | switch (TREE_CODE (TREE_TYPE (expr))) | |
220 | { | |
221 | case BOOLEAN_TYPE: | |
222 | if (TREE_TYPE (expr) == boolean_type_node) | |
223 | return expr; | |
6615c446 | 224 | else if (COMPARISON_CLASS_P (expr)) |
6de9cd9a DN |
225 | { |
226 | TREE_TYPE (expr) = boolean_type_node; | |
227 | return expr; | |
228 | } | |
229 | else if (TREE_CODE (expr) == NOP_EXPR) | |
230 | return build1 (NOP_EXPR, boolean_type_node, | |
231 | TREE_OPERAND (expr, 0)); | |
232 | else | |
233 | return build1 (NOP_EXPR, boolean_type_node, expr); | |
234 | ||
235 | case INTEGER_TYPE: | |
236 | if (TREE_CODE (expr) == INTEGER_CST) | |
237 | return integer_zerop (expr) ? boolean_false_node : boolean_true_node; | |
238 | else | |
923ab88c | 239 | return build2 (NE_EXPR, boolean_type_node, expr, integer_zero_node); |
6de9cd9a DN |
240 | |
241 | default: | |
242 | internal_error ("Unexpected type in truthvalue_conversion"); | |
243 | } | |
244 | } | |
245 | ||
246 | static void | |
247 | gfc_create_decls (void) | |
248 | { | |
249 | /* GCC builtins. */ | |
250 | gfc_init_builtin_functions (); | |
251 | ||
252 | /* Runtime/IO library functions. */ | |
253 | gfc_build_builtin_function_decls (); | |
254 | ||
255 | gfc_init_constants (); | |
256 | } | |
257 | ||
258 | static void | |
259 | gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED) | |
260 | { | |
261 | int errors; | |
262 | int warnings; | |
263 | ||
264 | gfc_create_decls (); | |
265 | gfc_parse_file (); | |
266 | gfc_generate_constructors (); | |
267 | ||
268 | cgraph_finalize_compilation_unit (); | |
269 | cgraph_optimize (); | |
270 | ||
271 | /* Tell the frontent about any errors. */ | |
272 | gfc_get_errors (&warnings, &errors); | |
273 | errorcount += errors; | |
274 | warningcount += warnings; | |
275 | } | |
276 | \f | |
277 | /* Initialize everything. */ | |
278 | ||
279 | static bool | |
280 | gfc_init (void) | |
281 | { | |
c8cc8542 PB |
282 | #ifdef USE_MAPPED_LOCATION |
283 | linemap_add (&line_table, LC_ENTER, false, gfc_option.source, 1); | |
284 | linemap_add (&line_table, LC_RENAME, false, "<built-in>", 0); | |
285 | #endif | |
286 | ||
6de9cd9a DN |
287 | /* First initialize the backend. */ |
288 | gfc_init_decl_processing (); | |
289 | gfc_static_ctors = NULL_TREE; | |
290 | ||
291 | /* Then the frontend. */ | |
292 | gfc_init_1 (); | |
293 | ||
294 | if (gfc_new_file (gfc_option.source, gfc_option.source_form) != SUCCESS) | |
295 | fatal_error ("can't open input file: %s", gfc_option.source); | |
296 | return true; | |
297 | } | |
298 | ||
299 | ||
300 | static void | |
301 | gfc_finish (void) | |
302 | { | |
303 | gfc_done_1 (); | |
304 | gfc_release_include_path (); | |
305 | return; | |
306 | } | |
307 | ||
308 | static void | |
309 | gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED, | |
310 | tree node ATTRIBUTE_UNUSED, | |
311 | int indent ATTRIBUTE_UNUSED) | |
312 | { | |
313 | return; | |
314 | } | |
315 | \f | |
316 | ||
317 | /* These functions and variables deal with binding contours. We only | |
318 | need these functions for the list of PARM_DECLs, but we leave the | |
319 | functions more general; these are a simplified version of the | |
320 | functions from GNAT. */ | |
321 | ||
322 | /* For each binding contour we allocate a binding_level structure which records | |
323 | the entities defined or declared in that contour. Contours include: | |
324 | ||
325 | the global one | |
326 | one for each subprogram definition | |
327 | one for each compound statement (declare block) | |
328 | ||
329 | Binding contours are used to create GCC tree BLOCK nodes. */ | |
330 | ||
331 | struct binding_level | |
332 | GTY(()) | |
333 | { | |
334 | /* A chain of ..._DECL nodes for all variables, constants, functions, | |
335 | parameters and type declarations. These ..._DECL nodes are chained | |
336 | through the TREE_CHAIN field. Note that these ..._DECL nodes are stored | |
337 | in the reverse of the order supplied to be compatible with the | |
338 | back-end. */ | |
339 | tree names; | |
340 | /* For each level (except the global one), a chain of BLOCK nodes for all | |
341 | the levels that were entered and exited one level down from this one. */ | |
342 | tree blocks; | |
f7b529fa | 343 | /* The binding level containing this one (the enclosing binding level). */ |
6de9cd9a DN |
344 | struct binding_level *level_chain; |
345 | }; | |
346 | ||
347 | /* The binding level currently in effect. */ | |
348 | static GTY(()) struct binding_level *current_binding_level = NULL; | |
349 | ||
350 | /* The outermost binding level. This binding level is created when the | |
351 | compiler is started and it will exist through the entire compilation. */ | |
352 | static GTY(()) struct binding_level *global_binding_level; | |
353 | ||
354 | /* Binding level structures are initialized by copying this one. */ | |
9dcf6e73 | 355 | static struct binding_level clear_binding_level = { NULL, NULL, NULL }; |
6de9cd9a | 356 | \f |
13795658 | 357 | /* Return nonzero if we are currently in the global binding level. */ |
6de9cd9a DN |
358 | |
359 | int | |
360 | global_bindings_p (void) | |
361 | { | |
362 | return current_binding_level == global_binding_level ? -1 : 0; | |
363 | } | |
364 | ||
365 | tree | |
366 | getdecls (void) | |
367 | { | |
368 | return current_binding_level->names; | |
369 | } | |
370 | ||
371 | /* Enter a new binding level. The input parameter is ignored, but has to be | |
372 | specified for back-end compatibility. */ | |
373 | ||
374 | void | |
375 | pushlevel (int ignore ATTRIBUTE_UNUSED) | |
376 | { | |
377 | struct binding_level *newlevel | |
378 | = (struct binding_level *) ggc_alloc (sizeof (struct binding_level)); | |
379 | ||
380 | *newlevel = clear_binding_level; | |
381 | ||
382 | /* Add this level to the front of the chain (stack) of levels that are | |
383 | active. */ | |
384 | newlevel->level_chain = current_binding_level; | |
385 | current_binding_level = newlevel; | |
386 | } | |
387 | ||
388 | /* Exit a binding level. | |
389 | Pop the level off, and restore the state of the identifier-decl mappings | |
390 | that were in effect when this level was entered. | |
391 | ||
392 | If KEEP is nonzero, this level had explicit declarations, so | |
393 | and create a "block" (a BLOCK node) for the level | |
394 | to record its declarations and subblocks for symbol table output. | |
395 | ||
396 | If FUNCTIONBODY is nonzero, this level is the body of a function, | |
397 | so create a block as if KEEP were set and also clear out all | |
398 | label names. | |
399 | ||
400 | If REVERSE is nonzero, reverse the order of decls before putting | |
401 | them into the BLOCK. */ | |
402 | ||
403 | tree | |
404 | poplevel (int keep, int reverse, int functionbody) | |
405 | { | |
1f2959f0 | 406 | /* Points to a BLOCK tree node. This is the BLOCK node constructed for the |
6de9cd9a DN |
407 | binding level that we are about to exit and which is returned by this |
408 | routine. */ | |
409 | tree block_node = NULL_TREE; | |
410 | tree decl_chain; | |
411 | tree subblock_chain = current_binding_level->blocks; | |
412 | tree subblock_node; | |
6de9cd9a DN |
413 | |
414 | /* Reverse the list of XXXX_DECL nodes if desired. Note that the ..._DECL | |
415 | nodes chained through the `names' field of current_binding_level are in | |
1f2959f0 | 416 | reverse order except for PARM_DECL node, which are explicitly stored in |
6de9cd9a DN |
417 | the right order. */ |
418 | decl_chain = (reverse) ? nreverse (current_binding_level->names) | |
419 | : current_binding_level->names; | |
420 | ||
6de9cd9a DN |
421 | /* If there were any declarations in the current binding level, or if this |
422 | binding level is a function body, or if there are any nested blocks then | |
423 | create a BLOCK node to record them for the life of this function. */ | |
9dcf6e73 | 424 | if (keep || functionbody) |
6de9cd9a DN |
425 | block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0); |
426 | ||
427 | /* Record the BLOCK node just built as the subblock its enclosing scope. */ | |
428 | for (subblock_node = subblock_chain; subblock_node; | |
429 | subblock_node = TREE_CHAIN (subblock_node)) | |
430 | BLOCK_SUPERCONTEXT (subblock_node) = block_node; | |
431 | ||
432 | /* Clear out the meanings of the local variables of this level. */ | |
433 | ||
434 | for (subblock_node = decl_chain; subblock_node; | |
435 | subblock_node = TREE_CHAIN (subblock_node)) | |
436 | if (DECL_NAME (subblock_node) != 0) | |
437 | /* If the identifier was used or addressed via a local extern decl, | |
f7b529fa | 438 | don't forget that fact. */ |
6de9cd9a DN |
439 | if (DECL_EXTERNAL (subblock_node)) |
440 | { | |
441 | if (TREE_USED (subblock_node)) | |
442 | TREE_USED (DECL_NAME (subblock_node)) = 1; | |
443 | if (TREE_ADDRESSABLE (subblock_node)) | |
444 | TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1; | |
445 | } | |
446 | ||
447 | /* Pop the current level. */ | |
448 | current_binding_level = current_binding_level->level_chain; | |
449 | ||
450 | if (functionbody) | |
451 | { | |
452 | /* This is the top level block of a function. The ..._DECL chain stored | |
453 | in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't | |
454 | leave them in the BLOCK because they are found in the FUNCTION_DECL | |
455 | instead. */ | |
456 | DECL_INITIAL (current_function_decl) = block_node; | |
457 | BLOCK_VARS (block_node) = 0; | |
458 | } | |
459 | else if (block_node) | |
460 | { | |
9dcf6e73 JM |
461 | current_binding_level->blocks |
462 | = chainon (current_binding_level->blocks, block_node); | |
6de9cd9a DN |
463 | } |
464 | ||
465 | /* If we did not make a block for the level just exited, any blocks made for | |
466 | inner levels (since they cannot be recorded as subblocks in that level) | |
467 | must be carried forward so they will later become subblocks of something | |
468 | else. */ | |
469 | else if (subblock_chain) | |
470 | current_binding_level->blocks | |
471 | = chainon (current_binding_level->blocks, subblock_chain); | |
472 | if (block_node) | |
473 | TREE_USED (block_node) = 1; | |
474 | ||
475 | return block_node; | |
476 | } | |
477 | \f | |
478 | /* Insert BLOCK at the end of the list of subblocks of the | |
479 | current binding level. This is used when a BIND_EXPR is expanded, | |
480 | to handle the BLOCK node inside the BIND_EXPR. */ | |
481 | ||
482 | void | |
483 | insert_block (tree block) | |
484 | { | |
485 | TREE_USED (block) = 1; | |
486 | current_binding_level->blocks | |
487 | = chainon (current_binding_level->blocks, block); | |
488 | } | |
489 | ||
6de9cd9a | 490 | /* Records a ..._DECL node DECL as belonging to the current lexical scope. |
f7b529fa | 491 | Returns the ..._DECL node. */ |
6de9cd9a DN |
492 | |
493 | tree | |
494 | pushdecl (tree decl) | |
495 | { | |
496 | /* External objects aren't nested, other objects may be. */ | |
497 | if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl)) | |
498 | DECL_CONTEXT (decl) = 0; | |
499 | else | |
500 | DECL_CONTEXT (decl) = current_function_decl; | |
501 | ||
502 | /* Put the declaration on the list. The list of declarations is in reverse | |
503 | order. The list will be reversed later if necessary. This needs to be | |
504 | this way for compatibility with the back-end. */ | |
505 | ||
506 | TREE_CHAIN (decl) = current_binding_level->names; | |
507 | current_binding_level->names = decl; | |
508 | ||
f7b529fa | 509 | /* For the declartion of a type, set its name if it is not already set. */ |
6de9cd9a DN |
510 | |
511 | if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0) | |
512 | { | |
513 | if (DECL_SOURCE_LINE (decl) == 0) | |
514 | TYPE_NAME (TREE_TYPE (decl)) = decl; | |
515 | else | |
516 | TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl); | |
517 | } | |
518 | ||
519 | return decl; | |
520 | } | |
521 | ||
522 | ||
523 | /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL. */ | |
524 | ||
525 | tree | |
526 | pushdecl_top_level (tree x) | |
527 | { | |
528 | tree t; | |
529 | struct binding_level *b = current_binding_level; | |
530 | ||
531 | current_binding_level = global_binding_level; | |
532 | t = pushdecl (x); | |
533 | current_binding_level = b; | |
534 | return t; | |
535 | } | |
536 | ||
537 | ||
9dcf6e73 JM |
538 | /* Clear the binding stack. */ |
539 | static void | |
540 | gfc_clear_binding_stack (void) | |
541 | { | |
542 | while (!global_bindings_p ()) | |
543 | poplevel (0, 0, 0); | |
544 | } | |
545 | ||
546 | ||
6de9cd9a DN |
547 | #ifndef CHAR_TYPE_SIZE |
548 | #define CHAR_TYPE_SIZE BITS_PER_UNIT | |
549 | #endif | |
550 | ||
551 | #ifndef INT_TYPE_SIZE | |
552 | #define INT_TYPE_SIZE BITS_PER_WORD | |
553 | #endif | |
554 | ||
555 | #undef SIZE_TYPE | |
556 | #define SIZE_TYPE "long unsigned int" | |
557 | ||
558 | /* Create tree nodes for the basic scalar types of Fortran 95, | |
559 | and some nodes representing standard constants (0, 1, (void *) 0). | |
560 | Initialize the global binding level. | |
561 | Make definitions for built-in primitive functions. */ | |
562 | static void | |
563 | gfc_init_decl_processing (void) | |
564 | { | |
565 | current_function_decl = NULL; | |
566 | named_labels = NULL; | |
567 | current_binding_level = NULL_BINDING_LEVEL; | |
568 | free_binding_level = NULL_BINDING_LEVEL; | |
569 | ||
570 | /* Make the binding_level structure for global names. We move all | |
571 | variables that are in a COMMON block to this binding level. */ | |
572 | pushlevel (0); | |
573 | global_binding_level = current_binding_level; | |
574 | ||
575 | /* Build common tree nodes. char_type_node is unsigned because we | |
576 | only use it for actual characters, not for INTEGER(1). Also, we | |
f7b529fa | 577 | want double_type_node to actually have double precision. */ |
8c1d6d62 | 578 | build_common_tree_nodes (false, false); |
6de9cd9a DN |
579 | set_sizetype (long_unsigned_type_node); |
580 | build_common_tree_nodes_2 (0); | |
581 | ||
582 | /* Set up F95 type nodes. */ | |
5e8e542f | 583 | gfc_init_kinds (); |
6de9cd9a DN |
584 | gfc_init_types (); |
585 | } | |
586 | ||
587 | /* Mark EXP saying that we need to be able to take the | |
588 | address of it; it should not be allocated in a register. | |
589 | In Fortran 95 this is only the case for variables with | |
590 | the TARGET attribute, but we implement it here for a | |
591 | likely future Cray pointer extension. | |
592 | Value is 1 if successful. */ | |
593 | /* TODO: Check/fix mark_addressable. */ | |
594 | bool | |
595 | gfc_mark_addressable (tree exp) | |
596 | { | |
597 | register tree x = exp; | |
598 | while (1) | |
599 | switch (TREE_CODE (x)) | |
600 | { | |
601 | case COMPONENT_REF: | |
602 | case ADDR_EXPR: | |
603 | case ARRAY_REF: | |
604 | case REALPART_EXPR: | |
605 | case IMAGPART_EXPR: | |
606 | x = TREE_OPERAND (x, 0); | |
607 | break; | |
608 | ||
609 | case CONSTRUCTOR: | |
610 | TREE_ADDRESSABLE (x) = 1; | |
611 | return true; | |
612 | ||
613 | case VAR_DECL: | |
614 | case CONST_DECL: | |
615 | case PARM_DECL: | |
616 | case RESULT_DECL: | |
617 | if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x)) | |
618 | { | |
619 | if (TREE_PUBLIC (x)) | |
620 | { | |
621 | error | |
597cdf4f | 622 | ("global register variable %qs used in nested function", |
6de9cd9a DN |
623 | IDENTIFIER_POINTER (DECL_NAME (x))); |
624 | return false; | |
625 | } | |
597cdf4f | 626 | pedwarn ("register variable %qs used in nested function", |
6de9cd9a DN |
627 | IDENTIFIER_POINTER (DECL_NAME (x))); |
628 | } | |
629 | else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) | |
630 | { | |
631 | if (TREE_PUBLIC (x)) | |
632 | { | |
597cdf4f | 633 | error ("address of global register variable %qs requested", |
6de9cd9a DN |
634 | IDENTIFIER_POINTER (DECL_NAME (x))); |
635 | return true; | |
636 | } | |
637 | ||
638 | #if 0 | |
639 | /* If we are making this addressable due to its having | |
640 | volatile components, give a different error message. Also | |
641 | handle the case of an unnamed parameter by not trying | |
642 | to give the name. */ | |
643 | ||
644 | else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x))) | |
645 | { | |
646 | error ("cannot put object with volatile field into register"); | |
647 | return false; | |
648 | } | |
649 | #endif | |
650 | ||
597cdf4f | 651 | pedwarn ("address of register variable %qs requested", |
6de9cd9a DN |
652 | IDENTIFIER_POINTER (DECL_NAME (x))); |
653 | } | |
6de9cd9a DN |
654 | |
655 | /* drops in */ | |
656 | case FUNCTION_DECL: | |
657 | TREE_ADDRESSABLE (x) = 1; | |
658 | ||
659 | default: | |
660 | return true; | |
661 | } | |
662 | } | |
663 | ||
664 | /* press the big red button - garbage (ggc) collection is on */ | |
665 | ||
666 | int ggc_p = 1; | |
667 | ||
1f2959f0 | 668 | /* Builtin function initialization. */ |
6de9cd9a DN |
669 | |
670 | /* Return a definition for a builtin function named NAME and whose data type | |
671 | is TYPE. TYPE should be a function type with argument types. | |
672 | FUNCTION_CODE tells later passes how to compile calls to this function. | |
673 | See tree.h for its possible values. | |
674 | ||
675 | If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, | |
676 | the name to be called if we can't opencode the function. If | |
677 | ATTRS is nonzero, use that for the function's attribute list. */ | |
678 | ||
679 | tree | |
680 | builtin_function (const char *name, | |
681 | tree type, | |
682 | int function_code, | |
683 | enum built_in_class class, | |
684 | const char *library_name, | |
685 | tree attrs ATTRIBUTE_UNUSED) | |
686 | { | |
687 | tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); | |
688 | DECL_EXTERNAL (decl) = 1; | |
689 | TREE_PUBLIC (decl) = 1; | |
690 | if (library_name) | |
691 | SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name)); | |
0e6df31e | 692 | make_decl_rtl (decl); |
6de9cd9a DN |
693 | pushdecl (decl); |
694 | DECL_BUILT_IN_CLASS (decl) = class; | |
695 | DECL_FUNCTION_CODE (decl) = function_code; | |
696 | return decl; | |
697 | } | |
698 | ||
699 | ||
700 | static void | |
701 | gfc_define_builtin (const char * name, | |
702 | tree type, | |
703 | int code, | |
704 | const char * library_name, | |
705 | bool const_p) | |
706 | { | |
707 | tree decl; | |
708 | ||
709 | decl = builtin_function (name, type, code, BUILT_IN_NORMAL, | |
710 | library_name, NULL_TREE); | |
711 | if (const_p) | |
712 | TREE_READONLY (decl) = 1; | |
713 | ||
714 | built_in_decls[code] = decl; | |
715 | implicit_built_in_decls[code] = decl; | |
716 | } | |
717 | ||
718 | ||
e8525382 SK |
719 | #define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \ |
720 | gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \ | |
6de9cd9a | 721 | BUILT_IN_ ## code, name, true); \ |
e8525382 | 722 | gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \ |
6de9cd9a DN |
723 | BUILT_IN_ ## code ## F, name "f", true); |
724 | ||
e8525382 SK |
725 | #define DEFINE_MATH_BUILTIN(code, name, argtype) \ |
726 | DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) | |
727 | ||
728 | /* The middle-end is missing builtins for some complex math functions, so | |
729 | we don't use them yet. */ | |
730 | #define DEFINE_MATH_BUILTIN_C(code, name, argtype) \ | |
731 | DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) | |
732 | /* DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c)*/ | |
733 | ||
734 | ||
735 | /* Create function types for builtin functions. */ | |
736 | ||
737 | static void | |
738 | build_builtin_fntypes (tree * fntype, tree type) | |
739 | { | |
740 | tree tmp; | |
741 | ||
742 | /* type (*) (type) */ | |
743 | tmp = tree_cons (NULL_TREE, float_type_node, void_list_node); | |
744 | fntype[0] = build_function_type (type, tmp); | |
745 | /* type (*) (type, type) */ | |
746 | tmp = tree_cons (NULL_TREE, float_type_node, tmp); | |
747 | fntype[1] = build_function_type (type, tmp); | |
748 | /* type (*) (int, type) */ | |
749 | tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node); | |
750 | tmp = tree_cons (NULL_TREE, type, tmp); | |
751 | fntype[2] = build_function_type (type, tmp); | |
752 | } | |
753 | ||
754 | ||
1f2959f0 | 755 | /* Initialization of builtin function nodes. */ |
e8525382 | 756 | |
6de9cd9a DN |
757 | static void |
758 | gfc_init_builtin_functions (void) | |
759 | { | |
e8525382 SK |
760 | tree mfunc_float[3]; |
761 | tree mfunc_double[3]; | |
762 | tree mfunc_cfloat[3]; | |
763 | tree mfunc_cdouble[3]; | |
ead6d15f AP |
764 | tree func_cfloat_float; |
765 | tree func_cdouble_double; | |
6de9cd9a DN |
766 | tree ftype; |
767 | tree tmp; | |
6de9cd9a | 768 | |
e8525382 SK |
769 | build_builtin_fntypes (mfunc_float, float_type_node); |
770 | build_builtin_fntypes (mfunc_double, double_type_node); | |
771 | build_builtin_fntypes (mfunc_cfloat, complex_float_type_node); | |
772 | build_builtin_fntypes (mfunc_cdouble, complex_double_type_node); | |
773 | ||
ead6d15f AP |
774 | tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node); |
775 | func_cfloat_float = build_function_type (float_type_node, tmp); | |
6de9cd9a | 776 | |
ead6d15f AP |
777 | tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node); |
778 | func_cdouble_double = build_function_type (double_type_node, tmp); | |
6de9cd9a DN |
779 | |
780 | #include "mathbuiltins.def" | |
781 | ||
e7dc5b4f | 782 | /* We define these separately as the fortran versions have different |
6de9cd9a DN |
783 | semantics (they return an integer type) */ |
784 | gfc_define_builtin ("__builtin_floor", mfunc_double[0], | |
785 | BUILT_IN_FLOOR, "floor", true); | |
786 | gfc_define_builtin ("__builtin_floorf", mfunc_float[0], | |
787 | BUILT_IN_FLOORF, "floorf", true); | |
788 | gfc_define_builtin ("__builtin_round", mfunc_double[0], | |
789 | BUILT_IN_ROUND, "round", true); | |
790 | gfc_define_builtin ("__builtin_roundf", mfunc_float[0], | |
791 | BUILT_IN_ROUNDF, "roundf", true); | |
ead6d15f AP |
792 | |
793 | gfc_define_builtin ("__builtin_cabs", func_cdouble_double, | |
794 | BUILT_IN_CABS, "cabs", true); | |
795 | gfc_define_builtin ("__builtin_cabsf", func_cfloat_float, | |
796 | BUILT_IN_CABSF, "cabsf", true); | |
797 | ||
798 | ||
799 | gfc_define_builtin ("__builtin_copysign", mfunc_double[1], | |
800 | BUILT_IN_COPYSIGN, "copysign", true); | |
801 | gfc_define_builtin ("__builtin_copysignf", mfunc_float[1], | |
802 | BUILT_IN_COPYSIGNF, "copysignf", true); | |
6de9cd9a | 803 | |
5b200ac2 | 804 | /* These are used to implement the ** operator. */ |
c7d78bbe | 805 | gfc_define_builtin ("__builtin_pow", mfunc_double[1], |
5b200ac2 | 806 | BUILT_IN_POW, "pow", true); |
c7d78bbe | 807 | gfc_define_builtin ("__builtin_powf", mfunc_float[1], |
5b200ac2 FW |
808 | BUILT_IN_POWF, "powf", true); |
809 | ||
6de9cd9a DN |
810 | /* Other builtin functions we use. */ |
811 | ||
5b200ac2 | 812 | tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node); |
6de9cd9a DN |
813 | tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp); |
814 | ftype = build_function_type (long_integer_type_node, tmp); | |
815 | gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, | |
816 | "__builtin_expect", true); | |
817 | ||
5b200ac2 | 818 | tmp = tree_cons (NULL_TREE, size_type_node, void_list_node); |
6de9cd9a DN |
819 | tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); |
820 | tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); | |
821 | ftype = build_function_type (pvoid_type_node, tmp); | |
822 | gfc_define_builtin ("__builtin_memcpy", ftype, BUILT_IN_MEMCPY, | |
823 | "memcpy", false); | |
824 | ||
5b200ac2 | 825 | tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node); |
6de9cd9a DN |
826 | ftype = build_function_type (integer_type_node, tmp); |
827 | gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, "clz", true); | |
828 | ||
5b200ac2 | 829 | tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node); |
6de9cd9a DN |
830 | ftype = build_function_type (integer_type_node, tmp); |
831 | gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, "clzl", true); | |
832 | ||
5b200ac2 | 833 | tmp = tree_cons (NULL_TREE, long_long_integer_type_node, void_list_node); |
6de9cd9a DN |
834 | ftype = build_function_type (integer_type_node, tmp); |
835 | gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, "clzll", true); | |
836 | ||
5b200ac2 | 837 | tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node); |
6de9cd9a DN |
838 | tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); |
839 | tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); | |
840 | ftype = build_function_type (void_type_node, tmp); | |
841 | gfc_define_builtin ("__builtin_init_trampoline", ftype, | |
842 | BUILT_IN_INIT_TRAMPOLINE, "init_trampoline", false); | |
843 | ||
5b200ac2 | 844 | tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node); |
6de9cd9a DN |
845 | ftype = build_function_type (pvoid_type_node, tmp); |
846 | gfc_define_builtin ("__builtin_adjust_trampoline", ftype, | |
847 | BUILT_IN_ADJUST_TRAMPOLINE, "adjust_trampoline", true); | |
848 | ||
1a186ec5 RH |
849 | /* The stack_save, stack_restore, and alloca builtins aren't used directly. |
850 | They are inserted during gimplification to implement variable sized | |
851 | stack allocation. */ | |
6de9cd9a | 852 | |
5b200ac2 | 853 | ftype = build_function_type (pvoid_type_node, void_list_node); |
6de9cd9a DN |
854 | gfc_define_builtin ("__builtin_stack_save", ftype, BUILT_IN_STACK_SAVE, |
855 | "stack_save", false); | |
1a186ec5 | 856 | |
5b200ac2 | 857 | tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node); |
6de9cd9a DN |
858 | ftype = build_function_type (void_type_node, tmp); |
859 | gfc_define_builtin ("__builtin_stack_restore", ftype, BUILT_IN_STACK_RESTORE, | |
860 | "stack_restore", false); | |
1a186ec5 RH |
861 | |
862 | tmp = tree_cons (NULL_TREE, size_type_node, void_list_node); | |
863 | ftype = build_function_type (pvoid_type_node, tmp); | |
864 | gfc_define_builtin ("__builtin_alloca", ftype, BUILT_IN_ALLOCA, | |
865 | "alloca", false); | |
ef9312c1 IR |
866 | |
867 | targetm.init_builtins (); | |
6de9cd9a DN |
868 | } |
869 | ||
e8525382 | 870 | #undef DEFINE_MATH_BUILTIN_C |
6de9cd9a DN |
871 | #undef DEFINE_MATH_BUILTIN |
872 | ||
873 | #include "gt-fortran-f95-lang.h" | |
874 | #include "gtype-fortran.h" |