From bb10b89181d4ad48e5dd82cf9d7c845c6206c08b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 22 Jun 2010 18:47:55 +0200 Subject: [PATCH] [multiple changes] 2010-06-22 Robert Dewar * s-rannum.adb: Minor reformatting. 2010-06-22 Javier Miranda * sem_aux.adb, sem_aux.ads, sem_util.adb, sem_util.ads, sem_elim.adb, exp_cg.adb: Minor code reorganization: Move routine Ultimate_Alias from package Sem_Util to package Sem_Aux. 2010-06-22 Javier Miranda * exp_disp.adb (Make_Secondary_DT, Make_DT): Minor code cleanup: remove useless restriction on imported routines when building the dispatch tables. 2010-06-22 Robert Dewar * cstand.adb (Create_Standard): Set Has_Pragma_Pack for standard string types. 2010-06-22 Javier Miranda * sem_ch4.adb (Collect_Generic_Type_Ops): Protect code that handles generic subprogram declarations to ensure proper context. Add missing support for generic actuals. (Try_Primitive_Operation): Add missing support for concurrent types that have no Corresponding_Record_Type. Required to diagnose errors compiling generics or when compiling with no code generation (-gnatc). * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Do not build the corresponding record type. * sem_disp.ads, sem_disp.adb (Check_Dispatching_Operation): Complete documentation. Do minimum decoration when processing a primitive of a concurrent tagged type that covers interfaces. Required to diagnose errors in the Object.Operation notation compiling generics or under -gnatc. * exp_ch9.ads, exp_ch9.adb (Build_Corresponding_Record): Add missing propagation of attribute Interface_List to the corresponding record. (Expand_N_Task_Type_Declaration): Code cleanup. (Expand_N_Protected_Type_Declaration): Code cleanup. From-SVN: r161203 --- gcc/ada/ChangeLog | 41 ++++++++++++++++++++++++++++++ gcc/ada/cstand.adb | 27 +++++++++++--------- gcc/ada/exp_cg.adb | 1 + gcc/ada/exp_ch9.adb | 26 +++++++++---------- gcc/ada/exp_ch9.ads | 10 +------- gcc/ada/exp_disp.adb | 6 ----- gcc/ada/s-rannum.adb | 60 +++++++++++++++++++++++++++++--------------- gcc/ada/sem_aux.adb | 16 ++++++++++++ gcc/ada/sem_aux.ads | 7 +++++- gcc/ada/sem_ch4.adb | 56 +++++++++++++++++++++++++---------------- gcc/ada/sem_ch9.adb | 19 -------------- gcc/ada/sem_disp.adb | 23 +++++++++++------ gcc/ada/sem_disp.ads | 9 +++++-- gcc/ada/sem_elim.adb | 1 + gcc/ada/sem_util.adb | 16 ------------ gcc/ada/sem_util.ads | 5 ---- 16 files changed, 191 insertions(+), 132 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b3834978de0..5f3487b1774 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2010-06-22 Robert Dewar + + * s-rannum.adb: Minor reformatting. + +2010-06-22 Javier Miranda + + * sem_aux.adb, sem_aux.ads, sem_util.adb, sem_util.ads, sem_elim.adb, + exp_cg.adb: Minor code reorganization: Move routine Ultimate_Alias from + package Sem_Util to package Sem_Aux. + +2010-06-22 Javier Miranda + + * exp_disp.adb (Make_Secondary_DT, Make_DT): Minor code cleanup: + remove useless restriction on imported routines when building the + dispatch tables. + +2010-06-22 Robert Dewar + + * cstand.adb (Create_Standard): Set Has_Pragma_Pack for standard string + types. + +2010-06-22 Javier Miranda + + * sem_ch4.adb (Collect_Generic_Type_Ops): Protect code that handles + generic subprogram declarations to ensure proper context. Add missing + support for generic actuals. + (Try_Primitive_Operation): Add missing support for concurrent types that + have no Corresponding_Record_Type. Required to diagnose errors compiling + generics or when compiling with no code generation (-gnatc). + * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Do not build + the corresponding record type. + * sem_disp.ads, sem_disp.adb (Check_Dispatching_Operation): Complete + documentation. Do minimum decoration when processing a primitive of a + concurrent tagged type that covers interfaces. Required to diagnose + errors in the Object.Operation notation compiling generics or under + -gnatc. + * exp_ch9.ads, exp_ch9.adb (Build_Corresponding_Record): Add missing + propagation of attribute Interface_List to the corresponding record. + (Expand_N_Task_Type_Declaration): Code cleanup. + (Expand_N_Protected_Type_Declaration): Code cleanup. + 2010-06-22 Matthew Heaney * a-convec.adb, a-coinve.adb: Removed 64-bit types Int and UInt. diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index d6f0ff09cea..76701813067 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -688,12 +688,13 @@ package body CStand is Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_String), Tdef_Node); - Set_Ekind (Standard_String, E_String_Type); - Set_Etype (Standard_String, Standard_String); - Set_Component_Type (Standard_String, Standard_Character); - Set_Component_Size (Standard_String, Uint_8); - Init_Size_Align (Standard_String); - Set_Alignment (Standard_String, Uint_1); + Set_Ekind (Standard_String, E_String_Type); + Set_Etype (Standard_String, Standard_String); + Set_Component_Type (Standard_String, Standard_Character); + Set_Component_Size (Standard_String, Uint_8); + Init_Size_Align (Standard_String); + Set_Alignment (Standard_String, Uint_1); + Set_Has_Pragma_Pack (Standard_String, True); -- On targets where a storage unit is larger than a byte (such as AAMP), -- pragma Pack has a real effect on the representation of type String, @@ -731,11 +732,12 @@ package body CStand is Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node); - Set_Ekind (Standard_Wide_String, E_String_Type); - Set_Etype (Standard_Wide_String, Standard_Wide_String); - Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); - Set_Component_Size (Standard_Wide_String, Uint_16); - Init_Size_Align (Standard_Wide_String); + Set_Ekind (Standard_Wide_String, E_String_Type); + Set_Etype (Standard_Wide_String, Standard_Wide_String); + Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); + Set_Component_Size (Standard_Wide_String, Uint_16); + Init_Size_Align (Standard_Wide_String); + Set_Has_Pragma_Pack (Standard_Wide_String, True); -- Set index type of Wide_String @@ -772,6 +774,7 @@ package body CStand is Set_Component_Size (Standard_Wide_Wide_String, Uint_32); Init_Size_Align (Standard_Wide_Wide_String); Set_Is_Ada_2005_Only (Standard_Wide_Wide_String); + Set_Has_Pragma_Pack (Standard_Wide_Wide_String, True); -- Set index type of Wide_Wide_String diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb index fcfbb263ac3..69dff207bf8 100644 --- a/gcc/ada/exp_cg.adb +++ b/gcc/ada/exp_cg.adb @@ -34,6 +34,7 @@ with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Output; use Output; +with Sem_Aux; use Sem_Aux; with Sem_Disp; use Sem_Disp; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 0a7ef3be233..70d92266489 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -128,6 +128,14 @@ package body Exp_Ch9 is -- Build a specification for a function implementing the protected entry -- barrier of the specified entry body. + function Build_Corresponding_Record + (N : Node_Id; + Ctyp : Node_Id; + Loc : Source_Ptr) return Node_Id; + -- Common to tasks and protected types. Copy discriminant specifications, + -- build record declaration. N is the type declaration, Ctyp is the + -- concurrent entity (task type or protected type). + function Build_Entry_Count_Expression (Concurrent_Type : Node_Id; Component_List : List_Id; @@ -1037,8 +1045,9 @@ package body Exp_Ch9 is -- record is "limited tagged". It is "limited" to reflect the underlying -- limitedness of the task or protected object that it represents, and -- ensuring for example that it is properly passed by reference. It is - -- "tagged" to give support to dispatching calls through interfaces (Ada - -- 2005: AI-345) + -- "tagged" to give support to dispatching calls through interfaces. We + -- propagate here the list of interfaces covered by the concurrent type + -- (Ada 2005: AI-345). return Make_Full_Type_Declaration (Loc, @@ -1051,6 +1060,7 @@ package body Exp_Ch9 is Component_Items => Cdecls), Tagged_Present => Ada_Version >= Ada_05 and then Is_Tagged_Type (Ctyp), + Interface_List => Interface_List (N), Limited_Present => True)); end Build_Corresponding_Record; @@ -7682,11 +7692,6 @@ package body Exp_Ch9 is Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); - -- Ada 2005 (AI-345): Propagate the attribute that contains the list - -- of implemented interfaces. - - Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); - Qualify_Entity_Names (N); -- If the type has discriminants, their occurrences in the declaration @@ -9946,11 +9951,6 @@ package body Exp_Ch9 is Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); - -- Ada 2005 (AI-345): Propagate the attribute that contains the list - -- of implemented interfaces. - - Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); - Rec_Ent := Defining_Identifier (Rec_Decl); Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 22a27d6422e..80d870ad8a1 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -50,14 +50,6 @@ package Exp_Ch9 is -- Task_Id of the associated task as the parameter. The caller is -- responsible for analyzing and resolving the resulting tree. - function Build_Corresponding_Record - (N : Node_Id; - Ctyp : Node_Id; - Loc : Source_Ptr) return Node_Id; - -- Common to tasks and protected types. Copy discriminant specifications, - -- build record declaration. N is the type declaration, Ctyp is the - -- concurrent entity (task type or protected type). - function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id; -- Create the statements which populate the entry names array of a task or -- protected type. The statements are wrapped inside a block due to a local diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index c05b057edc3..d10ae75a635 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -3968,12 +3968,9 @@ package body Exp_Disp is -- are located in a separate dispatch table; skip also -- abstract and eliminated primitives. - -- Why do we skip imported primitives??? - if not Is_Predefined_Dispatching_Operation (Prim) and then Present (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (Alias (Prim)) - and then not Is_Imported (Alias (Prim)) and then not Is_Eliminated (Alias (Prim)) and then Find_Dispatching_Type (Interface_Alias (Prim)) = Iface @@ -5518,13 +5515,10 @@ package body Exp_Disp is -- to build secondary dispatch tables; skip also abstract -- and eliminated primitives. - -- Why do we skip imported primitives??? - if not Is_Predefined_Dispatching_Operation (Prim) and then not Is_Predefined_Dispatching_Operation (E) and then not Present (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (E) - and then not Is_Imported (E) and then not Is_Eliminated (E) then pragma Assert diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb index aa6191344df..227949dc0b0 100644 --- a/gcc/ada/s-rannum.adb +++ b/gcc/ada/s-rannum.adb @@ -86,9 +86,10 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Calendar; use Ada.Calendar; +with Ada.Calendar; use Ada.Calendar; with Ada.Unchecked_Conversion; -with Interfaces; use Interfaces; + +with Interfaces; use Interfaces; use Ada; @@ -122,7 +123,9 @@ package body System.Random_Numbers is Image_Numeral_Length : constant := Max_Image_Width / N; subtype Image_String is String (1 .. Max_Image_Width); - -- Utility functions + ----------------------- + -- Local Subprograms -- + ----------------------- procedure Init (Gen : out Generator; Initiator : Unsigned_32); -- Perform a default initialization of the state of Gen. The resulting @@ -199,6 +202,10 @@ package body System.Random_Numbers is -- assuming that Unsigned is large enough to hold the bits of a mantissa -- for type Real. + --------------------------- + -- Random_Float_Template -- + --------------------------- + function Random_Float_Template (Gen : Generator) return Real is pragma Compile_Time_Error @@ -232,6 +239,7 @@ package body System.Random_Numbers is if Real'Machine_Radix /= 2 then return Real'Machine (Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size)); + else declare type Bit_Count is range 0 .. 4; @@ -239,8 +247,8 @@ package body System.Random_Numbers is subtype T is Real'Base; Trailing_Ones : constant array (Unsigned_32 range 0 .. 15) - of Bit_Count - := (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2, + of Bit_Count := + (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2, 2#00100# => 0, 2#00101# => 1, 2#00110# => 0, 2#00111# => 3, 2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2, 2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4); @@ -255,21 +263,30 @@ package body System.Random_Numbers is (Unsigned'Size - T'Machine_Mantissa + 1); -- Random bits left over after selecting mantissa - Mantissa : Unsigned; - X : Real; -- Scaled mantissa - R : Unsigned_32; -- Supply of random bits - R_Bits : Natural; -- Number of bits left in R + Mantissa : Unsigned; - K : Bit_Count; -- Next decrement to exponent - begin + X : Real; + -- Scaled mantissa + + R : Unsigned_32; + -- Supply of random bits + + R_Bits : Natural; + -- Number of bits left in R + + K : Bit_Count; + -- Next decrement to exponent + begin Mantissa := Random (Gen) / 2**Extra_Bits; R := Unsigned_32 (Mantissa mod 2**Extra_Bits); R_Bits := Extra_Bits; X := Real (2**(T'Machine_Mantissa - 1) + Mantissa); -- Exact - if Extra_Bits < 4 and then R < 2**Extra_Bits - 1 then + if Extra_Bits < 4 and then R < 2 ** Extra_Bits - 1 then + -- We got lucky and got a zero in our few extra bits + K := Trailing_Ones (R); else @@ -305,12 +322,11 @@ package body System.Random_Numbers is end loop Find_Zero; end if; - -- K has the count of trailing ones not reflected yet in X. - -- The following multiplication takes care of that, as well - -- as the correction to move the radix point to the left of - -- the mantissa. Doing it at the end avoids repeated rounding - -- errors in the exceedingly unlikely case of ever having - -- a subnormal result. + -- K has the count of trailing ones not reflected yet in X. The + -- following multiplication takes care of that, as well as the + -- correction to move the radix point to the left of the mantissa. + -- Doing it at the end avoids repeated rounding errors in the + -- exceedingly unlikely case of ever having a subnormal result. X := X * Pow_Tab (K); @@ -330,6 +346,10 @@ package body System.Random_Numbers is end if; end Random_Float_Template; + ------------ + -- Random -- + ------------ + function Random (Gen : Generator) return Float is function F is new Random_Float_Template (Unsigned_32, Float); begin @@ -371,7 +391,7 @@ package body System.Random_Numbers is -- Ignore different-size warnings here; since GNAT's handling -- is correct. - pragma Warnings ("Z"); + pragma Warnings ("Z"); -- better to use msg string! ??? function Conv_To_Unsigned is new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64); function Conv_To_Result is @@ -489,7 +509,7 @@ package body System.Random_Numbers is I, J : Integer; begin - Init (Gen, 19650218); + Init (Gen, 19650218); -- please give this constant a name ??? I := 1; J := 0; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index ae087977405..99bec9b72da 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -799,4 +799,20 @@ package body Sem_Aux is Obsolescent_Warnings.Tree_Write; end Tree_Write; + -------------------- + -- Ultimate_Alias -- + -------------------- + + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := Prim; + + begin + while Present (Alias (E)) loop + pragma Assert (Alias (E) /= E); + E := Alias (E); + end loop; + + return E; + end Ultimate_Alias; + end Sem_Aux; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 464a764a3e3..8b763e05240 100755 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -193,4 +193,9 @@ package Sem_Aux is function Number_Discriminants (Typ : Entity_Id) return Pos; -- Typ is a type with discriminants, yields number of discriminants in type + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; + pragma Inline (Ultimate_Alias); + -- Return the last entity in the chain of aliased entities of Prim. If Prim + -- has no alias return Prim. + end Sem_Aux; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c33083006b6..0b984760397 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6880,23 +6880,26 @@ package body Sem_Ch4 is -- Scan the list of generic formals to find subprograms -- that may have a first controlling formal of the type. - declare - Decl : Node_Id; - - begin - Decl := - First (Generic_Formal_Declarations - (Unit_Declaration_Node (Scope (T)))); - while Present (Decl) loop - if Nkind (Decl) in N_Formal_Subprogram_Declaration then - Subp := Defining_Entity (Decl); - Check_Candidate; - end if; - - Next (Decl); - end loop; - end; + if Nkind (Unit_Declaration_Node (Scope (T))) + = N_Generic_Subprogram_Declaration + then + declare + Decl : Node_Id; + + begin + Decl := + First (Generic_Formal_Declarations + (Unit_Declaration_Node (Scope (T)))); + while Present (Decl) loop + if Nkind (Decl) in N_Formal_Subprogram_Declaration then + Subp := Defining_Entity (Decl); + Check_Candidate; + end if; + Next (Decl); + end loop; + end; + end if; return Candidates; else @@ -6906,7 +6909,15 @@ package body Sem_Ch4 is -- declaration or body (either the one that declares T, or a -- child unit). - Subp := First_Entity (Scope (T)); + -- For a subtype representing a generic actual type, go to the + -- base type. + + if Is_Generic_Actual_Type (T) then + Subp := First_Entity (Scope (Base_Type (T))); + else + Subp := First_Entity (Scope (T)); + end if; + while Present (Subp) loop if Is_Overloadable (Subp) then Check_Candidate; @@ -6979,13 +6990,14 @@ package body Sem_Ch4 is -- corresponding record (base) type. if Is_Concurrent_Type (Obj_Type) then - if not Present (Corresponding_Record_Type (Obj_Type)) then - return False; + if Present (Corresponding_Record_Type (Obj_Type)) then + Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); + Elmt := First_Elmt (Primitive_Operations (Corr_Type)); + else + Corr_Type := Obj_Type; + Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); end if; - Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); - Elmt := First_Elmt (Primitive_Operations (Corr_Type)); - elsif not Is_Generic_Type (Obj_Type) then Corr_Type := Obj_Type; Elmt := First_Elmt (Primitive_Operations (Obj_Type)); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index dd23fc0ba97..21f80dfd713 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1176,16 +1176,6 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); - -- Perform minimal expansion of protected type while inside a generic. - -- The corresponding record is needed for various semantic checks. - - if Ada_Version >= Ada_05 - and then Inside_A_Generic - then - Insert_After_And_Analyze (N, - Build_Corresponding_Record (N, T, Sloc (T))); - end if; - Analyze (Protected_Definition (N)); -- Protected types with entries are controlled (because of the @@ -1976,15 +1966,6 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); - -- Perform minimal expansion of the task type while inside a generic - -- context. The corresponding record is needed for various semantic - -- checks. - - if Inside_A_Generic then - Insert_After_And_Analyze (N, - Build_Corresponding_Record (N, T, Sloc (T))); - end if; - if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 6ffdb851635..77fcb4f6b9a 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -677,18 +677,15 @@ package body Sem_Disp is Set_Is_Dispatching_Operation (Subp, False); Tagged_Type := Find_Dispatching_Type (Subp); - -- Ada 2005 (AI-345) + -- Ada 2005 (AI-345): Use the corresponding record (if available). + -- Required because primitives of concurrent types are be attached + -- to the corresponding record (not to the concurrent type). if Ada_Version >= Ada_05 and then Present (Tagged_Type) and then Is_Concurrent_Type (Tagged_Type) + and then Present (Corresponding_Record_Type (Tagged_Type)) then - -- Protect the frontend against previously detected errors - - if No (Corresponding_Record_Type (Tagged_Type)) then - return; - end if; - Tagged_Type := Corresponding_Record_Type (Tagged_Type); end if; @@ -1068,6 +1065,18 @@ package body Sem_Disp is end if; end if; + -- If the tagged type is a concurrent type then we must be compiling + -- with no code generation (we are either compiling a generic unit or + -- compiling under -gnatc mode) because we have previously tested that + -- no serious errors has been reported. In this case we do not add the + -- primitive to the list of primitives of Tagged_Type but we leave the + -- primitive decorated as a dispatching operation to be able to analyze + -- and report errors associated with the Object.Operation notation. + + elsif Is_Concurrent_Type (Tagged_Type) then + pragma Assert (not Expander_Active); + null; + -- If no old subprogram, then we add this as a dispatching operation, -- but we avoid doing this if an error was posted, to prevent annoying -- cascaded errors. diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads index c0195ecd4fd..3877826ca29 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -46,7 +46,12 @@ package Sem_Disp is -- if it has a parameter of this type and is defined at a proper place for -- primitive operations (new primitives are only defined in package spec, -- overridden operation can be defined in any scope). If Old_Subp is not - -- Empty we are in the overriding case. + -- Empty we are in the overriding case. If the tagged type associated with + -- Subp is a concurrent type (case that occurs when the type is declared in + -- a generic because the analysis of generics disables generation of the + -- corresponding record) then this routine does does not add "Subp" to the + -- list of primitive operations but leaves Subp decorated as dispatching + -- operation to enable checks associated with the Object.Operation notation procedure Check_Operation_From_Incomplete_Type (Subp : Entity_Id; diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index 97faf84877f..c160c8e419a 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -31,6 +31,7 @@ with Namet; use Namet; with Nlists; use Nlists; with Opt; use Opt; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinput; use Sinput; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c8a98b88f45..875b89c8e0e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11125,22 +11125,6 @@ package body Sem_Util is return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; - -------------------- - -- Ultimate_Alias -- - -------------------- - - function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is - E : Entity_Id := Prim; - - begin - while Present (Alias (E)) loop - pragma Assert (Alias (E) /= E); - E := Alias (E); - end loop; - - return E; - end Ultimate_Alias; - -------------------------- -- Unit_Declaration_Node -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 8da6b52223e..dd655c9beb9 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1260,11 +1260,6 @@ package Sem_Util is function Type_Access_Level (Typ : Entity_Id) return Uint; -- Return the accessibility level of Typ - function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; - pragma Inline (Ultimate_Alias); - -- Return the last entity in the chain of aliased entities of Prim. If Prim - -- has no alias return Prim. - function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a program unit, this function returns the -- corresponding xxx_Declaration node for the entity. Also applies to the -- 2.30.2