diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 35 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 188 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 2 |
8 files changed, 198 insertions, 113 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5353e3ee1c9..f8ffbcd21d1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2012-02-22 Vincent Pucci <pucci@adacore.com> + + * rtsfind.adb (Get_Unit_Name): Ada_Numerics_Child and + System_Dim_Child cases added. + * rtsfind.ads: Ada_Numerics, + Ada_Numerics_Generic_Elementary_Functions, System_Dim, + System_Dim_Float_IO and System_Dim_Integer_IO added to the list + of RTU_Id. Ada_Numerics_Child and System_Dim_Child added as + new RTU_Id subtypes. + * sem_dim.adb (Is_Dim_IO_Package_Entity): Use of + Rtsfind to verify the package entity is located either + in System.Dim.Integer_IO or in System.Dim.Float_IO. + (Is_Dim_IO_Package_Instantiation): Minor + changes. (Is_Elementary_Function_Call): Removed. + (Is_Elementary_Function_Entity): New routine. + (Is_Procedure_Put_Call): Is_Dim_IO_Package_Entity call added. + * snames.ads-tmpl: Name_Dim and Name_Generic_Elementary_Functions + removed. + +2012-02-22 Vincent Pucci <pucci@adacore.com> + + * sem_prag.adb: Minor reformatting. + +2012-02-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Find_Type_Name): When analyzing a private type + declaration that is the completion of a tagged incomplete type, do + not associate the class-wide type already created with the private + type to prevent order-of-elaboration issues in the back-end. + * exp_disp.adb (Find_Specific_Type): Find specific type of + a class-wide type, and handle the case of an incomplete type + coming either from a limited_with clause or from an incomplete + type declaration. Used when expanding a dispatchin call and + generating tag checks (minor refactoring). + 2012-02-22 Robert Dewar <dewar@adacore.com> * exp_ch5.adb: Add comment. diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 23ffe90c5fd..314862b49fa 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -75,6 +75,11 @@ package body Exp_Disp is -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table -- of the default primitive operations. + function Find_Specific_Type (CW : Entity_Id) return Entity_Id; + -- Find specific type of a class-wide type, and handle the case of an + -- incomplete type coming either from a limited_with clause or from an + -- incomplete type declaration. + function Has_DT (Typ : Entity_Id) return Boolean; pragma Inline (Has_DT); -- Returns true if we generate a dispatch table for tagged type Typ @@ -178,11 +183,7 @@ package body Exp_Disp is CW_Typ := Class_Wide_Type (Ctrl_Typ); end if; - Typ := Root_Type (CW_Typ); - - if Ekind (Typ) = E_Incomplete_Type then - Typ := Non_Limited_View (Typ); - end if; + Typ := Find_Specific_Type (CW_Typ); if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); @@ -746,11 +747,7 @@ package body Exp_Disp is CW_Typ := Class_Wide_Type (Ctrl_Typ); end if; - Typ := Root_Type (CW_Typ); - - if Ekind (Typ) = E_Incomplete_Type then - Typ := Non_Limited_View (Typ); - end if; + Typ := Find_Specific_Type (CW_Typ); if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); @@ -1884,6 +1881,25 @@ package body Exp_Disp is end if; end Expand_Interface_Thunk; + ------------------------ + -- Find_Specific_Type -- + ------------------------ + + function Find_Specific_Type (CW : Entity_Id) return Entity_Id is + Typ : Entity_Id := Root_Type (CW); + + begin + if Ekind (Typ) = E_Incomplete_Type then + if From_With_Type (Typ) then + Typ := Non_Limited_View (Typ); + else + Typ := Full_View (Typ); + end if; + end if; + + return Typ; + end Find_Specific_Type; + -------------------------- -- Has_CPP_Constructors -- -------------------------- diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index b8a6b1fe9c1..3b3e768adaa 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -313,6 +313,9 @@ package body Rtsfind is elsif U_Id in Ada_Interrupts_Child then Name_Buffer (15) := '.'; + elsif U_Id in Ada_Numerics_Child then + Name_Buffer (13) := '.'; + elsif U_Id in Ada_Real_Time_Child then Name_Buffer (14) := '.'; @@ -338,6 +341,10 @@ package body Rtsfind is elsif U_Id in System_Child then Name_Buffer (7) := '.'; + if U_Id in System_Dim_Child then + Name_Buffer (11) := '.'; + end if; + if U_Id in System_Multiprocessors_Child then Name_Buffer (23) := '.'; end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 64d10566067..7720d5e25a0 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -125,6 +125,7 @@ package Rtsfind is Ada_Exceptions, Ada_Finalization, Ada_Interrupts, + Ada_Numerics, Ada_Real_Time, Ada_Streams, Ada_Strings, @@ -144,6 +145,10 @@ package Rtsfind is Ada_Interrupts_Names, + -- Children of Ada.Numerics + + Ada_Numerics_Generic_Elementary_Functions, + -- Children of Ada.Real_Time Ada_Real_Time_Delays, @@ -223,6 +228,7 @@ package Rtsfind is System_Concat_7, System_Concat_8, System_Concat_9, + System_Dim, System_DSA_Services, System_DSA_Types, System_Exception_Table, @@ -372,6 +378,11 @@ package Rtsfind is System_WWd_Enum, System_WWd_Wchar, + -- Children of System.Dim + + System_Dim_Float_IO, + System_Dim_Integer_IO, + -- Children of System.Multiprocessors System_Multiprocessors_Dispatching_Domains, @@ -413,6 +424,11 @@ package Rtsfind is Ada_Interrupts_Names .. Ada_Interrupts_Names; -- Range of values for children of Ada.Interrupts + subtype Ada_Numerics_Child is Ada_Child + range Ada_Numerics_Generic_Elementary_Functions .. + Ada_Numerics_Generic_Elementary_Functions; + -- Range of values for children of Ada.Numerics + subtype Ada_Real_Time_Child is Ada_Child range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events; -- Range of values for children of Ada.Real_Time @@ -445,6 +461,10 @@ package Rtsfind is range System_Address_Image .. System_Tasking_Stages; -- Range of values for children or grandchildren of System + subtype System_Dim_Child is RTU_Id + range System_Dim_Float_IO .. System_Dim_Integer_IO; + -- Range of values for children of System.Dim + subtype System_Multiprocessors_Child is RTU_Id range System_Multiprocessors_Dispatching_Domains .. System_Multiprocessors_Dispatching_Domains; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d56c59fd64a..4618a712b4f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -14968,7 +14968,15 @@ package body Sem_Ch3 is then Set_Ekind (Id, Ekind (Prev)); -- will be reset later Set_Class_Wide_Type (Id, Class_Wide_Type (Prev)); - Set_Etype (Class_Wide_Type (Id), Id); + + -- If the incomplete type is completed by a private declaration + -- the class-wide type remains associated with the incomplete + -- type, to prevent order-of-elaboration issues in gigi, else + -- we associate the class-wide type with the known full view. + + if Nkind (N) /= N_Private_Type_Declaration then + Set_Etype (Class_Wide_Type (Id), Id); + end if; end if; -- Case of full declaration of private type diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 4ba81f822d2..d95e7081527 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -36,7 +36,6 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; @@ -1359,94 +1358,105 @@ package body Sem_Dim is -- Analyze_Dimension_Function_Call -- ------------------------------------- + -- Propagate the dimensions from the returned type to the call node. Note + -- that there is a special treatment for elementary function calls. Indeed + -- for Sqrt call, the resulting dimensions equal to half the dimensions of + -- the actual, and for other elementary calls, this routine check that + -- every actuals are dimensionless. + procedure Analyze_Dimension_Function_Call (N : Node_Id) is - Name_Call : constant Node_Id := Name (N); Actuals : constant List_Id := Parameter_Associations (N); + Name_Call : constant Node_Id := Name (N); Actual : Node_Id; Dims_Of_Actual : Dimension_Type; Dims_Of_Call : Dimension_Type; + Ent : Entity_Id; - function Is_Elementary_Function_Call return Boolean; - -- Return True if the call is a call of an elementary function (see + function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean; + -- Given E the original subprogram entity, return True if the call is a + -- an elementary function call (see -- Ada.Numerics.Generic_Elementary_Functions). - --------------------------------- - -- Is_Elementary_Function_Call -- - --------------------------------- + ----------------------------------- + -- Is_Elementary_Function_Entity -- + ----------------------------------- - function Is_Elementary_Function_Call return Boolean is - Ent : Entity_Id; + function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (E); begin - if Is_Entity_Name (Name_Call) then - Ent := Entity (Name_Call); + -- Check the function entity is located in + -- Ada.Numerics.Generic_Elementary_Functions. - -- Check the procedure is defined in an instantiation of a generic - -- package. + return + Loc > No_Location + and then + Is_RTU + (Cunit_Entity (Get_Source_Unit (Loc)), + Ada_Numerics_Generic_Elementary_Functions); + end Is_Elementary_Function_Entity; - if Is_Generic_Instance (Scope (Ent)) then - Ent := Cunit_Entity (Get_Source_Unit (Ent)); + -- Start of processing for Analyze_Dimension_Function_Call - -- Check the name of the generic package is - -- Generic_Elementary_Functions + begin + -- Look for elementary function call - return - Is_Library_Level_Entity (Ent) - and then Chars (Ent) = Name_Generic_Elementary_Functions; - end if; - end if; + if Is_Entity_Name (Name_Call) then + Ent := Entity (Name_Call); - return False; - end Is_Elementary_Function_Call; + -- Get the original subprogram entity following the renaming chain - -- Start of processing for Analyze_Dimension_Function_Call + if Present (Alias (Ent)) then + Ent := Alias (Ent); + end if; - begin - -- Elementary function case + -- Elementary function case - if Is_Elementary_Function_Call then + if Is_Elementary_Function_Entity (Ent) then -- Sqrt function call case - if Chars (Name_Call) = Name_Sqrt then - Dims_Of_Call := Dimensions_Of (First (Actuals)); + if Chars (Ent) = Name_Sqrt then + Dims_Of_Call := Dimensions_Of (First (Actuals)); - if Exists (Dims_Of_Call) then - for Position in Dims_Of_Call'Range loop - Dims_Of_Call (Position) := - Dims_Of_Call (Position) * Rational'(Numerator => 1, + if Exists (Dims_Of_Call) then + for Position in Dims_Of_Call'Range loop + Dims_Of_Call (Position) := + Dims_Of_Call (Position) * Rational'(Numerator => 1, Denominator => 2); - end loop; + end loop; - Set_Dimensions (N, Dims_Of_Call); - end if; + Set_Dimensions (N, Dims_Of_Call); + end if; - -- All other functions in Ada.Numerics.Generic_Elementary_Functions - -- case. Note that all parameters here should be dimensionless. + -- All other elementary functions case. Note that every actual + -- here should be dimensionless. - else - Actual := First (Actuals); - while Present (Actual) loop - Dims_Of_Actual := Dimensions_Of (Actual); - - if Exists (Dims_Of_Actual) then - Error_Msg_NE ("parameter should be dimensionless for " & - "elementary function&", - Actual, - Name_Call); - Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual), - Actual); - end if; + else + Actual := First (Actuals); + while Present (Actual) loop + Dims_Of_Actual := Dimensions_Of (Actual); + + if Exists (Dims_Of_Actual) then + Error_Msg_NE ("parameter should be dimensionless for " & + "elementary function&", + Actual, + Name_Call); + Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual), + Actual); + end if; - Next (Actual); - end loop; + Next (Actual); + end loop; + end if; + + return; end if; + end if; - -- Other case + -- Other cases - else - Analyze_Dimension_Has_Etype (N); - end if; + Analyze_Dimension_Has_Etype (N); end Analyze_Dimension_Function_Call; --------------------------------- @@ -2226,28 +2236,31 @@ package body Sem_Dim is function Is_Procedure_Put_Call return Boolean is Ent : Entity_Id; + Loc : Source_Ptr; begin - -- There are three different Put routine in each generic package - -- Check that the current procedure call is one of them + -- There are three different Put routines in each generic dim IO + -- package. Verify the current procedure call is one of them. if Is_Entity_Name (Name_Call) then Ent := Entity (Name_Call); - -- Check that the name of the procedure is Put - -- Check the procedure is defined in an instantiation of a - -- generic package. + -- Get the original subprogram entity following the renaming chain - if Chars (Name_Call) = Name_Put - and then Is_Generic_Instance (Scope (Ent)) - then - Ent := Cunit_Entity (Get_Source_Unit (Ent)); + if Present (Alias (Ent)) then + Ent := Alias (Ent); + end if; - -- Verify that the generic package is either - -- System.Dim.Float_IO or System.Dim.Integer_IO. + Loc := Sloc (Ent); - return Is_Dim_IO_Package_Entity (Ent); - end if; + -- Check the name of the entity subprogram is Put and verify this + -- entity is located in either System.Dim.Float_IO or + -- System.Dim.Integer_IO. + + return Chars (Ent) = Name_Put + and then Loc > No_Location + and then Is_Dim_IO_Package_Entity + (Cunit_Entity (Get_Source_Unit (Loc))); end if; return False; @@ -2499,22 +2512,14 @@ package body Sem_Dim is -- Is_Dim_IO_Package_Entity -- ------------------------------ - -- Why all this comparison of names, why not use Is_RTE and Is_RTU ??? - function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is begin - -- Check the package entity is standard and its scope is either - -- System.Dim.Float_IO or System.Dim.Integer_IO. - - if Is_Library_Level_Entity (E) - and then (Chars (E) = Name_Float_IO - or else Chars (E) = Name_Integer_IO) - then - return Chars (Scope (E)) = Name_Dim - and Chars (Scope (Scope (E))) = Name_System; - end if; + -- Check the package entity corresponds to System.Dim.Float_IO or + -- System.Dim.Integer_IO. - return False; + return + Is_RTU (E, System_Dim_Float_IO) + or Is_RTU (E, System_Dim_Integer_IO); end Is_Dim_IO_Package_Entity; ------------------------------------- @@ -2523,19 +2528,14 @@ package body Sem_Dim is function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is Gen_Id : constant Node_Id := Name (N); - Ent : Entity_Id; begin - if Is_Entity_Name (Gen_Id) then - Ent := Entity (Gen_Id); - - -- Verify that the instantiated package is either System.Dim.Float_IO - -- or System.Dim.Integer_IO. - - return Is_Dim_IO_Package_Entity (Ent); - end if; + -- Check that the instantiated package is either System.Dim.Float_IO + -- or System.Dim.Integer_IO. - return False; + return + Is_Entity_Name (Gen_Id) + and then Is_Dim_IO_Package_Entity (Entity (Gen_Id)); end Is_Dim_IO_Package_Instantiation; ---------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f1ea658a10b..9761f2fbea2 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -14970,14 +14970,15 @@ package body Sem_Prag is -- Follow subprogram renaming chain Result := Def_Id; - while Is_Subprogram (Result) + + if Is_Subprogram (Result) and then Nkind (Parent (Declaration_Node (Result))) = N_Subprogram_Renaming_Declaration and then Present (Alias (Result)) - loop + then Result := Alias (Result); - end loop; + end if; return Result; end Get_Base_Subprogram; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index b1c6a2d80b0..cce46080d0a 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -225,8 +225,6 @@ package Snames is -- Names used by the analyzer and expander for aspect Dimension and -- Dimension_System to deal with Sqrt and IO routines. - Name_Dim : constant Name_Id := N + $; -- Ada 12 - Name_Generic_Elementary_Functions : constant Name_Id := N + $; -- Ada 12 Name_Item : constant Name_Id := N + $; -- Ada 12 Name_Sqrt : constant Name_Id := N + $; -- Ada 12 Name_Symbols : constant Name_Id := N + $; -- Ada 12 |