diff options
| -rw-r--r-- | gcc/ada/decl.c | 277 | ||||
| -rw-r--r-- | gcc/ada/gigi.h | 23 | ||||
| -rw-r--r-- | gcc/ada/repinfo.adb | 143 | ||||
| -rw-r--r-- | gcc/ada/repinfo.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/repinfo.h | 3 | ||||
| -rw-r--r-- | gcc/ada/trans.c | 186 | ||||
| -rw-r--r-- | gcc/ada/utils.c | 100 | ||||
| -rw-r--r-- | gcc/ada/utils2.c | 127 |
8 files changed, 551 insertions, 315 deletions
diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c index 5a9c931..bbbb471 100644 --- a/gcc/ada/decl.c +++ b/gcc/ada/decl.c @@ -35,6 +35,7 @@ #include "ggc.h" #include "obstack.h" #include "target.h" +#include "expr.h" #include "ada.h" #include "types.h" @@ -52,21 +53,14 @@ #include "ada-tree.h" #include "gigi.h" -/* Provide default values for the macros controlling stack checking. - This is copied from GCC's expr.h. */ +/* Convention_Stdcall should be processed in a specific way on Windows targets + only. The macro below is a helper to avoid having to check for a Windows + specific attribute throughout this unit. */ -#ifndef STACK_CHECK_BUILTIN -#define STACK_CHECK_BUILTIN 0 -#endif -#ifndef STACK_CHECK_PROBE_INTERVAL -#define STACK_CHECK_PROBE_INTERVAL 4096 -#endif -#ifndef STACK_CHECK_MAX_FRAME_SIZE -#define STACK_CHECK_MAX_FRAME_SIZE \ - (STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD) -#endif -#ifndef STACK_CHECK_MAX_VAR_SIZE -#define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100) +#if TARGET_DLLIMPORT_DECL_ATTRIBUTES +#define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall) +#else +#define Has_Stdcall_Convention(E) (0) #endif /* These two variables are used to defer recursively expanding incomplete @@ -531,6 +525,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) || TREE_CODE (gnu_type) == VOID_TYPE) { gcc_assert (type_annotate_only); + if (this_global) + force_global--; return error_mark_node; } @@ -670,11 +666,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { tree gnu_fat = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity)))); - tree gnu_temp_type - = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat)))); gnu_type - = build_unc_object_type (gnu_temp_type, gnu_type, + = build_unc_object_type_from_ptr (gnu_fat, gnu_type, concat_id_with_name (gnu_entity_id, "UNC")); } @@ -729,18 +723,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) gnu_expr = convert (gnu_type, gnu_expr); - /* See if this is a renaming. If this is a constant renaming, treat - it as a normal variable whose initial value is what is being - renamed. We cannot do this if the type is unconstrained or - class-wide. + /* See if this is a renaming, and handle appropriately depending on + what is renamed and in which context. There are three major + cases: + + 1/ This is a constant renaming and we can just make an object + with what is renamed as its initial value, - Otherwise, if what we are renaming is a reference, we can simply - return a stabilized version of that reference, after forcing any - SAVE_EXPRs to be evaluated. But, if this is at global level, we - can only do this if we know no SAVE_EXPRs will be made. + 2/ We can reuse a stabilized version of what is renamed in place + of the renaming, - Otherwise, make this into a constant pointer to the object we are - to rename. */ + 3/ If neither 1 or 2 applies, we make the renaming entity a constant + pointer to what is being renamed. */ if (Present (Renamed_Object (gnat_entity))) { @@ -756,6 +750,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_type = TREE_TYPE (gnu_expr); } + /* Case 1: If this is a constant renaming, treat it as a normal + object whose initial value is what is being renamed. We cannot + do this if the type is unconstrained or class-wide. */ if (const_flag && !TREE_SIDE_EFFECTS (gnu_expr) && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE @@ -764,49 +761,100 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && !Is_Array_Type (Etype (gnat_entity))) ; - /* If this is a declaration or reference that we can stabilize, - just use that declaration or reference as this entity unless - the latter has to be materialized. */ - else if ((DECL_P (gnu_expr) || REFERENCE_CLASS_P (gnu_expr)) - && !Materialize_Entity (gnat_entity) - && (!global_bindings_p () - || (staticp (gnu_expr) - && !TREE_SIDE_EFFECTS (gnu_expr)))) - { - gnu_decl = gnat_stabilize_reference (gnu_expr, true); - save_gnu_tree (gnat_entity, gnu_decl, true); - saved = true; - break; - } - - /* Otherwise, make this into a constant pointer to the object we - are to rename and attach the object to the pointer. We need - to stabilize too since the renaming evaluation may directly - reference the renamed object instead of the pointer we will - attach it to. We don't want variables in the expression to - be evaluated every time the renaming is used, since their - value may change in between. */ + /* Otherwise, see if we can proceed with a stabilized version of + the renamed entity or if we need to make a pointer. */ else { - bool has_side_effects = TREE_SIDE_EFFECTS (gnu_expr); - inner_const_flag = TREE_READONLY (gnu_expr); - const_flag = true; - gnu_type = build_reference_type (gnu_type); - renamed_obj = gnat_stabilize_reference (gnu_expr, true); - gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj); - - if (!global_bindings_p ()) + bool stabilized; + tree maybe_stable_expr = NULL_TREE; + + /* Case 2: If the renaming entity need not be materialized and + the renamed expression is something we can stabilize, use + that for the renaming after forcing the evaluation of any + SAVE_EXPR. At the global level, we can only do this if we + know no SAVE_EXPRs will be made. */ + if (!Materialize_Entity (gnat_entity) + && (!global_bindings_p () + || (staticp (gnu_expr) + && !TREE_SIDE_EFFECTS (gnu_expr)))) { - /* If the original expression had side effects, put a - SAVE_EXPR around this whole thing. */ - if (has_side_effects) - gnu_expr = save_expr (gnu_expr); + maybe_stable_expr + = maybe_stabilize_reference (gnu_expr, true, false, + &stabilized); + + if (stabilized) + { + gnu_decl = maybe_stable_expr; + save_gnu_tree (gnat_entity, gnu_decl, true); + saved = true; + break; + } - add_stmt (gnu_expr); + /* The stabilization failed. Keep maybe_stable_expr + untouched here to let the pointer case below know + about that failure. */ } - gnu_size = NULL_TREE; - used_by_ref = true; + /* Case 3: Make this into a constant pointer to the object we + are to rename and attach the object to the pointer if it is + an lvalue that can be stabilized. + + From the proper scope, attached objects will be referenced + directly instead of indirectly via the pointer to avoid + subtle aliasing problems with non addressable entities. + They have to be stable because we must not evaluate the + variables in the expression every time the renaming is used. + They also have to be lvalues because the context in which + they are reused sometimes requires so. We call pointers + with an attached object "renaming" pointers. + + In the rare cases where we cannot stabilize the renamed + object, we just make a "bare" pointer, and the renamed + entity is always accessed indirectly through it. */ + { + bool has_side_effects = TREE_SIDE_EFFECTS (gnu_expr); + inner_const_flag = TREE_READONLY (gnu_expr); + const_flag = true; + gnu_type = build_reference_type (gnu_type); + + /* If a previous attempt at unrestricted + stabilization failed, there is no point trying + again and we can reuse the result without + attaching it to the pointer. */ + if (maybe_stable_expr) + ; + + /* Otherwise, try to stabilize now, restricting to + lvalues only, and attach the expression to the pointer + if the stabilization succeeds. */ + else + { + maybe_stable_expr + = maybe_stabilize_reference (gnu_expr, true, true, + &stabilized); + + if (stabilized) + renamed_obj = maybe_stable_expr; + /* Attaching is actually performed downstream, as soon + as we have a DECL for the pointer we make. */ + } + + gnu_expr + = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr); + + if (!global_bindings_p ()) + { + /* If the original expression had side effects, put a + SAVE_EXPR around this whole thing. */ + if (has_side_effects) + gnu_expr = save_expr (gnu_expr); + + add_stmt (gnu_expr); + } + + gnu_size = NULL_TREE; + used_by_ref = true; + } } } @@ -894,10 +942,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) imported. */ if ((!definition && Present (Address_Clause (gnat_entity))) || (Is_Imported (gnat_entity) - && Convention (gnat_entity) == Convention_Stdcall)) + && Has_Stdcall_Convention (gnat_entity))) { gnu_type = build_reference_type (gnu_type); gnu_size = NULL_TREE; + + gnu_expr = NULL_TREE; + /* No point in taking the address of an initializing expression + that isn't going to be used. */ + used_by_ref = true; } @@ -1495,19 +1548,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_READONLY (gnu_template_type) = 1; /* Make a node for the array. If we are not defining the array - suppress expanding incomplete types and save the node as the type - for GNAT_ENTITY. */ + suppress expanding incomplete types. */ gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE); + if (!definition) - { - defer_incomplete_level++; - this_deferred = this_made_decl = true; - gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - save_gnu_tree (gnat_entity, gnu_decl, false); - saved = true; - } + defer_incomplete_level++, this_deferred = true; /* Build the fat pointer type. Use a "void *" object instead of a pointer to the array type since we don't have the array type @@ -2310,9 +2355,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } /* Make a node for the record. If we are not defining the record, - suppress expanding incomplete types and save the node as the type - for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type - and reset TYPE_DUMMY_P to show it's no longer a dummy. + suppress expanding incomplete types. We use the same RECORD_TYPE + as for a dummy type and reset TYPE_DUMMY_P to show it's no longer + a dummy. It is very tempting to delay resetting this bit until we are done with completing the type, e.g. to let possible intermediate @@ -2335,15 +2380,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_PACKED (gnu_type) = packed || has_rep; if (!definition) - { - defer_incomplete_level++; - this_deferred = true; - gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); - save_gnu_tree (gnat_entity, gnu_decl, false); - this_made_decl = saved = true; - } + defer_incomplete_level++, this_deferred = true; /* If both a size and rep clause was specified, put the size in the record type now so that it can get the proper mode. */ @@ -3642,8 +3679,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (list_length (gnu_return_list) == 1) gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list)); -#ifdef TARGET_DLLIMPORT_DECL_ATTRIBUTES - if (Convention (gnat_entity) == Convention_Stdcall) + if (Has_Stdcall_Convention (gnat_entity)) { struct attrib *attr = (struct attrib *) xmalloc (sizeof (struct attrib)); @@ -3655,7 +3691,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) attr->error_point = gnat_entity; attr_list = attr; } -#endif /* Both lists ware built in reverse. */ gnu_param_list = nreverse (gnu_param_list); @@ -3766,14 +3801,23 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) compiling, then just get the type from its Etype. */ if (No (Full_View (gnat_entity))) { - /* If this is an incomplete type with no full view, it must - be a Taft Amendement type, so just return a dummy type. */ + /* If this is an incomplete type with no full view, it must be + either a limited view brought in by a limited_with clause, in + which case we use the non-limited view, or a Taft Amendement + type, in which case we just return a dummy type. */ if (kind == E_Incomplete_Type) - gnu_type = make_dummy_type (gnat_entity); + { + if (From_With_Type (gnat_entity) + && Present (Non_Limited_View (gnat_entity))) + gnu_decl = gnat_to_gnu_entity (Non_Limited_View (gnat_entity), + NULL_TREE, 0); + else + gnu_type = make_dummy_type (gnat_entity); + } - else if (Present (Underlying_Full_View (gnat_entity))) - gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity), - NULL_TREE, 0); + else if (Present (Underlying_Full_View (gnat_entity))) + gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity), + NULL_TREE, 0); else { gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), @@ -4087,7 +4131,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) DECL_ARTIFICIAL (gnu_decl) = 1; if (!debug_info_p && DECL_P (gnu_decl) - && TREE_CODE (gnu_decl) != FUNCTION_DECL) + && TREE_CODE (gnu_decl) != FUNCTION_DECL + && No (Renamed_Object (gnat_entity))) DECL_IGNORED_P (gnu_decl) = 1; /* If we haven't already, associate the ..._DECL node that we just made with @@ -4703,9 +4748,9 @@ elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity, gnu_decl = create_var_decl (create_concat_name (gnat_entity, IDENTIFIER_POINTER (gnu_name)), - NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true, - Is_Public (gnat_entity), !definition, false, NULL, - gnat_entity); + NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, + !need_debug, Is_Public (gnat_entity), + !definition, false, 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. */ @@ -5812,6 +5857,7 @@ annotate_value (tree gnu_size) case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break; case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break; case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break; + case BIT_AND_EXPR: tcode = Bit_And_Expr; break; case LT_EXPR: tcode = Lt_Expr; break; case LE_EXPR: tcode = Le_Expr; break; case GT_EXPR: tcode = Gt_Expr; break; @@ -5898,8 +5944,7 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type) Set_Esize (gnat_field, annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry)))); } - else if (type_annotate_only - && Is_Tagged_Type (gnat_entity) + else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity)) { /* If there is no gnu_entry, this is an inherited component whose @@ -6638,32 +6683,28 @@ rm_size (tree gnu_type) tree create_concat_name (Entity_Id gnat_entity, const char *suffix) { + Entity_Kind kind = Ekind (gnat_entity); + const char *str = (!suffix ? "" : suffix); String_Template temp = {1, strlen (str)}; Fat_Pointer fp = {str, &temp}; Get_External_Name_With_Suffix (gnat_entity, fp); -#ifdef TARGET_DLLIMPORT_DECL_ATTRIBUTES /* A variable using the Stdcall convention (meaning we are running on a Windows box) live in a DLL. Here we adjust its name to use the jump-table, the _imp__NAME contains the address for the NAME variable. */ - { - Entity_Kind kind = Ekind (gnat_entity); - const char *prefix = "_imp__"; - int plen = strlen (prefix); + if ((kind == E_Variable || kind == E_Constant) + && Has_Stdcall_Convention (gnat_entity)) + { + const char *prefix = "_imp__"; + int k, plen = strlen (prefix); - if ((kind == E_Variable || kind == E_Constant) - && Convention (gnat_entity) == Convention_Stdcall) - { - int k; - for (k = 0; k <= Name_Len; k++) - Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k]; - strncpy (Name_Buffer, prefix, plen); - } - } -#endif + for (k = 0; k <= Name_Len; k++) + Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k]; + strncpy (Name_Buffer, prefix, plen); + } return get_identifier (Name_Buffer); } diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h index 9dba805..6dd10ff 100644 --- a/gcc/ada/gigi.h +++ b/gcc/ada/gigi.h @@ -248,9 +248,21 @@ extern void init_code_table (void); called. */ extern Node_Id error_gnat_node; -/* This is equivalent to stabilize_reference in GCC's tree.c, but we know - how to handle our new nodes and we take an extra argument that says - whether to force evaluation of everything. */ +/* This is equivalent to stabilize_reference in GCC's tree.c, but we know how + to handle our new nodes and we take extra arguments. + + FORCE says whether to force evaluation of everything, + + SUCCESS we set to true unless we walk through something we don't + know how to stabilize, or through something which is not an lvalue + and LVALUES_ONLY is true, in which cases we set to false. */ +extern tree maybe_stabilize_reference (tree ref, bool force, bool lvalues_only, + bool *success); + +/* Wrapper around maybe_stabilize_reference, for common uses without + lvalue restrictions and without need to examine the success + indication. */ + extern tree gnat_stabilize_reference (tree ref, bool force); /* Highest number in the front-end node table. */ @@ -612,6 +624,11 @@ extern tree build_vms_descriptor (tree type, Mechanism_Type mech, extern tree build_unc_object_type (tree template_type, tree object_type, tree name); +/* Same as build_unc_object_type, but taking a thin or fat pointer type + instead of the template type. */ +extern tree build_unc_object_type_from_ptr (tree thin_fat_ptr_type, + tree object_type, tree name); + /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In the normal case this is just two adjustments, but we have more to do if NEW is an UNCONSTRAINED_ARRAY_TYPE. */ diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index a3e9e8a..ba1646b 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -48,6 +48,8 @@ with Table; use Table; with Uname; use Uname; with Urealp; use Urealp; +with Ada.Unchecked_Conversion; + package body Repinfo is SSU : constant := 8; @@ -61,17 +63,16 @@ package body Repinfo is -- Representation of gcc Expressions -- --------------------------------------- - -- This table is used only if Frontend_Layout_On_Target is False, - -- so that gigi lays out dynamic size/offset fields using encoded - -- gcc expressions. + -- This table is used only if Frontend_Layout_On_Target is False, so that + -- gigi lays out dynamic size/offset fields using encoded gcc + -- expressions. - -- A table internal to this unit is used to hold the values of - -- back annotated expressions. This table is written out by -gnatt - -- and read back in for ASIS processing. + -- A table internal to this unit is used to hold the values of back + -- annotated expressions. This table is written out by -gnatt and read + -- back in for ASIS processing. - -- Node values are stored as Uint values which are the negative of - -- the node index in this table. Constants appear as non-negative - -- Uint values. + -- Node values are stored as Uint values using the negative of the node + -- index in this table. Constants appear as non-negative Uint values. type Exp_Node is record Expr : TCode; @@ -104,28 +105,27 @@ package body Repinfo is -- Identifier casing for current unit Need_Blank_Line : Boolean; - -- Set True if a blank line is needed before outputting any - -- information for the current entity. Set True when a new - -- entity is processed, and false when the blank line is output. + -- Set True if a blank line is needed before outputting any information for + -- the current entity. Set True when a new entity is processed, and false + -- when the blank line is output. ----------------------- -- Local Subprograms -- ----------------------- function Back_End_Layout return Boolean; - -- Test for layout mode, True = back end, False = front end. This - -- function is used rather than checking the configuration parameter - -- because we do not want Repinfo to depend on Targparm (for ASIS) + -- Test for layout mode, True = back end, False = front end. This function + -- is used rather than checking the configuration parameter because we do + -- not want Repinfo to depend on Targparm (for ASIS) procedure Blank_Line; -- Called before outputting anything for an entity. Ensures that -- a blank line precedes the output for a particular entity. procedure List_Entities (Ent : Entity_Id); - -- This procedure lists the entities associated with the entity E, - -- starting with the First_Entity and using the Next_Entity link. - -- If a nested package is found, entities within the package are - -- recursively processed. + -- This procedure lists the entities associated with the entity E, starting + -- with the First_Entity and using the Next_Entity link. If a nested + -- package is found, entities within the package are recursively processed. procedure List_Name (Ent : Entity_Id); -- List name of entity Ent in appropriate case. The name is listed with @@ -135,8 +135,8 @@ package body Repinfo is -- List representation info for array type Ent procedure List_Mechanisms (Ent : Entity_Id); - -- List mechanism information for parameters of Ent, which is a - -- subprogram, subprogram type, or an entry or entry family. + -- List mechanism information for parameters of Ent, which is subprogram, + -- subprogram type, or an entry or entry family. procedure List_Object_Info (Ent : Entity_Id); -- List representation info for object Ent @@ -155,12 +155,11 @@ package body Repinfo is -- Output given number of spaces procedure Write_Info_Line (S : String); - -- Routine to write a line to Repinfo output file. This routine is - -- passed as a special output procedure to Output.Set_Special_Output. - -- Note that Write_Info_Line is called with an EOL character at the - -- end of each line, as per the Output spec, but the internal call - -- to the appropriate routine in Osint requires that the end of line - -- sequence be stripped off. + -- Routine to write a line to Repinfo output file. This routine is passed + -- as a special output procedure to Output.Set_Special_Output. Note that + -- Write_Info_Line is called with an EOL character at the end of each line, + -- as per the Output spec, but the internal call to the appropriate routine + -- in Osint requires that the end of line sequence be stripped off. procedure Write_Mechanism (M : Mechanism_Type); -- Writes symbolic string for mechanism represented by M @@ -168,8 +167,8 @@ package body Repinfo is procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False); -- Given a representation value, write it out. No_Uint values or values -- dependent on discriminants are written as two question marks. If the - -- flag Paren is set, then the output is surrounded in parentheses if - -- it is other than a simple value. + -- flag Paren is set, then the output is surrounded in parentheses if it is + -- other than a simple value. --------------------- -- Back_End_Layout -- @@ -177,8 +176,8 @@ package body Repinfo is function Back_End_Layout return Boolean is begin - -- We have back end layout if the back end has made any entries in - -- the table of GCC expressions, otherwise we have front end layout. + -- We have back end layout if the back end has made any entries in the + -- table of GCC expressions, otherwise we have front end layout. return Rep_Table.Last > 0; end Back_End_Layout; @@ -350,10 +349,10 @@ package body Repinfo is while Present (E) loop Need_Blank_Line := True; - -- We list entities that come from source (excluding private - -- or incomplete types or deferred constants, where we will - -- list the info for the full view). If debug flag A is set, - -- then all entities are listed + -- We list entities that come from source (excluding private or + -- incomplete types or deferred constants, where we will list the + -- info for the full view). If debug flag A is set, then all + -- entities are listed if (Comes_From_Source (E) and then not Is_Incomplete_Or_Private_Type (E) @@ -402,10 +401,9 @@ package body Repinfo is end if; - -- Recurse into nested package, but not if they are - -- package renamings (in particular renamings of the - -- enclosing package, as for some Java bindings and - -- for generic instances). + -- Recurse into nested package, but not if they are package + -- renamings (in particular renamings of the enclosing package, + -- as for some Java bindings and for generic instances). if Ekind (E) = E_Package then if No (Renamed_Object (E)) then @@ -438,10 +436,10 @@ package body Repinfo is E := Next_Entity (E); end loop; - -- For a package body, the entities of the visible subprograms - -- are declared in the corresponding spec. Iterate over its - -- entities in order to handle properly the subprogram bodies. - -- Skip bodies in subunits, which are listed independently. + -- For a package body, the entities of the visible subprograms are + -- declared in the corresponding spec. Iterate over its entities in + -- order to handle properly the subprogram bodies. Skip bodies in + -- subunits, which are listed independently. if Ekind (Ent) = E_Package_Body and then Present (Corresponding_Spec (Find_Declaration (Ent))) @@ -583,6 +581,9 @@ package body Repinfo is Write_Str ("not "); Print_Expr (Node.Op1); + when Bit_And_Expr => + Binop (" & "); + when Lt_Expr => Binop (" < "); @@ -801,9 +802,9 @@ package body Repinfo is UI_Image (Sunit); end if; - -- If the record is not packed, then we know that all - -- fields whose position is not specified have a starting - -- normalized bit position of zero + -- If the record is not packed, then we know that all fields whose + -- position is not specified have a starting normalized bit + -- position of zero if Unknown_Normalized_First_Bit (Comp) and then not Is_Packed (Ent) @@ -885,11 +886,11 @@ package body Repinfo is UI_Write (Fbit); Write_Str (" .. "); - -- Allowing Uint_0 here is a kludge, really this should be - -- a fine Esize value but currently it means unknown, except - -- that we know after gigi has back annotated that a size of - -- zero is real, since otherwise gigi back annotates using - -- No_Uint as the value to indicate unknown). + -- Allowing Uint_0 here is a kludge, really this should be a + -- fine Esize value but currently it means unknown, except that + -- we know after gigi has back annotated that a size of zero is + -- real, since otherwise gigi back annotates using No_Uint as + -- the value to indicate unknown). if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp)) and then Known_Static_Normalized_First_Bit (Comp) @@ -916,8 +917,8 @@ package body Repinfo is Write_Val (Esiz, Paren => True); - -- If in front end layout mode, then dynamic size is - -- stored in storage units, so renormalize for output + -- If in front end layout mode, then dynamic size is stored + -- in storage units, so renormalize for output if not Back_End_Layout then Write_Str (" * "); @@ -1019,8 +1020,8 @@ package body Repinfo is Write_Line (";"); -- For now, temporary case, to be removed when gigi properly back - -- annotates RM_Size, if RM_Size is not set, then list Esize as - -- Size. This avoids odd Object_Size output till we fix things??? + -- annotates RM_Size, if RM_Size is not set, then list Esize as Size. + -- This avoids odd Object_Size output till we fix things??? elsif Unknown_RM_Size (Ent) then Write_Str ("for "); @@ -1086,6 +1087,14 @@ package body Repinfo is function V (Val : Node_Ref_Or_Val) return Uint; -- Internal recursive routine to evaluate tree + function W (Val : Uint) return Word; + -- Convert Val to Word, assuming Val is always in the Int range. This is + -- a helper function for the evaluation of bitwise expressions like + -- Bit_And_Expr, for which there is no direct support in uintp. Uint + -- values out of the Int range are expected to be seen in such + -- expressions only with overflowing byte sizes around, introducing + -- inherent unreliabilties in computations anyway. + ------- -- B -- ------- @@ -1113,6 +1122,23 @@ package body Repinfo is end T; ------- + -- W -- + ------- + + -- We use an unchecked conversion to map Int values to their Word + -- bitwise equivalent, which we could not achieve with a normal type + -- conversion for negative Ints. We want bitwise equivalents because W + -- is used as a helper for bit operators like Bit_And_Expr, and can be + -- called for negative Ints in the context of aligning expressions like + -- X+Align & -Align. + + function W (Val : Uint) return Word is + function To_Word is new Ada.Unchecked_Conversion (Int, Word); + begin + return To_Word (UI_To_Int (Val)); + end W; + + ------- -- V -- ------- @@ -1203,6 +1229,11 @@ package body Repinfo is when Truth_Not_Expr => return B (not T (Node.Op1)); + when Bit_And_Expr => + L := V (Node.Op1); + R := V (Node.Op2); + return UI_From_Int (Int (W (L) and W (R))); + when Lt_Expr => return B (V (Node.Op1) < V (Node.Op2)); diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index 2af09cb..9fc16c2 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2005, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,7 @@ -- tree to fill in representation information, and also the routine used -- by -gnatR to print this information. This unit is used both in the -- compiler and in ASIS (it is used in ASIS as part of the implementation --- of the data decomposition annex. +-- of the data decomposition annex). with Types; use Types; with Uintp; use Uintp; @@ -128,7 +128,7 @@ package Repinfo is -- Subtype used for values that can either be a Node_Ref (negative) -- or a value (non-negative) - type TCode is range 0 .. 27; + type TCode is range 0 .. 28; -- Type used on Ada side to represent DEFTREECODE values defined in -- tree.def. Only a subset of these tree codes can actually appear. -- The names are the names from tree.def in Ada casing. @@ -162,6 +162,7 @@ package Repinfo is Ge_Expr : constant TCode := 25; -- comparision >= 2 Eq_Expr : constant TCode := 26; -- comparision = 2 Ne_Expr : constant TCode := 27; -- comparision /= 2 + Bit_And_Expr : constant TCode := 28; -- Binary and 2 -- The following entry is used to represent a discriminant value in -- the tree. It has a special tree code that does not correspond diff --git a/gcc/ada/repinfo.h b/gcc/ada/repinfo.h index 672ff29..ec5452d 100644 --- a/gcc/ada/repinfo.h +++ b/gcc/ada/repinfo.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1999-2002 Free Software Foundation, Inc. * + * Copyright (C) 1999-2005 Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -67,6 +67,7 @@ typedef char TCode; #define Ge_Expr 25 #define Eq_Expr 26 #define Ne_Expr 27 +#define Bit_And_Expr 28 /* Creates a node using the tree code defined by Expr and from 1-3 operands as required (unused operands set as shown to No_Uint) Note diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index d685fb3..918f374 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -408,13 +408,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) else if (TREE_CODE (gnu_result) == VAR_DECL && (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0 && (! DECL_RENAMING_GLOBAL_P (gnu_result) - || global_bindings_p ()) - /* Make sure it's an lvalue like INDIRECT_REF. */ - && (DECL_P (renamed_obj) - || REFERENCE_CLASS_P (renamed_obj) - || (TREE_CODE (renamed_obj) == VIEW_CONVERT_EXPR - && (DECL_P (TREE_OPERAND (renamed_obj, 0)) - || REFERENCE_CLASS_P (TREE_OPERAND (renamed_obj,0)))))) + || global_bindings_p ())) gnu_result = renamed_obj; else gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, @@ -719,6 +713,21 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) = size_binop (MAX_EXPR, gnu_result, DECL_SIZE (TREE_OPERAND (gnu_expr, 1))); } + else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference) + { + Node_Id gnat_deref = Prefix (gnat_node); + Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref); + tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref))); + if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type) + && Present (gnat_actual_subtype)) + { + tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype); + gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type, + gnu_actual_obj_type, get_identifier ("SIZE")); + } + + gnu_result = TYPE_SIZE (gnu_type); + } else gnu_result = TYPE_SIZE (gnu_type); } @@ -1564,8 +1573,15 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 0, Etype (Name (gnat_node)), "PAD", false, false, false); - gnu_target = create_tmp_var_raw (gnu_obj_type, "LR"); - gnat_pushdecl (gnu_target, gnat_node); + /* ??? We may be about to create a static temporary if we happen to + be at the global binding level. That's a regression from what + the 3.x back-end would generate in the same situation, but we + don't have a mechanism in Gigi for creating automatic variables + in the elaboration routines. */ + gnu_target + = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type, + NULL, false, false, false, false, NULL, + gnat_node); } gnu_actual_list @@ -1602,6 +1618,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) tree gnu_formal = (present_gnu_tree (gnat_formal) ? get_gnu_tree (gnat_formal) : NULL_TREE); + tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); /* We treat a conversion between aggregate types as if it is an unchecked conversion. */ bool unchecked_convert_p @@ -1613,7 +1630,6 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) tree gnu_name = gnat_to_gnu (gnat_name); tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)); tree gnu_actual; - tree gnu_formal_type; /* If it's possible we may need to use this expression twice, make sure than any side-effects are handled via SAVE_EXPRs. Likewise if we need @@ -1626,6 +1642,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) if (Ekind (gnat_formal) != E_In_Parameter) { gnu_name = gnat_stabilize_reference (gnu_name, true); + if (!addressable_p (gnu_name) && gnu_formal && (DECL_BY_REF_P (gnu_formal) @@ -1741,6 +1758,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual); + if (TREE_CODE (gnu_actual) != SAVE_EXPR) + gnu_actual = convert (gnu_formal_type, gnu_actual); + /* If we have not saved a GCC object for the formal, it means it is an OUT parameter not passed by reference and that does not need to be copied in. Otherwise, look at the PARM_DECL to see if it is passed by @@ -1989,7 +2009,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result))))) gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result); } - + gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_actual, gnu_result); annotate_with_node (gnu_result, gnat_actual); @@ -2497,25 +2517,40 @@ gnat_to_gnu (Node_Id gnat_node) return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)), build_call_raise (CE_Range_Check_Failed)); - /* 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 - and push our context. */ - if (!current_function_decl - && ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call) - && Nkind (gnat_node) != N_Null_Statement) - || Nkind (gnat_node) == N_Procedure_Call_Statement - || Nkind (gnat_node) == N_Label - || Nkind (gnat_node) == N_Implicit_Label_Declaration - || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements - || ((Nkind (gnat_node) == N_Raise_Constraint_Error - || Nkind (gnat_node) == N_Raise_Storage_Error - || Nkind (gnat_node) == N_Raise_Program_Error) - && (Ekind (Etype (gnat_node)) == E_Void)))) + /* 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 and push our + context. + + If we are in the elaboration procedure, check if we are violating a a + No_Elaboration_Code restriction by having a statement there. */ + if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call) + && Nkind (gnat_node) != N_Null_Statement) + || Nkind (gnat_node) == N_Procedure_Call_Statement + || Nkind (gnat_node) == N_Label + || Nkind (gnat_node) == N_Implicit_Label_Declaration + || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements + || ((Nkind (gnat_node) == N_Raise_Constraint_Error + || Nkind (gnat_node) == N_Raise_Storage_Error + || Nkind (gnat_node) == N_Raise_Program_Error) + && (Ekind (Etype (gnat_node)) == E_Void))) { - current_function_decl = TREE_VALUE (gnu_elab_proc_stack); - start_stmt_group (); - gnat_pushlevel (); - went_into_elab_proc = true; + if (!current_function_decl) + { + current_function_decl = TREE_VALUE (gnu_elab_proc_stack); + start_stmt_group (); + gnat_pushlevel (); + went_into_elab_proc = true; + } + + /* Don't check for a possible No_Elaboration_Code restriction violation + on N_Handled_Sequence_Of_Statements, as we want to signal an error on + 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 == TREE_VALUE (gnu_elab_proc_stack) + && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements) + Check_Elaboration_Code_Allowed (gnat_node); } switch (Nkind (gnat_node)) @@ -2982,7 +3017,7 @@ gnat_to_gnu (Node_Id gnat_node) ? Designated_Type (Etype (Prefix (gnat_node))) : Etype (Prefix (gnat_node)))) - gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0); + gnu_prefix = gnat_stabilize_reference (gnu_prefix, false); gnu_result = build_component_ref (gnu_prefix, NULL_TREE, gnu_field, @@ -3427,7 +3462,7 @@ gnat_to_gnu (Node_Id gnat_node) /* If the type has a size that overflows, convert this into raise of Storage_Error: execution shouldn't have gotten here anyway. */ if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST - && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs)))) + && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs)))) gnu_result = build_call_raise (SE_Object_Too_Large); else if (Nkind (Expression (gnat_node)) == N_Function_Call && !Do_Range_Check (Expression (gnat_node))) @@ -3927,7 +3962,9 @@ gnat_to_gnu (Node_Id gnat_node) if (!type_annotate_only) { tree gnu_ptr = gnat_to_gnu (Expression (gnat_node)); + tree gnu_ptr_type = TREE_TYPE (gnu_ptr); tree gnu_obj_type; + tree gnu_actual_obj_type = 0; tree gnu_obj_size; int align; @@ -3952,7 +3989,21 @@ gnat_to_gnu (Node_Id gnat_node) gnu_ptr); gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); - gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type); + + if (Present (Actual_Designated_Subtype (gnat_node))) + { + gnu_actual_obj_type = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node)); + + if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) + gnu_actual_obj_type + = build_unc_object_type_from_ptr (gnu_ptr_type, + gnu_actual_obj_type, + get_identifier ("DEALLOC")); + } + else + gnu_actual_obj_type = gnu_obj_type; + + gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type); align = TYPE_ALIGN (gnu_obj_type); if (TREE_CODE (gnu_obj_type) == RECORD_TYPE @@ -4106,7 +4157,7 @@ gnat_to_gnu (Node_Id gnat_node) if (TREE_SIDE_EFFECTS (gnu_result) && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))) - gnu_result = gnat_stabilize_reference (gnu_result, 0); + gnu_result = gnat_stabilize_reference (gnu_result, false); /* Now convert the result to the proper type. If the type is void or if we have no result, return error_mark_node to show we have no result. @@ -5709,17 +5760,26 @@ protect_multiple_eval (tree exp) exp))); } -/* This is equivalent to stabilize_reference in GCC's tree.c, but we know - how to handle our new nodes and we take an extra argument that says - whether to force evaluation of everything. */ +/* This is equivalent to stabilize_reference in GCC's tree.c, but we know how + to handle our new nodes and we take extra arguments: + + FORCE says whether to force evaluation of everything, + + SUCCESS we set to true unless we walk through something we don't know how + to stabilize, or through something which is not an lvalue and LVALUES_ONLY + is true, in which cases we set to false. */ tree -gnat_stabilize_reference (tree ref, bool force) +maybe_stabilize_reference (tree ref, bool force, bool lvalues_only, + bool *success) { tree type = TREE_TYPE (ref); enum tree_code code = TREE_CODE (ref); tree result; + /* Assume we'll success unless proven otherwise. */ + *success = true; + switch (code) { case VAR_DECL: @@ -5728,6 +5788,15 @@ gnat_stabilize_reference (tree ref, bool force) /* No action is needed in this case. */ return ref; + case ADDR_EXPR: + /* A standalone ADDR_EXPR is never an lvalue, and this one can't + be nested inside an outer INDIRECT_REF, since INDIREC_REF goes + straight to stabilize_1. */ + if (lvalues_only) + goto failure; + + /* ... Fallthru ... */ + case NOP_EXPR: case CONVERT_EXPR: case FLOAT_EXPR: @@ -5736,10 +5805,10 @@ gnat_stabilize_reference (tree ref, bool force) case FIX_ROUND_EXPR: case FIX_CEIL_EXPR: case VIEW_CONVERT_EXPR: - case ADDR_EXPR: result = build1 (code, type, - gnat_stabilize_reference (TREE_OPERAND (ref, 0), force)); + maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, + lvalues_only, success)); break; case INDIRECT_REF: @@ -5750,15 +5819,16 @@ gnat_stabilize_reference (tree ref, bool force) break; case COMPONENT_REF: - result = build3 (COMPONENT_REF, type, - gnat_stabilize_reference (TREE_OPERAND (ref, 0), - force), - TREE_OPERAND (ref, 1), NULL_TREE); + result = build3 (COMPONENT_REF, type, + maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, + lvalues_only, success), + TREE_OPERAND (ref, 1), NULL_TREE); break; case BIT_FIELD_REF: result = build3 (BIT_FIELD_REF, type, - gnat_stabilize_reference (TREE_OPERAND (ref, 0), force), + maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, + lvalues_only, success), gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), force), gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2), @@ -5768,7 +5838,8 @@ gnat_stabilize_reference (tree ref, bool force) case ARRAY_REF: case ARRAY_RANGE_REF: result = build4 (code, type, - gnat_stabilize_reference (TREE_OPERAND (ref, 0), force), + maybe_stabilize_reference (TREE_OPERAND (ref, 0), force, + lvalues_only, success), gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1), force), NULL_TREE, NULL_TREE); @@ -5778,17 +5849,21 @@ gnat_stabilize_reference (tree ref, bool force) result = build2 (COMPOUND_EXPR, type, gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0), force), - gnat_stabilize_reference (TREE_OPERAND (ref, 1), - force)); + maybe_stabilize_reference (TREE_OPERAND (ref, 1), force, + lvalues_only, success)); break; + case ERROR_MARK: + ref = error_mark_node; + + /* ... Fallthru to failure ... */ + /* If arg isn't a kind of lvalue we recognize, make no change. Caller should recognize the error for an invalid lvalue. */ default: + failure: + *success = false; return ref; - - case ERROR_MARK: - return error_mark_node; } TREE_READONLY (result) = TREE_READONLY (ref); @@ -5808,6 +5883,17 @@ gnat_stabilize_reference (tree ref, bool force) return result; } +/* Wrapper around maybe_stabilize_reference, for common uses without + lvalue restrictions and without need to examine the success + indication. */ + +tree +gnat_stabilize_reference (tree ref, bool force) +{ + bool stabilized; + return maybe_stabilize_reference (ref, force, false, &stabilized); +} + /* Similar to stabilize_reference_1 in tree.c, but supports an extra arg to force a SAVE_EXPR for everything. */ diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c index 1bf0007..2bfafce 100644 --- a/gcc/ada/utils.c +++ b/gcc/ada/utils.c @@ -324,7 +324,13 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL) DECL_CONTEXT (decl) = 0; else - DECL_CONTEXT (decl) = current_function_decl; + { + DECL_CONTEXT (decl) = current_function_decl; + + /* Functions imported in another function are not really nested. */ + if (TREE_CODE (decl) == FUNCTION_DECL && TREE_PUBLIC (decl)) + DECL_NO_STATIC_CHAIN (decl) = 1; + } TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node)); @@ -1277,6 +1283,12 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init, || (type_annotate_only && var_init && !TREE_CONSTANT (var_init))) var_init = NULL_TREE; + /* At the global level, an initializer requiring code to be generated + produces elaboration statements. Check that such statements are allowed, + that is, not violating a No_Elaboration_Code restriction. */ + if (global_bindings_p () && var_init != 0 && ! init_const) + Check_Elaboration_Code_Allowed (gnat_node); + /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't try to fiddle with DECL_COMMON. However, on platforms that don't support global BSS sections, uninitialized global variables would @@ -1313,6 +1325,10 @@ create_var_decl (tree var_name, tree asm_name, tree type, tree var_init, if (TREE_CODE (var_decl) != CONST_DECL) rest_of_decl_compilation (var_decl, global_bindings_p (), 0); + else + /* expand CONST_DECLs to set their MODE, ALIGN, SIZE and SIZE_UNIT, + which we need for later back-annotations. */ + expand_decl (var_decl); return var_decl; } @@ -1607,7 +1623,7 @@ potential_alignment_gap (tree prev_field, tree curr_field, tree offset) % DECL_ALIGN (curr_field) != 0); /* If both the position and size of the previous field are multiples - of the current field alignment, there can not be any gap. */ + of the current field alignment, there cannot be any gap. */ if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field)) && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field))) return false; @@ -2444,6 +2460,22 @@ build_unc_object_type (tree template_type, tree object_type, tree name) return type; } + +/* Same, taking a thin or fat pointer type instead of a template type. */ + +tree +build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, tree name) +{ + tree template_type; + + gcc_assert (TYPE_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type)); + + template_type + = (TYPE_FAT_POINTER_P (thin_fat_ptr_type) + ? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (thin_fat_ptr_type)))) + : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type)))); + return build_unc_object_type (template_type, object_type, name); +} /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In the normal case this is just two adjustments, but we have more to do @@ -2755,11 +2787,15 @@ convert (tree type, tree expr) expr)), TYPE_MIN_VALUE (etype)))); - /* If the input is a justified modular type, we need to extract - the actual object before converting it to any other type with the - exception of an unconstrained array. */ + /* If the input is a justified modular type, we need to extract the actual + object before converting it to any other type with the exceptions of an + unconstrained array or of a mere type variant. It is useful to avoid the + extraction and conversion in the type variant case because it could end + up replacing a VAR_DECL expr by a constructor and we might be about the + take the address of the result. */ if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype) - && code != UNCONSTRAINED_ARRAY_TYPE) + && code != UNCONSTRAINED_ARRAY_TYPE + && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype)) return convert (type, build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false)); @@ -2804,9 +2840,7 @@ convert (tree type, tree expr) just make a new one in the proper type. */ if (code == ecode && AGGREGATE_TYPE_P (etype) && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST - && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST) - && (TREE_CODE (expr) == STRING_CST - || get_alias_set (etype) == get_alias_set (type))) + && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)) { expr = copy_node (expr); TREE_TYPE (expr) = type; @@ -2826,9 +2860,40 @@ convert (tree type, tree expr) break; case VIEW_CONVERT_EXPR: - if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype) - && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)) - return convert (type, TREE_OPERAND (expr, 0)); + { + /* GCC 4.x is very sensitive to type consistency overall, and view + conversions thus are very frequent. Eventhough just "convert"ing + the inner operand to the output type is fine in most cases, it + might expose unexpected input/output type mismatches in special + circumstances so we avoid such recursive calls when we can. */ + + tree op0 = TREE_OPERAND (expr, 0); + + /* If we are converting back to the original type, we can just + lift the input conversion. This is a common occurence with + switches back-and-forth amongst type variants. */ + if (type == TREE_TYPE (op0)) + return op0; + + /* Otherwise, if we're converting between two aggregate types, we + might be allowed to substitute the VIEW_CONVERT target type in + place or to just convert the inner expression. */ + if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)) + { + /* If we are converting between type variants, we can just + substitute the VIEW_CONVERT in place. */ + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)) + return build1 (VIEW_CONVERT_EXPR, type, op0); + + /* Otherwise, we may just bypass the input view conversion unless + one of the types is a fat pointer, or we're converting to an + unchecked union type. Both are handled by specialized code + below and the latter relies on exact type matching. */ + else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype) + && !(code == UNION_TYPE && TYPE_UNCHECKED_UNION_P (type))) + return convert (type, op0); + } + } break; case INDIRECT_REF: @@ -2957,13 +3022,10 @@ convert (tree type, tree expr) { if (TREE_TYPE (tem) == etype) return build1 (CONVERT_EXPR, type, expr); - - /* Accept slight type variations. */ - if (TREE_TYPE (tem) == TYPE_MAIN_VARIANT (etype) - || (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE - && (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem)) - || TYPE_IS_PADDING_P (TREE_TYPE (tem))) - && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype)) + else if (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE + && (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem)) + || TYPE_IS_PADDING_P (TREE_TYPE (tem))) + && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype) return build1 (CONVERT_EXPR, type, convert (TREE_TYPE (tem), expr)); } diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c index 21a3f61..2493744 100644 --- a/gcc/ada/utils2.c +++ b/gcc/ada/utils2.c @@ -170,7 +170,7 @@ known_alignment (tree exp) case NON_LVALUE_EXPR: /* Conversions between pointers and integers don't change the alignment of the underlying object. */ - this_alignment = known_alignment (TREE_OPERAND (exp, 0)); + this_alignment = known_alignment (TREE_OPERAND (exp, 0)); break; case PLUS_EXPR: @@ -656,40 +656,6 @@ build_binary_op (enum tree_code op_code, tree result_type, if (!operation_type) operation_type = left_type; - /* If the RHS has a conversion between record and array types and - an inner type is no worse, use it. Note we cannot do this for - modular types or types with TYPE_ALIGN_OK, since the latter - might indicate a conversion between a root type and a class-wide - type, which we must not remove. */ - while (TREE_CODE (right_operand) == VIEW_CONVERT_EXPR - && (((TREE_CODE (right_type) == RECORD_TYPE - || TREE_CODE (right_type) == UNION_TYPE) - && !TYPE_JUSTIFIED_MODULAR_P (right_type) - && !TYPE_ALIGN_OK (right_type) - && !TYPE_IS_FAT_POINTER_P (right_type)) - || TREE_CODE (right_type) == ARRAY_TYPE) - && ((((TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0))) - == RECORD_TYPE) - || (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0))) - == UNION_TYPE)) - && !(TYPE_JUSTIFIED_MODULAR_P - (TREE_TYPE (TREE_OPERAND (right_operand, 0)))) - && !(TYPE_ALIGN_OK - (TREE_TYPE (TREE_OPERAND (right_operand, 0)))) - && !(TYPE_IS_FAT_POINTER_P - (TREE_TYPE (TREE_OPERAND (right_operand, 0))))) - || (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0))) - == ARRAY_TYPE)) - && (0 == (best_type - = find_common_type (right_type, - TREE_TYPE (TREE_OPERAND - (right_operand, 0)))) - || right_type != best_type)) - { - right_operand = TREE_OPERAND (right_operand, 0); - right_type = TREE_TYPE (right_operand); - } - /* If we are copying one array or record to another, find the best type to use. */ if (((TREE_CODE (left_type) == ARRAY_TYPE @@ -1159,12 +1125,18 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) return build_unary_op (ADDR_EXPR, result_type, TREE_OPERAND (operand, 0)); - /* If this NOP_EXPR doesn't change the mode, get the result type - from this type and go down. We need to do this in case - this is a conversion of a CONST_DECL. */ - if (TYPE_MODE (type) != BLKmode - && (TYPE_MODE (type) - == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0))))) + /* ... fallthru ... */ + + case VIEW_CONVERT_EXPR: + /* If this just a variant conversion or if the conversion doesn't + change the mode, get the result type from this type and go down. + This is needed for conversions of CONST_DECLs, to eventually get + to the address of their CORRESPONDING_VARs. */ + if ((TYPE_MAIN_VARIANT (type) + == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0)))) + || (TYPE_MODE (type) != BLKmode + && (TYPE_MODE (type) + == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0)))))) return build_unary_op (ADDR_EXPR, (result_type ? result_type : build_pointer_type (type)), @@ -1409,7 +1381,7 @@ build_return_expr (tree result_decl, tree ret_val) build_binary_op with the additional guarantee that the type cannot involve a placeholder, since otherwise the function would use the "target pointer" return mechanism. */ - + if (operation_type != TREE_TYPE (ret_val)) ret_val = convert (operation_type, ret_val); @@ -1493,17 +1465,41 @@ build_call_raise (int msg) build_int_cst (NULL_TREE, input_line)); } +/* qsort comparer for the bit positions of two constructor elements + for record components. */ + +static int +compare_elmt_bitpos (const PTR rt1, const PTR rt2) +{ + tree elmt1 = * (tree *) rt1; + tree elmt2 = * (tree *) rt2; + + tree pos_field1 = bit_position (TREE_PURPOSE (elmt1)); + tree pos_field2 = bit_position (TREE_PURPOSE (elmt2)); + + if (tree_int_cst_equal (pos_field1, pos_field2)) + return 0; + else if (tree_int_cst_lt (pos_field1, pos_field2)) + return -1; + else + return 1; +} + /* Return a CONSTRUCTOR of TYPE whose list is LIST. */ tree gnat_build_constructor (tree type, tree list) { tree elmt; + int n_elmts; bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST); bool side_effects = false; tree result; - for (elmt = list; elmt; elmt = TREE_CHAIN (elmt)) + /* Scan the elements to see if they are all constant or if any has side + effects, to let us set global flags on the resulting constructor. Count + the elements along the way for possible sorting purposes below. */ + for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++) { if (!TREE_CONSTANT (TREE_VALUE (elmt)) || (TREE_CODE (type) == RECORD_TYPE @@ -1525,26 +1521,30 @@ gnat_build_constructor (tree type, tree list) return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0)); } - /* If TYPE is a RECORD_TYPE and the fields are not in the - same order as their bit position, don't treat this as constant - since varasm.c can't handle it. */ - if (allconstant && TREE_CODE (type) == RECORD_TYPE) + /* For record types with constant components only, sort field list + by increasing bit position. This is necessary to ensure the + constructor can be output as static data, which the gimplifier + might force in various circumstances. */ + if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1) { - tree last_pos = bitsize_zero_node; - tree field; + /* Fill an array with an element tree per index, and ask qsort to order + them according to what a bitpos comparison function says. */ - for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) - { - tree this_pos = bit_position (field); + tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts); + int i; - if (TREE_CODE (this_pos) != INTEGER_CST - || tree_int_cst_lt (this_pos, last_pos)) - { - allconstant = false; - break; - } + for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++) + gnu_arr[i] = elmt; + + qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos); - last_pos = this_pos; + /* Then reconstruct the list from the sorted array contents. */ + + list = NULL_TREE; + for (i = n_elmts - 1; i >= 0; i--) + { + TREE_CHAIN (gnu_arr[i]) = list; + list = gnu_arr[i]; } } @@ -1821,13 +1821,10 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, fill in the parts that are known. */ else if (TYPE_FAT_OR_THIN_POINTER_P (result_type)) { - tree template_type - = (TYPE_FAT_POINTER_P (result_type) - ? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (result_type)))) - : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (result_type)))); tree storage_type - = build_unc_object_type (template_type, type, - get_identifier ("ALLOC")); + = build_unc_object_type_from_ptr (result_type, type, + get_identifier ("ALLOC")); + tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type)); tree storage_ptr_type = build_pointer_type (storage_type); tree storage; tree template_cons = NULL_TREE; |