diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 22 | ||||
| -rw-r--r-- | gcc/ada/atree.adb | 83 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 93 | ||||
| -rw-r--r-- | gcc/ada/atree.h | 20 | ||||
| -rw-r--r-- | gcc/ada/back_end.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/gigi.h | 10 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 29 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 20 |
9 files changed, 248 insertions, 37 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0ae1c7a..1a872b2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2014-01-21 Robert Dewar <dewar@adacore.com> + + * gcc-interface/gigi.h: Get Flags array address. + * gcc-interface/trans.c: Acquire Flags array address. + * atree.adb: Add support for Flags array and Flag0,1,2,3. + * atree.ads: Add support for Flags array and Flag0,1,2,3. + * atree.h: Add support for Flags array and Flag0,1,2,3. + * back_end.adb: Pass Flags array address to gigi. + +2014-01-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Attribute_Renaming): Transfer original attribute + reference to generated body so that legality checks on stream + attributes are properly applied. If type is tagged and already + frozen, insert generated body at the point of the renaming + declaration. + +2014-01-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb: Code clean up. + * sem_ch8.adb: Minor reformatting + 2014-01-20 Robert Dewar <dewar@adacore.com> * checks.adb: Check SPARK_Mode instead of GNATProve_Mode for diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index e7d4b20..ee53b97 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -568,14 +568,17 @@ package body Atree is and then Src = Nodes.Last then New_Id := Src; + else -- We are allocating a new node, or extending a node -- other than Nodes.Last. if Present (Src) then Nodes.Append (Nodes.Table (Src)); + Flags.Append (Flags.Table (Src)); else Nodes.Append (Default_Node); + Flags.Append (Default_Flags); end if; New_Id := Nodes.Last; @@ -596,10 +599,12 @@ package body Atree is if Present (Src) and then Has_Extension (Src) then for J in 1 .. Num_Extension_Nodes loop Nodes.Append (Nodes.Table (Src + Node_Id (J))); + Flags.Append (Flags.Table (Src + Node_Id (J))); end loop; else for J in 1 .. Num_Extension_Nodes loop Nodes.Append (Default_Node_Extension); + Flags.Append (Default_Flags); end loop; end if; end if; @@ -680,6 +685,8 @@ package body Atree is Nodes.Table (N).Nkind := New_Node_Kind; Nodes.Table (N).Error_Posted := Save_Posted; + Flags.Table (N) := Default_Flags; + if New_Node_Kind in N_Subexpr then Set_Paren_Count (N, Par_Count); end if; @@ -718,6 +725,8 @@ package body Atree is Nodes.Table (Destination).In_List := Save_In_List; Nodes.Table (Destination).Link := Save_Link; + Flags.Table (Destination) := Flags.Table (Source); + -- Specifically set Paren_Count to make sure auxiliary table entry -- gets correctly made if the parentheses count is at the max value. @@ -725,7 +734,8 @@ package body Atree is Set_Paren_Count (Destination, Paren_Count (Source)); end if; - -- Deal with copying extension nodes if present + -- Deal with copying extension nodes if present. No need to copy flags + -- table entries, since they are always zero for extending components. if Has_Extension (Source) then pragma Assert (Has_Extension (Destination)); @@ -1094,6 +1104,7 @@ package body Atree is procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id) is Temp_Ent : Node_Record; + Temp_Flg : Flags_Byte; begin pragma Assert (Has_Extension (E1) @@ -1127,6 +1138,13 @@ package body Atree is Nodes.Table (E1 + 5) := Nodes.Table (E2 + 5); Nodes.Table (E2 + 5) := Temp_Ent; + -- Exchange flag bytes for first component. No need to do the exchange + -- for the other components, since the flag bytes are always zero. + + Temp_Flg := Flags.Table (E1); + Flags.Table (E1) := Flags.Table (E2); + Flags.Table (E2) := Temp_Flg; + -- That exchange exchanged the parent pointers as well, which is what -- we want, but we need to patch up the defining identifier pointers -- in the parent nodes (the child pointers) to match this switch @@ -1231,6 +1249,15 @@ package body Atree is Fix_Parent (Field5 (Fix_Node)); end Fix_Parents; + ------------------- + -- Flags_Address -- + ------------------- + + function Flags_Address return System.Address is + begin + return Flags.Table (First_Node_Id)'Address; + end Flags_Address; + ----------------------------------- -- Get_Comes_From_Source_Default -- ----------------------------------- @@ -1270,6 +1297,7 @@ package body Atree is begin Node_Count := 0; Atree_Private_Part.Nodes.Init; + Atree_Private_Part.Flags.Init; Orig_Nodes.Init; Paren_Counts.Init; @@ -1320,8 +1348,10 @@ package body Atree is procedure Lock is begin Nodes.Locked := True; + Flags.Locked := True; Orig_Nodes.Locked := True; Nodes.Release; + Flags.Release; Orig_Nodes.Release; end Lock; @@ -2157,6 +2187,7 @@ package body Atree is begin Tree_Read_Int (Node_Count); Nodes.Tree_Read; + Flags.Tree_Read; Orig_Nodes.Tree_Read; Paren_Counts.Tree_Read; end Tree_Read; @@ -2169,6 +2200,7 @@ package body Atree is begin Tree_Write_Int (Node_Count); Nodes.Tree_Write; + Flags.Tree_Write; Orig_Nodes.Tree_Write; Paren_Counts.Tree_Write; end Tree_Write; @@ -3006,6 +3038,30 @@ package body Atree is return From_Union (Nodes.Table (N + 3).Field8); end Ureal21; + function Flag0 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Flags.Table (N).Flag0; + end Flag0; + + function Flag1 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Flags.Table (N).Flag1; + end Flag1; + + function Flag2 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Flags.Table (N).Flag2; + end Flag2; + + function Flag3 (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Flags.Table (N).Flag3; + end Flag3; + function Flag4 (N : Node_Id) return Boolean is begin pragma Assert (N <= Nodes.Last); @@ -5563,6 +5619,30 @@ package body Atree is Nodes.Table (N + 3).Field8 := To_Union (Val); end Set_Ureal21; + procedure Set_Flag0 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Flags.Table (N).Flag0 := Val; + end Set_Flag0; + + procedure Set_Flag1 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Flags.Table (N).Flag1 := Val; + end Set_Flag1; + + procedure Set_Flag2 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Flags.Table (N).Flag2 := Val; + end Set_Flag2; + + procedure Set_Flag3 (N : Node_Id; Val : Boolean) is + begin + pragma Assert (N <= Nodes.Last); + Flags.Table (N).Flag3 := Val; + end Set_Flag3; + procedure Set_Flag4 (N : Node_Id; Val : Boolean) is begin pragma Assert (N <= Nodes.Last); @@ -7924,6 +8004,7 @@ package body Atree is procedure Unlock is begin Nodes.Locked := False; + Flags.Locked := False; Orig_Nodes.Locked := False; end Unlock; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 0f47e86..0896e42 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -168,16 +168,20 @@ package Atree is -- it is useful to be able to do untyped traversals, and an internal -- package in Atree allows for direct untyped accesses in such cases. - -- Flag4 Fifteen Boolean flags (use depends on Nkind and - -- Flag5 Ekind, as described for FieldN). Again the access - -- Flag6 is usually via subprograms in Sinfo and Einfo which - -- Flag7 provide high-level synonyms for these flags, and - -- Flag8 contain debugging code that checks that the values - -- Flag9 in Nkind and Ekind are appropriate for the access. + -- Flag0 Nineteen Boolean flags (use depends on Nkind and + -- Flag1 Ekind, as described for FieldN). Again the access + -- Flag2 is usually via subprograms in Sinfo and Einfo which + -- Flag3 provide high-level synonyms for these flags, and + -- Flag4 contain debugging code that checks that the values + -- Flag5 in Nkind and Ekind are appropriate for the access. + -- Flag6 + -- Flag7 + -- Flag8 + -- Flag9 -- Flag10 - -- Flag11 Note that Flag1-3 are missing from this list. For - -- Flag12 historical reasons, these flag names are unused. - -- Flag13 + -- Flag11 Note that Flag0-3 are stored separately in the Flags + -- Flag12 table, but that's a detail of the implementation which + -- Flag13 is entirely hidden by the funcitonal interface. -- Flag14 -- Flag15 -- Flag16 @@ -220,6 +224,9 @@ package Atree is function Nodes_Address return System.Address; -- Return address of Nodes table (used in Back_End for Gigi call) + function Flags_Address return System.Address; + -- Return address of Flags table (used in Back_End for Gigi call) + function Num_Nodes return Nat; -- Total number of nodes allocated, where an entity counts as a single -- node. This count is incremented every time a node or entity is @@ -350,7 +357,7 @@ package Atree is ------------------------------------- -- A subpackage Atree.Unchecked_Access provides routines for reading and - -- writing the fields defined above (Field1-35, Node1-35, Flag4-317 etc). + -- writing the fields defined above (Field1-35, Node1-35, Flag0-317 etc). -- These unchecked access routines can be used for untyped traversals. -- In addition they are used in the implementations of the Sinfo and -- Einfo packages. These packages both provide logical synonyms for @@ -1341,6 +1348,18 @@ package Atree is function Ureal21 (N : Node_Id) return Ureal; pragma Inline (Ureal21); + function Flag0 (N : Node_Id) return Boolean; + pragma Inline (Flag0); + + function Flag1 (N : Node_Id) return Boolean; + pragma Inline (Flag1); + + function Flag2 (N : Node_Id) return Boolean; + pragma Inline (Flag2); + + function Flag3 (N : Node_Id) return Boolean; + pragma Inline (Flag3); + function Flag4 (N : Node_Id) return Boolean; pragma Inline (Flag4); @@ -2624,6 +2643,18 @@ package Atree is procedure Set_Ureal21 (N : Node_Id; Val : Ureal); pragma Inline (Set_Ureal21); + procedure Set_Flag0 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag0); + + procedure Set_Flag1 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag1); + + procedure Set_Flag2 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag2); + + procedure Set_Flag3 (N : Node_Id; Val : Boolean); + pragma Inline (Set_Flag3); + procedure Set_Flag4 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag4); @@ -3621,12 +3652,12 @@ package Atree is ------------------------- -- The nodes of the tree are stored in a table (i.e. an array). In the - -- case of extended nodes five consecutive components in the array are + -- case of extended nodes six consecutive components in the array are -- used. There are thus two formats for array components. One is used -- for non-extended nodes, and for the first component of extended -- nodes. The other is used for the extension parts (second, third, - -- fourth and fifth components) of an extended node. A variant record - -- structure is used to distinguish the two formats. + -- fourth, fifth, and sixth components) of an extended node. A variant + -- record structure is used to distinguish the two formats. type Node_Record (Is_Extension : Boolean := False) is record @@ -3680,7 +3711,8 @@ package Atree is Flag16 : Boolean; Flag17 : Boolean; Flag18 : Boolean; - -- The eighteen flags for a normal node + -- Flags 4-18 for a normal node. Note that Flags 0-3 are stored + -- separately in the Flags array. -- The above fields are used as follows in components 2-6 of -- an extended node entry. @@ -3888,7 +3920,7 @@ package Atree is Field12 => Empty_List_Or_Node); -- The following defines the extendable array used for the nodes table - -- Nodes with extensions use five consecutive entries in the array + -- Nodes with extensions use six consecutive entries in the array package Nodes is new Table.Table ( Table_Component_Type => Node_Record, @@ -3898,6 +3930,37 @@ package Atree is Table_Increment => Alloc.Nodes_Increment, Table_Name => "Nodes"); + -- The following is a parallel table to Nodes, which provides 8 more + -- bits of space that logically belong to the corresponding node. This + -- is currently used to implement Flags 0,1,2,3 for normal nodes, or + -- the first component of an extended node (four bits unused). Entries + -- for extending components are completely unused. + + type Flags_Byte is record + Flag0 : Boolean; + Flag1 : Boolean; + Flag2 : Boolean; + Flag3 : Boolean; + Spare0 : Boolean; + Spare1 : Boolean; + Spare2 : Boolean; + Spare3 : Boolean; + end record; + + for Flags_Byte'Size use 8; + pragma Pack (Flags_Byte); + + Default_Flags : constant Flags_Byte := (others => False); + -- Default value used to initialize new entries + + package Flags is new Table.Table ( + Table_Component_Type => Flags_Byte, + Table_Index_Type => Node_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => Alloc.Nodes_Initial, + Table_Increment => Alloc.Nodes_Increment, + Table_Name => "Flags"); + end Atree_Private_Part; end Atree; diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index c9fd5e0..f391385 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -359,6 +359,21 @@ extern struct Node *Nodes_Ptr; #define Parent atree__parent extern Node_Id Parent (Node_Id); +/* The auxiliary flags array which is allocated in parallel to Nodes */ + +struct Flags +{ + Boolean Flag0 : 1; + Boolean Flag1 : 1; + Boolean Flag2 : 1; + Boolean Flag3 : 1; + Boolean Spare0 : 1; + Boolean Spare1 : 1; + Boolean Spare2 : 1; + Boolean Spare3 : 1; +}; +extern struct Flags *Flags_Ptr; + /* Overloaded Functions: These functions are overloaded in the original Ada source, but there is @@ -531,6 +546,11 @@ extern Node_Id Current_Error_Node; #define Convention(N) \ (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention) +#define Flag0(N) (Flags_Ptr[(N) - First_Node_Id].Flag0) +#define Flag1(N) (Flags_Ptr[(N) - First_Node_Id].Flag1) +#define Flag2(N) (Flags_Ptr[(N) - First_Node_Id].Flag2) +#define Flag3(N) (Flags_Ptr[(N) - First_Node_Id].Flag3) + #define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4) #define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5) #define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6) diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index 577d004..6488da1 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -87,6 +87,7 @@ package body Back_End is max_gnat_node : Int; number_name : Nat; nodes_ptr : Address; + flags_ptr : Address; next_node_ptr : Address; prev_node_ptr : Address; @@ -141,6 +142,7 @@ package body Back_End is max_gnat_node => Int (Last_Node_Id - First_Node_Id + 1), number_name => Name_Entries_Count, nodes_ptr => Nodes_Address, + flags_ptr => Flags_Address, next_node_ptr => Next_Node_Address, prev_node_ptr => Prev_Node_Address, diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 832803c..cf75bd6 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -238,10 +238,14 @@ extern "C" { /* This is the main program of the back-end. It sets up all the table structures and then generates code. */ -extern void gigi (Node_Id gnat_root, int max_gnat_node, +extern void gigi (Node_Id gnat_root, + int max_gnat_node, int number_name ATTRIBUTE_UNUSED, - struct Node *nodes_ptr, Node_Id *next_node_ptr, - Node_Id *prev_node_ptr, struct Elist_Header *elists_ptr, + struct Node *nodes_ptr, + struct Flags *Flags_Ptr, + Node_Id *next_node_ptr, + Node_Id *prev_node_ptr, + struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr, struct String_Entry *strings_ptr, Char_Code *strings_chars_ptr, diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index d99eda8..b0cbedb 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -90,6 +90,7 @@ static location_t block_end_locus_sink; /* Pointers to front-end tables accessed through macros. */ struct Node *Nodes_Ptr; +struct Flags *Flags_Ptr; Node_Id *Next_Node_Ptr; Node_Id *Prev_Node_Ptr; struct Elist_Header *Elists_Ptr; @@ -273,15 +274,26 @@ static const char *decode_name (const char *) ATTRIBUTE_UNUSED; structures and then generates code. */ void -gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, - struct Node *nodes_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr, - struct Elist_Header *elists_ptr, struct Elmt_Item *elmts_ptr, - struct String_Entry *strings_ptr, Char_Code *string_chars_ptr, - struct List_Header *list_headers_ptr, Nat number_file, +gigi (Node_Id gnat_root, + int max_gnat_node, + int number_name ATTRIBUTE_UNUSED, + struct Node *nodes_ptr, + struct Flags *flags_ptr, + Node_Id *next_node_ptr, + Node_Id *prev_node_ptr, + struct Elist_Header *elists_ptr, + struct Elmt_Item *elmts_ptr, + struct String_Entry *strings_ptr, + Char_Code *string_chars_ptr, + struct List_Header *list_headers_ptr, + Nat number_file, struct File_Info_Type *file_info_ptr, - Entity_Id standard_boolean, Entity_Id standard_integer, - Entity_Id standard_character, Entity_Id standard_long_long_float, - Entity_Id standard_exception_type, Int gigi_operating_mode) + Entity_Id standard_boolean, + Entity_Id standard_integer, + Entity_Id standard_character, + Entity_Id standard_long_long_float, + Entity_Id standard_exception_type, + Int gigi_operating_mode) { Node_Id gnat_iter; Entity_Id gnat_literal; @@ -293,6 +305,7 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, max_gnat_nodes = max_gnat_node; Nodes_Ptr = nodes_ptr; + Flags_Ptr = flags_ptr; Next_Node_Ptr = next_node_ptr; Prev_Node_Ptr = prev_node_ptr; Elists_Ptr = elists_ptr; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 12f53d3..d90d58c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -13060,10 +13060,12 @@ package body Sem_Ch12 is -- package, which is necessary semantically but complicates -- ASIS tree traversal, so we recover the original entity to -- expose the renaming. Take into account that the context may - -- be a nested generic and that the original node may itself - -- have an associated node that had better be an entity. + -- be a nested generic, that the original node may itself have + -- an associated node that had better be an entity, and that + -- the current node is still a selected component. if Ekind (E) = E_Package + and then Nkind (N) = N_Selected_Component and then Nkind (Parent (N)) = N_Expanded_Name and then Present (Original_Node (N2)) and then Is_Entity_Name (Original_Node (N2)) diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 33c3dbf..792b85f 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3437,13 +3437,12 @@ package body Sem_Ch8 is -- a list of expressions corresponding to the subprogram formals. -- A renaming declaration is not a freeze point, and the analysis of -- the attribute reference should not freeze the type of the prefix. + -- We use the original node in the renaming so that its source location + -- is preserved, and checks on stream attributes are properly applied. else - Attr_Node := - Make_Attribute_Reference (Loc, - Prefix => Prefix (Nam), - Attribute_Name => Aname, - Expressions => Expr_List); + Attr_Node := Relocate_Node (Nam); + Set_Expressions (Attr_Node, Expr_List); Set_Must_Not_Freeze (Attr_Node); Set_Must_Not_Freeze (Prefix (Nam)); @@ -3459,8 +3458,8 @@ package body Sem_Ch8 is Find_Type (Result_Definition (Spec)); Rewrite (Result_Definition (Spec), - New_Reference_To ( - Base_Type (Entity (Result_Definition (Spec))), Loc)); + New_Reference_To + (Base_Type (Entity (Result_Definition (Spec))), Loc)); Body_Node := Make_Subprogram_Body (Loc, @@ -3522,7 +3521,12 @@ package body Sem_Ch8 is Find_Type (P); end if; - if Is_Tagged_Type (Etype (P)) then + -- If the target type is not yet frozen, add the body to the + -- actions to be elaborated at freeze time. + + if Is_Tagged_Type (Etype (P)) + and then In_Open_Scopes (Scope (Etype (P))) + then Ensure_Freeze_Node (Etype (P)); Append_Freeze_Action (Etype (P), Body_Node); else |