diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/decl.c | 45 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/gigi.h | 4 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 24 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/utils.c | 40 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/constant1.adb (renamed from gcc/testsuite/gnat.dg/const1.adb) | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/constant2.adb | 11 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/constant2_pkg1.ads | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/constant2_pkg2.adb | 13 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/constant2_pkg2.ads | 6 |
11 files changed, 153 insertions, 32 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 713edf4..b91bd5c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,28 @@ 2010-09-19 Eric Botcazou <ebotcazou@adacore.com> + * gcc-interface/gigi.h (get_elaboration_procedure): Declare. + (gnat_zaplevel): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity): Do not force global + binding level for an external constant. + <E_Constant>: Force the local context and create a fake scope before + translating the defining expression of an external constant. + <object>: Treat external constants at the global level explicitly for + renaming declarations. + (elaborate_expression_1): Force the variable to be static if the + expression is global. + * gcc-interface/trans.c (get_elaboration_procedure): New function. + (call_to_gnu): Use it. + (gnat_to_gnu): Likewise. + <N_Object_Declaration>: Do not test Is_Public to force the creation of + an initialization variable. + (add_decl_expr): Discard the statement if the declaration is external. + * gcc-interface/utils.c (gnat_pushdecl): Do not put the declaration in + the current block if it is external. + (create_var_decl_1): Do not test Is_Public to set TREE_STATIC. + (gnat_zaplevel): New global function. + +2010-09-19 Eric Botcazou <ebotcazou@adacore.com> + * gcc-interface/decl.c (gnat_to_gnu_entity): Explicitly test _LEVEL variables against zero in all cases. (rest_of_type_decl_compilation): Likewise. diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 850777d..32b499b 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -357,10 +357,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) another compilation unit) public entities, show we are at global level for the purpose of computing scopes. Don't do this for components or discriminants since the relevant test is whether or not the record is - being defined. */ + being defined. Don't do this for constants either as we'll look into + their defining expression in the local context. */ if (!definition && kind != E_Component && kind != E_Discriminant + && kind != E_Constant && Is_Public (gnat_entity) && !Is_Statically_Allocated (gnat_entity)) force_global++, this_global = true; @@ -430,7 +432,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && Present (Expression (Declaration_Node (gnat_entity))) && Nkind (Expression (Declaration_Node (gnat_entity))) != N_Allocator) - gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); + { + bool went_into_elab_proc = false; + + /* The expression may contain N_Expression_With_Actions nodes and + thus object declarations from other units. In this case, even + though the expression will eventually be discarded since not a + constant, the declarations would be stuck either in the global + varpool or in the current scope. Therefore we force the local + context and create a fake scope that we'll zap at the end. */ + if (!current_function_decl) + { + current_function_decl = get_elaboration_procedure (); + went_into_elab_proc = true; + } + gnat_pushlevel (); + + gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); + + gnat_zaplevel (); + if (went_into_elab_proc) + current_function_decl = NULL_TREE; + } /* Ignore deferred constant definitions without address clause since they are processed fully in the front-end. If No_Initialization @@ -926,10 +949,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) that for the renaming. At the global level, we can only do this if we know no SAVE_EXPRs need be made, because the expression we return might be used in arbitrary conditional - branches so we must force the SAVE_EXPRs evaluation - immediately and this requires a function context. */ + branches so we must force the evaluation of the SAVE_EXPRs + immediately and this requires a proper function context. + Note that an external constant is at the global level. */ if (!Materialize_Entity (gnat_entity) - && (!global_bindings_p () + && (!((!definition && kind == E_Constant) + || global_bindings_p ()) || (staticp (gnu_expr) && !TREE_SIDE_EFFECTS (gnu_expr)))) { @@ -940,7 +965,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { /* ??? No DECL_EXPR is created so we need to mark the expression manually lest it is shared. */ - if (global_bindings_p ()) + if ((!definition && kind == E_Constant) + || global_bindings_p ()) MARK_VISITED (maybe_stable_expr); gnu_decl = maybe_stable_expr; save_gnu_tree (gnat_entity, gnu_decl, true); @@ -1359,11 +1385,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } /* If this is a renaming pointer, attach the renamed object to it and - register it if we are at top level. */ + register it if we are at the global level. Note that an external + constant is at the global level. */ if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj) { SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj); - if (global_bindings_p ()) + if ((!definition && kind == E_Constant) || global_bindings_p ()) { DECL_RENAMING_GLOBAL_P (gnu_decl) = 1; record_global_renaming_pointer (gnu_decl); @@ -5977,7 +6004,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, IDENTIFIER_POINTER (gnu_name)), NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, !need_debug, Is_Public (gnat_entity), - !definition, false, NULL, gnat_entity); + !definition, expr_global, NULL, gnat_entity); /* We only need to use this variable if we are in global context since GCC can do the right thing in the local case. */ diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 767700f..b464cac 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -259,6 +259,9 @@ extern void post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, if none. */ extern tree get_exception_label (char kind); +/* Return the decl for the current elaboration procedure. */ +extern tree get_elaboration_procedure (void); + /* If nonzero, pretend we are allocating at global level. */ extern int force_global; @@ -403,6 +406,7 @@ extern int global_bindings_p (void); /* Enter and exit a new binding level. */ extern void gnat_pushlevel (void); extern void gnat_poplevel (void); +extern void gnat_zaplevel (void); /* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL and point FNDECL to this BLOCK. */ diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 028419b..bf9ac15 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -2675,7 +2675,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) so we can give them the scope of the elaboration routine at top level. */ else if (!current_function_decl) { - current_function_decl = VEC_last (tree, gnu_elab_proc_stack); + current_function_decl = get_elaboration_procedure (); went_into_elab_proc = true; } @@ -3755,11 +3755,13 @@ gnat_to_gnu (Node_Id gnat_node) || kind == N_Handled_Sequence_Of_Statements || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void)) { + tree current_elab_proc = get_elaboration_procedure (); + /* If this is a statement and we are at top level, it must be part of the elaboration procedure, so mark us as being in that procedure. */ if (!current_function_decl) { - current_function_decl = VEC_last (tree, gnu_elab_proc_stack); + current_function_decl = current_elab_proc; went_into_elab_proc = true; } @@ -3770,7 +3772,7 @@ gnat_to_gnu (Node_Id gnat_node) every nested real statement instead. This also avoids triggering spurious errors on dummy (empty) sequences created by the front-end for package bodies in some cases. */ - if (current_function_decl == VEC_last (tree, gnu_elab_proc_stack) + if (current_function_decl == current_elab_proc && kind != N_Handled_Sequence_Of_Statements) Check_Elaboration_Code_Allowed (gnat_node); } @@ -3998,15 +4000,13 @@ gnat_to_gnu (Node_Id gnat_node) is frozen. */ if (Present (Freeze_Node (gnat_temp))) { - bool public_flag = Is_Public (gnat_temp); - if (TREE_CONSTANT (gnu_expr)) ; - else if (public_flag || global_bindings_p ()) + else if (global_bindings_p ()) gnu_expr = create_var_decl (create_concat_name (gnat_temp, "init"), NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, - false, public_flag, false, false, + false, false, false, false, NULL, gnat_temp); else gnu_expr = gnat_save_expr (gnu_expr); @@ -5809,7 +5809,7 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) || TREE_CODE (type) == QUAL_UNION_TYPE)) MARK_VISITED (TYPE_ADA_SIZE (type)); } - else + else if (!DECL_EXTERNAL (gnu_decl)) add_stmt_with_node (gnu_stmt, gnat_entity); /* If this is a variable and an initializer is attached to it, it must be @@ -7665,4 +7665,12 @@ get_exception_label (char kind) return NULL_TREE; } +/* Return the decl for the current elaboration procedure. */ + +tree +get_elaboration_procedure (void) +{ + return VEC_last (tree, gnu_elab_proc_stack); +} + #include "gt-ada-trans.h" diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index cadc4d7..98a1565 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -411,6 +411,22 @@ gnat_poplevel (void) free_binding_level = level; } +/* Exit a binding level and discard the associated BLOCK. */ + +void +gnat_zaplevel (void) +{ + struct gnat_binding_level *level = current_binding_level; + tree block = level->block; + + BLOCK_CHAIN (block) = free_block_chain; + free_block_chain = block; + + /* Free this binding structure. */ + current_binding_level = level->chain; + level->chain = free_binding_level; + free_binding_level = level; +} /* Records a ..._DECL node DECL as belonging to the current lexical scope and uses GNAT_NODE for location information and propagating flags. */ @@ -441,13 +457,12 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) add_decl_expr (decl, gnat_node); /* Put the declaration on the list. The list of declarations is in reverse - order. The list will be reversed later. Put global variables in the - globals list and builtin functions in a dedicated list to speed up - further lookups. Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into - the list, as they will cause trouble with the debugger and aren't needed - anyway. */ - if (TREE_CODE (decl) != TYPE_DECL - || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE) + order. The list will be reversed later. Put global declarations in the + globals list and local ones in the current block. But skip TYPE_DECLs + for UNCONSTRAINED_ARRAY_TYPE in both cases, as they will cause trouble + with the debugger and aren't needed anyway. */ + if (!(TREE_CODE (decl) == TYPE_DECL + && TREE_CODE (TREE_TYPE (decl)) == UNCONSTRAINED_ARRAY_TYPE)) { if (global_bindings_p ()) { @@ -456,7 +471,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl)) VEC_safe_push (tree, gc, builtin_decls, decl); } - else + else if (!DECL_EXTERNAL (decl)) { tree block; /* Fake PARM_DECLs go into the topmost block of the function. */ @@ -1371,12 +1386,11 @@ create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init, && !have_global_bss_p ()) DECL_COMMON (var_decl) = 1; - /* If it's public and not external, always allocate storage for it. - At the global binding level we need to allocate static storage for the - variable if and only if it's not external. If we are not at the top level - we allocate automatic storage unless requested not to. */ + /* At the global binding level, we need to allocate static storage for the + variable if it isn't external. Otherwise, we allocate automatic storage + unless requested not to. */ TREE_STATIC (var_decl) - = !extern_flag && (public_flag || static_flag || global_bindings_p ()); + = !extern_flag && (static_flag || global_bindings_p ()); /* For an external constant whose initializer is not absolute, do not emit debug info. In DWARF this would mean a global relocation in a read-only diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index dc0286a..1ef14a3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,13 @@ 2010-09-19 Eric Botcazou <ebotcazou@adacore.com> + * gnat.dg/const1.adb: Rename into... + * gnat.dg/constant1.adb: ...this. + * gnat.dg/constant2.adb: New test. + * gnat.dg/constant2_pkg1.ads: New helper. + * gnat.dg/constant2_pkg2.ad[sb]: Likewise. + +2010-09-19 Eric Botcazou <ebotcazou@adacore.com> + * gnat.dg/specs/constant1.ads: New test. * gnat.dg/specs/constant1_pkg.ads: New helper. diff --git a/gcc/testsuite/gnat.dg/const1.adb b/gcc/testsuite/gnat.dg/constant1.adb index 486e963..6cd1bcf 100644 --- a/gcc/testsuite/gnat.dg/const1.adb +++ b/gcc/testsuite/gnat.dg/constant1.adb @@ -1,8 +1,8 @@ -- { dg-do compile } -procedure const1 is +procedure Constant1 is Def_Const : constant Integer; pragma Import (Ada, Def_Const); begin null; -end const1; +end; diff --git a/gcc/testsuite/gnat.dg/constant2.adb b/gcc/testsuite/gnat.dg/constant2.adb new file mode 100644 index 0000000..41c7e91 --- /dev/null +++ b/gcc/testsuite/gnat.dg/constant2.adb @@ -0,0 +1,11 @@ +-- { dg-do run } +-- { dg-options "-gnatVa" } + +with Constant2_Pkg1; use Constant2_Pkg1; + +procedure Constant2 is +begin + if Val then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/constant2_pkg1.ads b/gcc/testsuite/gnat.dg/constant2_pkg1.ads new file mode 100644 index 0000000..8905d30 --- /dev/null +++ b/gcc/testsuite/gnat.dg/constant2_pkg1.ads @@ -0,0 +1,7 @@ +with Constant2_Pkg2; use Constant2_Pkg2; + +package Constant2_Pkg1 is + + Val : constant Boolean := F1 and then F2; + +end Constant2_Pkg1; diff --git a/gcc/testsuite/gnat.dg/constant2_pkg2.adb b/gcc/testsuite/gnat.dg/constant2_pkg2.adb new file mode 100644 index 0000000..e9ccade --- /dev/null +++ b/gcc/testsuite/gnat.dg/constant2_pkg2.adb @@ -0,0 +1,13 @@ +package body Constant2_Pkg2 is + + function F1 return Boolean is + begin + return False; + end; + + function F2 return Boolean is + begin + return False; + end; + +end Constant2_Pkg2; diff --git a/gcc/testsuite/gnat.dg/constant2_pkg2.ads b/gcc/testsuite/gnat.dg/constant2_pkg2.ads new file mode 100644 index 0000000..60b283c --- /dev/null +++ b/gcc/testsuite/gnat.dg/constant2_pkg2.ads @@ -0,0 +1,6 @@ +package Constant2_Pkg2 is + + function F1 return Boolean; + function F2 return Boolean; + +end Constant2_Pkg2; |