From 6871ba5ffcd7c2eccc4acd66da2ab4f9bdb730fe Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 23 Feb 2004 12:17:13 +0100 Subject: [PATCH] [multiple changes] 2004-02-23 Ed Schonberg * exp_ch6.adb (Expand_N_Subprogram_Declaration): Do not create protected operations if original subprogram is flagged as eliminated. (Expand_N_Subprogram_Body): For a protected operation, create discriminals for next operation before checking whether the operation is eliminated. * exp_ch9.adb (Expand_N_Protected_Body, Expand_N_Protected_Type_Declaration): Do not generate specs and bodies for internal protected operations if the original subprogram is eliminated. * sem_elim.adb (Check_Eliminated): Handle properly protected operations declared in a single protected object. 2004-02-23 Vincent Celier * prj-attr.adb: Make attribute Builder'Executable an associative array, case insensitive if file names are case insensitive, instead of a standard associative array. * prj-attr.adb (Initialize): For 'b' associative arrays, do not set them as case insensitive on platforms where the file names are case sensitive. * prj-part.adb (Parse_Single_Project): Make sure, when checking if project file has already been parsed that canonical path are compared. 2004-02-23 Robert Dewar * sinput-c.ads: Correct bad unit title in header * freeze.adb: Minor reformatting 2004-02-23 Richard Kenner * trans.c (tree_transform, case N_Procedure_Call_Statement): For nonaddressable COMPONENT_REF that is removing padding that we are taking the address of, take the address of the padded record instead if item is variable size. From-SVN: r78292 --- gcc/ada/ChangeLog | 42 ++++++++++++++++++ gcc/ada/exp_ch6.adb | 63 ++++++++++++++------------- gcc/ada/exp_ch9.adb | 11 +++-- gcc/ada/freeze.adb | 14 +++--- gcc/ada/prj-attr.adb | 6 +-- gcc/ada/prj-part.adb | 121 +++++++++++++++++++++++++++++---------------------- gcc/ada/sem_elim.adb | 27 +++++++++++- gcc/ada/sinput-c.ads | 4 +- gcc/ada/trans.c | 13 ++++++ 9 files changed, 202 insertions(+), 99 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4605412..7ecb98e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2004-02-23 Ed Schonberg + + * exp_ch6.adb (Expand_N_Subprogram_Declaration): Do not create + protected operations if original subprogram is flagged as eliminated. + (Expand_N_Subprogram_Body): For a protected operation, create + discriminals for next operation before checking whether the operation + is eliminated. + + * exp_ch9.adb (Expand_N_Protected_Body, + Expand_N_Protected_Type_Declaration): Do not generate specs and bodies + for internal protected operations if the original subprogram is + eliminated. + + * sem_elim.adb (Check_Eliminated): Handle properly protected operations + declared in a single protected object. + +2004-02-23 Vincent Celier + + * prj-attr.adb: Make attribute Builder'Executable an associative array, + case insensitive if file names are case insensitive, instead of a + standard associative array. + + * prj-attr.adb (Initialize): For 'b' associative arrays, do not set + them as case insensitive on platforms where the file names are case + sensitive. + + * prj-part.adb (Parse_Single_Project): Make sure, when checking if + project file has already been parsed that canonical path are compared. + +2004-02-23 Robert Dewar + + * sinput-c.ads: Correct bad unit title in header + + * freeze.adb: Minor reformatting + +2004-02-23 Richard Kenner + + * trans.c (tree_transform, case N_Procedure_Call_Statement): For + nonaddressable COMPONENT_REF that is removing padding that we are + taking the address of, take the address of the padded record instead + if item is variable size. + 2004-02-20 Robert Dewar * bld.adb, exp_util.adb, gprcmd.adb: Minor reformatting diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 744a024..b8d8ed2 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3191,6 +3191,34 @@ package body Exp_Ch6 is end; end if; + Scop := Scope (Spec_Id); + + -- Add discriminal renamings to protected subprograms. + -- Install new discriminals for expansion of the next + -- subprogram of this protected type, if any. + + if Is_List_Member (N) + and then Present (Parent (List_Containing (N))) + and then Nkind (Parent (List_Containing (N))) = N_Protected_Body + then + Add_Discriminal_Declarations + (Declarations (N), Scop, Name_uObject, Loc); + Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc); + + -- Associate privals and discriminals with the next protected + -- operation body to be expanded. These are used to expand + -- references to private data objects and discriminants, + -- respectively. + + Next_Op := Next_Protected_Operation (N); + + if Present (Next_Op) then + Dec := Parent (Base_Type (Scop)); + Set_Privals (Dec, Next_Op, Loc); + Set_Discriminals (Dec); + end if; + end if; + -- Clear out statement list for stubbed procedure if Present (Corresponding_Spec (N)) then @@ -3208,8 +3236,6 @@ package body Exp_Ch6 is end if; end if; - Scop := Scope (Spec_Id); - -- Returns_By_Ref flag is normally set when the subprogram is frozen -- but subprograms with no specs are not frozen @@ -3298,32 +3324,6 @@ package body Exp_Ch6 is end; end if; - -- Add discriminal renamings to protected subprograms. - -- Install new discriminals for expansion of the next - -- subprogram of this protected type, if any. - - if Is_List_Member (N) - and then Present (Parent (List_Containing (N))) - and then Nkind (Parent (List_Containing (N))) = N_Protected_Body - then - Add_Discriminal_Declarations - (Declarations (N), Scop, Name_uObject, Loc); - Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc); - - -- Associate privals and discriminals with the next protected - -- operation body to be expanded. These are used to expand - -- references to private data objects and discriminants, - -- respectively. - - Next_Op := Next_Protected_Operation (N); - - if Present (Next_Op) then - Dec := Parent (Base_Type (Scop)); - Set_Privals (Dec, Next_Op, Loc); - Set_Discriminals (Dec); - end if; - end if; - -- If subprogram contains a parameterless recursive call, then we may -- have an infinite recursion, so see if we can generate code to check -- for this possibility if storage checks are not suppressed. @@ -3420,14 +3420,17 @@ package body Exp_Ch6 is Prot_Id : Entity_Id; begin - -- Deal with case of protected subprogram + -- Deal with case of protected subprogram. Do not generate + -- protected operation if operation is flagged as eliminated. if Is_List_Member (N) and then Present (Parent (List_Containing (N))) and then Nkind (Parent (List_Containing (N))) = N_Protected_Body and then Is_Protected_Type (Scop) then - if No (Protected_Body_Subprogram (Subp)) then + if No (Protected_Body_Subprogram (Subp)) + and then not Is_Eliminated (Subp) + then Prot_Decl := Make_Subprogram_Declaration (Loc, Specification => diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index e55f987..ddaf2aa 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -4885,7 +4885,9 @@ package body Exp_Ch9 is -- Exclude functions created to analyze defaults. - if not Is_Eliminated (Defining_Entity (Op_Body)) then + if not Is_Eliminated (Defining_Entity (Op_Body)) + and then not Is_Eliminated (Corresponding_Spec (Op_Body)) + then New_Op_Body := Build_Unprotected_Subprogram_Body (Op_Body, Pid); @@ -5372,14 +5374,17 @@ package body Exp_Ch9 is -- subprogram; one to call from outside the object and one to -- call from inside. Build a barrier function and an entry -- body action procedure specification for each protected entry. - -- Initialize the entry body array. + -- Initialize the entry body array. If subprogram is flagged as + -- eliminated, do not generate any internal operations. E_Count := 0; Comp := First (Visible_Declarations (Pdef)); while Present (Comp) loop - if Nkind (Comp) = N_Subprogram_Declaration then + if Nkind (Comp) = N_Subprogram_Declaration + and then not Is_Eliminated (Defining_Entity (Comp)) + then Sub := Make_Subprogram_Declaration (Loc, Specification => diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 73861b7..11f8270 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1479,6 +1479,10 @@ package body Freeze is -- might otherwise be frozen in the wrong scope, and a freeze node -- on subtype has no effect. + ----------------- + -- Check_Itype -- + ----------------- + procedure Check_Itype (Desig : Entity_Id) is begin if not Is_Frozen (Desig) @@ -1522,11 +1526,10 @@ package body Freeze is then Set_First_Entity (Rec, First_Entity (Base_Type (Rec))); - -- If this is an internal type without a declaration, as for - -- a record component, the base type may not yet be frozen, - -- and its controller has not been created. Add an explicit - -- freeze node for the itype, so it will be frozen after the - -- base type. + -- If this is an internal type without a declaration, as for a + -- record component, the base type may not yet be frozen, and its + -- controller has not been created. Add an explicit freeze node + -- for the itype, so it will be frozen after the base type. elsif Is_Itype (Rec) and then Has_Delayed_Freeze (Base_Type (Rec)) @@ -1997,7 +2000,6 @@ package body Freeze is -- Loop through formals Formal := First_Formal (E); - while Present (Formal) loop F_Type := Etype (Formal); Freeze_And_Append (F_Type, Loc, Result); diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 8482fd2..6e8cc6c 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2004 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- -- @@ -105,7 +105,7 @@ package body Prj.Attr is "Pbuilder#" & "Ladefault_switches#" & "Lbswitches#" & - "SAexecutable#" & + "Sbexecutable#" & "SVexecutable_suffix#" & "SVglobal_configuration_pragmas#" & @@ -258,7 +258,7 @@ package body Prj.Attr is when 'b' => if File_Names_Case_Sensitive then - Kind_2 := Case_Insensitive_Associative_Array; + Kind_2 := Associative_Array; else Kind_2 := Case_Insensitive_Associative_Array; end if; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index a97f874..a6c8f7b 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -97,13 +97,14 @@ package body Prj.Part is -- projects. These imported projects will be effectively parsed after the -- name of the current project has been extablished. - type Name_And_Id is record - Name : Name_Id; + type Names_And_Id is record + Path_Name : Name_Id; + Canonical_Path_Name : Name_Id; Id : Project_Node_Id; end record; package Project_Stack is new Table.Table - (Table_Component_Type => Name_And_Id, + (Table_Component_Type => Names_And_Id, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 10, @@ -717,7 +718,7 @@ package body Prj.Part is if Project_Stack.Last > 1 then for Index in reverse 1 .. Project_Stack.Last loop - Error_Msg_Name_1 := Project_Stack.Table (Index).Name; + Error_Msg_Name_1 := Project_Stack.Table (Index).Path_Name; Error_Msg ("\imported by {", Current_With.Location); end loop; end if; @@ -761,7 +762,7 @@ package body Prj.Part is Canonical_Path_Name := Name_Find; for Index in 1 .. Project_Stack.Last loop - if Project_Stack.Table (Index).Name = + if Project_Stack.Table (Index).Canonical_Path_Name = Canonical_Path_Name then -- We have found the limited imported project, @@ -875,13 +876,15 @@ package body Prj.Part is -- Check for a circular dependency for Index in 1 .. Project_Stack.Last loop - if Canonical_Path_Name = Project_Stack.Table (Index).Name then + if Canonical_Path_Name = + Project_Stack.Table (Index).Canonical_Path_Name + then Error_Msg ("circular dependency detected", Token_Ptr); Error_Msg_Name_1 := Normed_Path_Name; Error_Msg ("\ { is imported by", Token_Ptr); for Current in reverse 1 .. Project_Stack.Last loop - Error_Msg_Name_1 := Project_Stack.Table (Current).Name; + Error_Msg_Name_1 := Project_Stack.Table (Current).Path_Name; if Error_Msg_Name_1 /= Canonical_Path_Name then Error_Msg @@ -901,63 +904,74 @@ package body Prj.Part is -- Put the new path name on the stack Project_Stack.Increment_Last; - Project_Stack.Table (Project_Stack.Last).Name := Canonical_Path_Name; + Project_Stack.Table (Project_Stack.Last).Path_Name := Normed_Path_Name; + Project_Stack.Table (Project_Stack.Last).Canonical_Path_Name := + Canonical_Path_Name; -- Check if the project file has already been parsed. while A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node loop - if - Path_Name_Of (A_Project_Name_And_Node.Node) = Canonical_Path_Name - then - if Extended then + declare + Path_Id : Name_Id := Path_Name_Of (A_Project_Name_And_Node.Node); + begin + if Path_Id /= No_Name then + Get_Name_String (Path_Id); + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Path_Id := Name_Find; + end if; - if A_Project_Name_And_Node.Extended then - Error_Msg - ("cannot extend the same project file several times", - Token_Ptr); + if Path_Id = Canonical_Path_Name then + if Extended then - else - Error_Msg - ("cannot extend an already imported project file", - Token_Ptr); - end if; + if A_Project_Name_And_Node.Extended then + Error_Msg + ("cannot extend the same project file several times", + Token_Ptr); - elsif A_Project_Name_And_Node.Extended then - Extends_All := Is_Extending_All (A_Project_Name_And_Node.Node); - - -- If the imported project is an extended project A, and we are - -- in an extended project, replace A with the ultimate project - -- extending A. + else + Error_Msg + ("cannot extend an already imported project file", + Token_Ptr); + end if; - if From_Extended /= None then - declare - Decl : Project_Node_Id := - Project_Declaration_Of - (A_Project_Name_And_Node.Node); - Prj : Project_Node_Id := - Extending_Project_Of (Decl); - begin - loop - Decl := Project_Declaration_Of (Prj); - exit when Extending_Project_Of (Decl) = Empty_Node; - Prj := Extending_Project_Of (Decl); - end loop; + elsif A_Project_Name_And_Node.Extended then + Extends_All := + Is_Extending_All (A_Project_Name_And_Node.Node); + + -- If the imported project is an extended project A, + -- and we are in an extended project, replace A with the + -- ultimate project extending A. + + if From_Extended /= None then + declare + Decl : Project_Node_Id := + Project_Declaration_Of + (A_Project_Name_And_Node.Node); + Prj : Project_Node_Id := + Extending_Project_Of (Decl); + begin + loop + Decl := Project_Declaration_Of (Prj); + exit when Extending_Project_Of (Decl) = Empty_Node; + Prj := Extending_Project_Of (Decl); + end loop; - A_Project_Name_And_Node.Node := Prj; - end; - else - Error_Msg - ("cannot import an already extended project file", - Token_Ptr); + A_Project_Name_And_Node.Node := Prj; + end; + else + Error_Msg + ("cannot import an already extended project file", + Token_Ptr); + end if; end if; - end if; - Project := A_Project_Name_And_Node.Node; - Project_Stack.Decrement_Last; - return; - end if; + Project := A_Project_Name_And_Node.Node; + Project_Stack.Decrement_Last; + return; + end if; + end; A_Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next; end loop; @@ -1202,11 +1216,12 @@ package body Prj.Part is if Project_Stack.Last > 1 then Error_Msg_Name_1 := - Project_Stack.Table (Project_Stack.Last).Name; + Project_Stack.Table (Project_Stack.Last).Path_Name; Error_Msg ("\extended by {", Token_Ptr); for Index in reverse 1 .. Project_Stack.Last - 1 loop - Error_Msg_Name_1 := Project_Stack.Table (Index).Name; + Error_Msg_Name_1 := + Project_Stack.Table (Index).Path_Name; Error_Msg ("\imported by {", Token_Ptr); end loop; end if; diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index c5c6b3a..2a6ead4 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2004 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- -- @@ -232,6 +232,29 @@ package body Sem_Elim is Ctr : Nat; Ent : Entity_Id; + function Original_Chars (S : Entity_Id) return Name_Id; + -- If the candidate subprogram is a protected operation of a single + -- protected object, the scope of the operation is the created + -- protected type, and we have to retrieve the original name of + -- the object. + + -------------------- + -- Original_Chars -- + -------------------- + + function Original_Chars (S : Entity_Id) return Name_Id is + begin + if Ekind (S) /= E_Protected_Type + or else Comes_From_Source (S) + then + return Chars (S); + else + return Chars (Defining_Identifier (Original_Node (Parent (S)))); + end if; + end Original_Chars; + + -- Start of processing for Check_Eliminated + begin if No_Elimination then return; @@ -270,7 +293,7 @@ package body Sem_Elim is Scop := Scope (E); if Elmt.Entity_Scope /= null then for J in reverse Elmt.Entity_Scope'Range loop - if Elmt.Entity_Scope (J) /= Chars (Scop) then + if Elmt.Entity_Scope (J) /= Original_Chars (Scop) then goto Continue; end if; diff --git a/gcc/ada/sinput-c.ads b/gcc/ada/sinput-c.ads index 7ed12cd..974b5af 100644 --- a/gcc/ada/sinput-c.ads +++ b/gcc/ada/sinput-c.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- S I N P U T . P -- +-- S I N P U T . C -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, 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- -- diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index d11742d..ba8d164 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -2997,6 +2997,19 @@ tree_transform (Node_Id gnat_node) gnu_actual); } + /* Otherwise, if we have a non-addressable COMPONENT_REF of a + variable-size type see if it's doing a unpadding operation. + If so, remove that operation since we have no way of + allocating the required temporary. */ + if (TREE_CODE (gnu_actual) == COMPONENT_REF + && ! TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) + && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_actual, 0))) + == RECORD_TYPE) + && TYPE_IS_PADDING_P (TREE_TYPE + (TREE_OPERAND (gnu_actual, 0))) + && !addressable_p (gnu_actual)) + gnu_actual = TREE_OPERAND (gnu_actual, 0); + /* The symmetry of the paths to the type of an entity is broken here since arguments don't know that they will be passed by ref. */ -- 2.7.4