From: Arnaud Charlet Date: Tue, 25 Apr 2017 08:37:09 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b619c88ebaa63de53de21684bdd4555598f68d49;p=gcc.git [multiple changes] 2017-04-25 Hristian Kirtchev * elists.ads, elists.adb (Prepend_Unique_Elmt): New routine. * exp_ch3.adb (Freeze_Type): Signal the DIC body is created for the purposes of freezing. * exp_util.adb Update the documentation and structure of the type map used in class-wide semantics of assertion expressions. (Add_Inherited_Tagged_DIC): There is really no need to preanalyze and resolve the triaged expression because all substitutions refer to the proper entities. Update the replacement of references. (Build_DIC_Procedure_Body): Add formal parameter For_Freeze. Add local variable Build_Body. Inherited DIC pragmas are now only processed when freezing occurs. Build a body only when one is needed. (Entity_Hash): Removed. (Map_Types): New routine. (Replace_Object_And_Primitive_References): Removed. (Replace_References): New routine. (Replace_Type_References): Moved to the library level of Exp_Util. (Type_Map_Hash): New routine. (Update_Primitives_Mapping): Update the mapping call. (Update_Primitives_Mapping_Of_Types): Removed. * exp_util.ads (Build_DIC_Procedure_Body): Add formal parameter For_Freeze and update the comment on usage. (Map_Types): New routine. (Replace_References): New routine. (Replace_Type_References): Moved to the library level of Exp_Util. (Update_Primitives_Mapping_Of_Types): Removed. * sem_ch7.adb (Preserve_Full_Attributes): Propagate the DIC properties of the private type to the full view in case the full view derives from a parent type and inherits a DIC pragma. * sem_prag.adb (Analyze_Pragma): Guard against a case where a DIC pragma is placed at the top of a declarative region. 2017-04-25 Arnaud Charlet * a-tasatt.adb: Complete previous change and use an unsigned int to avoid overflow checks. 2017-04-25 Ed Schonberg * sem_attr.adb (Analyze_Attribute, case 'Access): Specialize the error message when the attribute reference is an actual in a call to a subprogram inherited from a generic formal type with unknown discriminants, which makes the subprogram and its formal parameters intrinsic (see RM 6.3.1 (8) and (13)). From-SVN: r247148 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 75733c1a823..ad33e282509 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,51 @@ +2017-04-25 Hristian Kirtchev + + * elists.ads, elists.adb (Prepend_Unique_Elmt): New routine. + * exp_ch3.adb (Freeze_Type): Signal the DIC body is created for + the purposes of freezing. + * exp_util.adb Update the documentation and structure of the + type map used in class-wide semantics of assertion expressions. + (Add_Inherited_Tagged_DIC): There is really no need to preanalyze + and resolve the triaged expression because all substitutions + refer to the proper entities. Update the replacement of + references. + (Build_DIC_Procedure_Body): Add formal parameter + For_Freeze. Add local variable Build_Body. Inherited DIC pragmas + are now only processed when freezing occurs. Build a body only + when one is needed. + (Entity_Hash): Removed. + (Map_Types): New routine. + (Replace_Object_And_Primitive_References): Removed. + (Replace_References): New routine. + (Replace_Type_References): Moved to the library level of Exp_Util. + (Type_Map_Hash): New routine. + (Update_Primitives_Mapping): Update the mapping call. + (Update_Primitives_Mapping_Of_Types): Removed. + * exp_util.ads (Build_DIC_Procedure_Body): Add formal + parameter For_Freeze and update the comment on usage. + (Map_Types): New routine. + (Replace_References): New routine. + (Replace_Type_References): Moved to the library level of Exp_Util. + (Update_Primitives_Mapping_Of_Types): Removed. + * sem_ch7.adb (Preserve_Full_Attributes): Propagate the DIC + properties of the private type to the full view in case the full + view derives from a parent type and inherits a DIC pragma. + * sem_prag.adb (Analyze_Pragma): Guard against a case where a + DIC pragma is placed at the top of a declarative region. + +2017-04-25 Arnaud Charlet + + * a-tasatt.adb: Complete previous change and use an unsigned + int to avoid overflow checks. + +2017-04-25 Ed Schonberg + + * sem_attr.adb (Analyze_Attribute, case 'Access): Specialize + the error message when the attribute reference is an actual in + a call to a subprogram inherited from a generic formal type with + unknown discriminants, which makes the subprogram and its formal + parameters intrinsic (see RM 6.3.1 (8) and (13)). + 2017-04-25 Hristian Kirtchev * sem_aggr.adb, inline.adb, einfo.adb, einfo.ads, scng.adb, diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb index 703d1407a98..97cc06e9030 100644 --- a/gcc/ada/a-tasatt.adb +++ b/gcc/ada/a-tasatt.adb @@ -93,10 +93,11 @@ package body Ada.Task_Attributes is function To_Attribute is new Ada.Unchecked_Conversion (Atomic_Address, Attribute); + type Unsigned is mod 2 ** Integer'Size; function To_Address is new Ada.Unchecked_Conversion (Attribute, System.Address); - function To_Int is new - Ada.Unchecked_Conversion (Attribute, Integer); + function To_Unsigned is new + Ada.Unchecked_Conversion (Attribute, Unsigned); pragma Warnings (On); @@ -121,7 +122,7 @@ package body Ada.Task_Attributes is Fast_Path : constant Boolean := (Attribute'Size = Integer'Size and then Attribute'Alignment <= Atomic_Address'Alignment - and then To_Int (Initial_Value) = 0) + and then To_Unsigned (Initial_Value) = 0) or else (Attribute'Size = System.Address'Size and then Attribute'Alignment <= Atomic_Address'Alignment and then To_Address (Initial_Value) = System.Null_Address); @@ -303,7 +304,7 @@ package body Ada.Task_Attributes is -- No finalization needed, simply set to Val if Attribute'Size = Integer'Size then - TT.Attributes (Index) := Atomic_Address (To_Int (Val)); + TT.Attributes (Index) := Atomic_Address (To_Unsigned (Val)); else TT.Attributes (Index) := To_Address (Val); end if; diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index 0367bebd727..c35b51d92db 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -450,6 +450,17 @@ package body Elists is Elists.Table (To).First := Elmts.Last; end Prepend_Elmt; + ------------------------- + -- Prepend_Unique_Elmt -- + ------------------------- + + procedure Prepend_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is + begin + if not Contains (To, N) then + Prepend_Elmt (N, To); + end if; + end Prepend_Unique_Elmt; + ------------- -- Present -- ------------- diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads index c20bf2213d5..18464ed7f18 100644 --- a/gcc/ada/elists.ads +++ b/gcc/ada/elists.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -141,6 +141,10 @@ package Elists is procedure Prepend_Elmt (N : Node_Or_Entity_Id; To : Elist_Id); -- Appends N at the beginning of To, allocating a new element + procedure Prepend_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id); + -- Like Prepend_Elmt, except that a check is made to see if To already + -- contains N and if so the call has no effect. + procedure Insert_Elmt_After (N : Node_Or_Entity_Id; Elmt : Elmt_Id); -- Add a new element (N) right after the pre-existing element Elmt -- It is invalid to call this subprogram with Elmt = No_Elmt. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 20331794c97..87dd3de4c13 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7515,7 +7515,7 @@ package body Exp_Ch3 is -- verification of pragma Default_Initial_Condition's expression. if Has_DIC (Def_Id) then - Build_DIC_Procedure_Body (Def_Id); + Build_DIC_Procedure_Body (Def_Id, For_Freeze => True); end if; -- Generate the [spec and] body of the invariant procedure tasked with diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ec5c2e2f124..ef794d72e3f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -92,17 +92,27 @@ package body Exp_Util is -- operations are mapped into the overriding operations of that current -- type extension. - Primitives_Mapping_Size : constant := 511; + -- The contents of the map are as follows: - subtype Num_Primitives is Integer range 0 .. Primitives_Mapping_Size - 1; - function Entity_Hash (E : Entity_Id) return Num_Primitives; + -- Key Value - package Primitives_Mapping is new GNAT.HTable.Simple_HTable - (Header_Num => Num_Primitives, + -- Discriminant (Entity_Id) Discriminant (Entity_Id) + -- Discriminant (Entity_Id) Non-discriminant name (Entity_Id) + -- Discriminant (Entity_Id) Expression (Node_Id) + -- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id) + -- Type (Entity_Id) Type (Entity_Id) + + Type_Map_Size : constant := 511; + + subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1; + function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header; + + package Type_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Type_Map_Header, Key => Entity_Id, - Element => Entity_Id, + Element => Node_Or_Entity_Id, No_element => Empty, - Hash => Entity_Hash, + Hash => Type_Map_Hash, Equal => "="); ----------------------- @@ -1086,7 +1096,7 @@ package body Exp_Util is -- Determine whether entity has a renaming - New_E := Primitives_Mapping.Get (Entity (N)); + New_E := Type_Map.Get (Entity (N)); if Present (New_E) then Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); @@ -1172,7 +1182,7 @@ package body Exp_Util is Subp_Formal := First_Formal (Subp); while Present (Par_Formal) and then Present (Subp_Formal) loop - Primitives_Mapping.Set (Par_Formal, Subp_Formal); + Type_Map.Set (Par_Formal, Subp_Formal); Next_Formal (Par_Formal); Next_Formal (Subp_Formal); end loop; @@ -1210,7 +1220,10 @@ package body Exp_Util is -- replaced by gotos which jump to the end of the routine and restore the -- Ghost mode. - procedure Build_DIC_Procedure_Body (Typ : Entity_Id) is + procedure Build_DIC_Procedure_Body + (Typ : Entity_Id; + For_Freeze : Boolean := False) + is procedure Add_DIC_Check (DIC_Prag : Node_Id; DIC_Expr : Node_Id; @@ -1249,34 +1262,6 @@ package body Exp_Util is -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code -- is added to list Stmts. - procedure Replace_Object_And_Primitive_References - (Expr : Node_Id; - Par_Typ : Entity_Id; - Deriv_Typ : Entity_Id; - Par_Obj : Entity_Id := Empty; - Deriv_Obj : Entity_Id := Empty); - -- Expr denotes an arbitrary expression. Par_Typ is a parent type in a - -- type hierarchy. Deriv_Typ is a type derived from Par_Typ. Par_Obj is - -- the formal parameter which emulates the current instance of Par_Typ. - -- Deriv_Obj is the formal parameter which emulates the current instance - -- of Deriv_Typ. Perform the following substitutions: - -- - -- * Replace a reference to Par_Obj with a reference to Deriv_Obj if - -- applicable. - -- - -- * Replace a call to an overridden parent primitive with a call to - -- the overriding derived type primitive. - -- - -- * Replace a call to an inherited parent primitive with a call to - -- the internally-generated inherited derived type primitive. - - procedure Replace_Type_References - (Expr : Node_Id; - Typ : Entity_Id; - Obj_Id : Entity_Id); - -- Substitute all references of the current instance of type Typ with - -- references to formal parameter Obj_Id within expression Expr. - ------------------- -- Add_DIC_Check -- ------------------- @@ -1358,7 +1343,6 @@ package body Exp_Util is Deriv_Typ : Entity_Id; Stmts : in out List_Id) is - Deriv_Decl : constant Node_Id := Declaration_Node (Deriv_Typ); Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ); DIC_Args : constant List_Id := Pragma_Argument_Associations (DIC_Prag); @@ -1383,6 +1367,9 @@ package body Exp_Util is -- type's DIC procedure with a reference to the _object parameter -- of the derived types' DIC procedure. + -- * Replace a reference to a discriminant of the parent type with + -- a suitable value from the point of view of the derived type. + -- * Replace a call to an overridden parent primitive with a call -- to the overriding derived type primitive. @@ -1395,19 +1382,13 @@ package body Exp_Util is pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc)); - Replace_Object_And_Primitive_References + Replace_References (Expr => Expr, Par_Typ => Par_Typ, Deriv_Typ => Deriv_Typ, Par_Obj => First_Formal (Par_Proc), Deriv_Obj => First_Formal (Deriv_Proc)); - -- Preanalyze the DIC expression to detect errors and at the same - -- time capture the visibility of the proper package part. - - Set_Parent (Expr, Deriv_Decl); - Preanalyze_Assert_Expression (Expr, Any_Boolean); - -- Once the DIC assertion expression is fully processed, add a check -- to the statements of the DIC procedure. @@ -1531,200 +1512,6 @@ package body Exp_Util is Stmts => Stmts); end Add_Own_DIC; - --------------------------------------------- - -- Replace_Object_And_Primitive_References -- - --------------------------------------------- - - procedure Replace_Object_And_Primitive_References - (Expr : Node_Id; - Par_Typ : Entity_Id; - Deriv_Typ : Entity_Id; - Par_Obj : Entity_Id := Empty; - Deriv_Obj : Entity_Id := Empty) - is - function Replace_Ref (Ref : Node_Id) return Traverse_Result; - -- Substitute a reference to an entity with a reference to the - -- corresponding entity stored in in table Primitives_Mapping. - - ----------------- - -- Replace_Ref -- - ----------------- - - function Replace_Ref (Ref : Node_Id) return Traverse_Result is - Context : constant Node_Id := Parent (Ref); - Loc : constant Source_Ptr := Sloc (Ref); - New_Id : Entity_Id; - New_Ref : Node_Id; - Ref_Id : Entity_Id; - Result : Traverse_Result; - - begin - Result := OK; - - -- The current node denotes a reference - - if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then - Ref_Id := Entity (Ref); - New_Id := Primitives_Mapping.Get (Ref_Id); - - -- The reference mentions a parent type primitive which has a - -- corresponding derived type primitive. - - if Present (New_Id) then - New_Ref := New_Occurrence_Of (New_Id, Loc); - - -- The reference mentions the _object parameter of the parent - -- type's DIC procedure. - - elsif Present (Par_Obj) - and then Present (Deriv_Obj) - and then Ref_Id = Par_Obj - then - New_Ref := New_Occurrence_Of (Deriv_Obj, Loc); - - -- The reference to _object acts as an actual parameter in a - -- subprogram call which may be invoking a primitive of the - -- parent type: - - -- Primitive (... _object ...); - - -- The parent type primitive may not be overridden nor - -- inherited when it is declared after the derived type - -- definition: - - -- type Parent is tagged private; - -- type Child is new Parent with private; - -- procedure Primitive (Obj : Parent); - - -- In this scenario the _object parameter is converted to - -- the parent type. - - if Nkind_In (Context, N_Function_Call, - N_Procedure_Call_Statement) - and then - No (Primitives_Mapping.Get (Entity (Name (Context)))) - then - New_Ref := Convert_To (Par_Typ, New_Ref); - - -- Do not process the generated type conversion because - -- both the parent type and the derived type are in the - -- Primitives_Mapping table. This will clobber the type - -- conversion by resetting its subtype mark. - - Result := Skip; - end if; - - -- Otherwise there is nothing to replace - - else - New_Ref := Empty; - end if; - - if Present (New_Ref) then - Rewrite (Ref, New_Ref); - - -- Update the return type when the context of the reference - -- acts as the name of a function call. Note that the update - -- should not be performed when the reference appears as an - -- actual in the call. - - if Nkind (Context) = N_Function_Call - and then Name (Context) = Ref - then - Set_Etype (Context, Etype (New_Id)); - end if; - end if; - end if; - - -- Reanalyze the reference due to potential replacements - - if Nkind (Ref) in N_Has_Etype then - Set_Analyzed (Ref, False); - end if; - - return Result; - end Replace_Ref; - - procedure Replace_Refs is new Traverse_Proc (Replace_Ref); - - -- Start of processing for Replace_Object_And_Primitive_References - - begin - -- Map each primitive operation of the parent type to the proper - -- primitive of the derived type. - - Update_Primitives_Mapping_Of_Types - (Par_Typ => Par_Typ, - Deriv_Typ => Deriv_Typ); - - -- Inspect the input expression and perform substitutions where - -- necessary. - - Replace_Refs (Expr); - end Replace_Object_And_Primitive_References; - - ----------------------------- - -- Replace_Type_References -- - ----------------------------- - - procedure Replace_Type_References - (Expr : Node_Id; - Typ : Entity_Id; - Obj_Id : Entity_Id) - is - procedure Replace_Type_Ref (N : Node_Id); - -- Substitute a single reference of the current instance of type Typ - -- with a reference to Obj_Id. - - ---------------------- - -- Replace_Type_Ref -- - ---------------------- - - procedure Replace_Type_Ref (N : Node_Id) is - Ref : Node_Id; - - begin - -- Decorate the reference to Typ even though it may be rewritten - -- further down. This is done for two reasons: - - -- 1) ASIS has all necessary semantic information in the - -- original tree. - - -- 2) Routines which examine properties of the Original_Node - -- have some semantic information. - - if Nkind (N) = N_Identifier then - Set_Entity (N, Typ); - Set_Etype (N, Typ); - - elsif Nkind (N) = N_Selected_Component then - Analyze (Prefix (N)); - Set_Entity (Selector_Name (N), Typ); - Set_Etype (Selector_Name (N), Typ); - end if; - - -- Perform the following substitution: - - -- Typ --> _object - - Ref := Make_Identifier (Sloc (N), Chars (Obj_Id)); - Set_Entity (Ref, Obj_Id); - Set_Etype (Ref, Typ); - - Rewrite (N, Ref); - - Set_Comes_From_Source (N, True); - end Replace_Type_Ref; - - procedure Replace_Type_Refs is - new Replace_Type_References_Generic (Replace_Type_Ref); - - -- Start of processing for Replace_Type_References - - begin - Replace_Type_Refs (Expr, Typ); - end Replace_Type_References; - -- Local variables Loc : constant Source_Ptr := Sloc (Typ); @@ -1740,6 +1527,9 @@ package body Exp_Util is Proc_Id : Entity_Id; Stmts : List_Id := No_List; + Build_Body : Boolean := False; + -- Flag set when the type requires a DIC procedure body to be built + Work_Typ : Entity_Id; -- The working type @@ -1854,9 +1644,18 @@ package body Exp_Util is DIC_Typ => DIC_Typ, Stmts => Stmts); - -- Otherwise the working type inherits a DIC pragma from a parent type + Build_Body := True; - else + -- Otherwise the working type inherits a DIC pragma from a parent type. + -- This processing is carried out when the type is frozen because the + -- state of all parent discriminants is known at that point. Note that + -- it is semantically sound to delay the creation of the DIC procedure + -- body till the freeze point. If the type has a DIC pragma of its own, + -- then the DIC procedure body would have already been constructed at + -- the end of the visible declarations and all parent DIC pragmas are + -- effectively "hidden" and irrelevant. + + elsif For_Freeze then pragma Assert (Has_Inherited_DIC (Work_Typ)); pragma Assert (DIC_Typ /= Work_Typ); @@ -1882,66 +1681,71 @@ package body Exp_Util is Deriv_Typ => Work_Typ, Stmts => Stmts); end if; + + Build_Body := True; end if; End_Scope; - -- Produce an empty completing body in the following cases: - -- * Assertions are disabled - -- * The DIC Assertion_Policy is Ignore - -- * Pragma DIC appears without an argument - -- * Pragma DIC appears with argument "null" + if Build_Body then - if No (Stmts) then - Stmts := New_List (Make_Null_Statement (Loc)); - end if; + -- Produce an empty completing body in the following cases: + -- * Assertions are disabled + -- * The DIC Assertion_Policy is Ignore + -- * Pragma DIC appears without an argument + -- * Pragma DIC appears with argument "null" - -- Generate: - -- procedure DIC (_object : ) is - -- begin - -- - -- end DIC; + if No (Stmts) then + Stmts := New_List (Make_Null_Statement (Loc)); + end if; + + -- Generate: + -- procedure DIC (_object : ) is + -- begin + -- + -- end DIC; - Proc_Body := - Make_Subprogram_Body (Loc, - Specification => - Copy_Subprogram_Spec (Parent (Proc_Id)), - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts)); - Proc_Body_Id := Defining_Entity (Proc_Body); + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Subprogram_Spec (Parent (Proc_Id)), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + Proc_Body_Id := Defining_Entity (Proc_Body); - -- Perform minor decoration in case the body is not analyzed + -- Perform minor decoration in case the body is not analyzed - Set_Ekind (Proc_Body_Id, E_Subprogram_Body); - Set_Etype (Proc_Body_Id, Standard_Void_Type); - Set_Scope (Proc_Body_Id, Current_Scope); + Set_Ekind (Proc_Body_Id, E_Subprogram_Body); + Set_Etype (Proc_Body_Id, Standard_Void_Type); + Set_Scope (Proc_Body_Id, Current_Scope); - -- Link both spec and body to avoid generating duplicates + -- Link both spec and body to avoid generating duplicates - Set_Corresponding_Body (Proc_Decl, Proc_Body_Id); - Set_Corresponding_Spec (Proc_Body, Proc_Id); + Set_Corresponding_Body (Proc_Decl, Proc_Body_Id); + Set_Corresponding_Spec (Proc_Body, Proc_Id); - -- The body should not be inserted into the tree when the context is - -- ASIS or a generic unit because it is not part of the template. Note - -- that the body must still be generated in order to resolve the DIC - -- assertion expression. + -- The body should not be inserted into the tree when the context + -- is ASIS or a generic unit because it is not part of the template. + -- Note that the body must still be generated in order to resolve the + -- DIC assertion expression. - if ASIS_Mode or Inside_A_Generic then - null; + if ASIS_Mode or Inside_A_Generic then + null; - -- Semi-insert the body into the tree for GNATprove by setting its - -- Parent field. This allows for proper upstream tree traversals. + -- Semi-insert the body into the tree for GNATprove by setting its + -- Parent field. This allows for proper upstream tree traversals. - elsif GNATprove_Mode then - Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ))); + elsif GNATprove_Mode then + Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ))); - -- Otherwise the body is part of the freezing actions of the working - -- type. + -- Otherwise the body is part of the freezing actions of the working + -- type. - else - Append_Freeze_Action (Work_Typ, Proc_Body); + else + Append_Freeze_Action (Work_Typ, Proc_Body); + end if; end if; <> @@ -3388,15 +3192,6 @@ package body Exp_Util is end if; end Ensure_Defined; - ----------------- - -- Entity_Hash -- - ----------------- - - function Entity_Hash (E : Entity_Id) return Num_Primitives is - begin - return Num_Primitives (E mod Primitives_Mapping_Size); - end Entity_Hash; - -------------------- -- Entry_Names_OK -- -------------------- @@ -8289,155 +8084,734 @@ package body Exp_Util is Constraints => List_Constr)); end Make_Subtype_From_Expr; - ---------------------------- - -- Matching_Standard_Type -- - ---------------------------- + --------------- + -- Map_Types -- + --------------- - function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is - pragma Assert (Is_Scalar_Type (Typ)); - Siz : constant Uint := Esize (Typ); + procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is - begin - -- Floating-point cases + -- NOTE: Most of the routines in Map_Types are intentionally unnested to + -- avoid deep indentation of code. - if Is_Floating_Point_Type (Typ) then - if Siz <= Esize (Standard_Short_Float) then - return Standard_Short_Float; - elsif Siz <= Esize (Standard_Float) then - return Standard_Float; - elsif Siz <= Esize (Standard_Long_Float) then - return Standard_Long_Float; - elsif Siz <= Esize (Standard_Long_Long_Float) then - return Standard_Long_Long_Float; - else - raise Program_Error; - end if; + -- NOTE: Routines which deal with discriminant mapping operate on the + -- [underlying/record] full view of various types because those views + -- contain all discriminants and stored constraints. - -- Integer cases (includes fixed-point types) + procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id); + -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or + -- overriding chain starting from Prim whose dispatching type is parent + -- type Par_Typ and add a mapping between the result and primitive Prim. - -- Unsigned integer cases (includes normal enumeration types) + function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id; + -- Subsidiary to Map_Primitives. Return the next ancestor primitive in + -- the inheritance or overriding chain of subprogram Subp. Return Empty + -- if no such primitive is available. - elsif Is_Unsigned_Type (Typ) then - if Siz <= Esize (Standard_Short_Short_Unsigned) then - return Standard_Short_Short_Unsigned; - elsif Siz <= Esize (Standard_Short_Unsigned) then - return Standard_Short_Unsigned; - elsif Siz <= Esize (Standard_Unsigned) then - return Standard_Unsigned; - elsif Siz <= Esize (Standard_Long_Unsigned) then - return Standard_Long_Unsigned; - elsif Siz <= Esize (Standard_Long_Long_Unsigned) then - return Standard_Long_Long_Unsigned; - else - raise Program_Error; - end if; + function Build_Chain + (Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id) return Elist_Id; + -- Subsidiary to Map_Discriminants. Recreate the derivation chain from + -- parent type Par_Typ leading down towards derived type Deriv_Typ. The + -- list has the form: + -- + -- head tail + -- v v + -- -> -> -> Deriv_Typ + -- + -- Note that Par_Typ is not part of the resulting derivation chain - -- Signed integer cases + function Discriminated_View (Typ : Entity_Id) return Entity_Id; + -- Return the view of type Typ which could potentially contains either + -- the discriminants or stored constraints of the type. - else - if Siz <= Esize (Standard_Short_Short_Integer) then - return Standard_Short_Short_Integer; - elsif Siz <= Esize (Standard_Short_Integer) then - return Standard_Short_Integer; - elsif Siz <= Esize (Standard_Integer) then - return Standard_Integer; - elsif Siz <= Esize (Standard_Long_Integer) then - return Standard_Long_Integer; - elsif Siz <= Esize (Standard_Long_Long_Integer) then - return Standard_Long_Long_Integer; - else - raise Program_Error; - end if; - end if; - end Matching_Standard_Type; + function Find_Discriminant_Value + (Discr : Entity_Id; + Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id; + Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id; + -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr + -- in the derivation chain starting from parent type Par_Typ leading to + -- derived type Deriv_Typ. The returned value is one of the following: + -- + -- * An entity which is either a discriminant or a non-discriminant + -- name, and renames/constraints Discr. + -- + -- * An expression which constraints Discr + -- + -- Typ_Elmt is an element of the derivation chain created by routine + -- Build_Chain and denotes the current ancestor being examined. - ----------------------------- - -- May_Generate_Large_Temp -- - ----------------------------- + procedure Map_Discriminants + (Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id); + -- Map each discriminant of type Par_Typ to a meaningful constraint + -- from the point of view of type Deriv_Typ. - -- At the current time, the only types that we return False for (i.e. where - -- we decide we know they cannot generate large temps) are ones where we - -- know the size is 256 bits or less at compile time, and we are still not - -- doing a thorough job on arrays and records ??? + procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id); + -- Map each primitive of type Par_Typ to a corresponding primitive of + -- type Deriv_Typ. - function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is - begin - if not Size_Known_At_Compile_Time (Typ) then - return False; + ------------------- + -- Add_Primitive -- + ------------------- - elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then - return False; + procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is + Par_Prim : Entity_Id; - elsif Is_Array_Type (Typ) - and then Present (Packed_Array_Impl_Type (Typ)) - then - return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ)); + begin + -- Inspect the inheritance chain through the Alias attribute and the + -- overriding chain through the Overridden_Operation looking for an + -- ancestor primitive with the appropriate dispatching type. - -- We could do more here to find other small types ??? + Par_Prim := Prim; + while Present (Par_Prim) loop + exit when Find_Dispatching_Type (Par_Prim) = Par_Typ; + Par_Prim := Ancestor_Primitive (Par_Prim); + end loop; - else - return True; - end if; - end May_Generate_Large_Temp; + -- Create a mapping of the form: - ------------------------ - -- Needs_Finalization -- - ------------------------ + -- parent type primitive -> derived type primitive - function Needs_Finalization (T : Entity_Id) return Boolean is - function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; - -- If type is not frozen yet, check explicitly among its components, - -- because the Has_Controlled_Component flag is not necessarily set. + if Present (Par_Prim) then + Type_Map.Set (Par_Prim, Prim); + end if; + end Add_Primitive; - ----------------------------------- - -- Has_Some_Controlled_Component -- - ----------------------------------- + ------------------------ + -- Ancestor_Primitive -- + ------------------------ - function Has_Some_Controlled_Component - (Rec : Entity_Id) return Boolean - is - Comp : Entity_Id; + function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is + Inher_Prim : constant Entity_Id := Alias (Subp); + Over_Prim : constant Entity_Id := Overridden_Operation (Subp); begin - if Has_Controlled_Component (Rec) then - return True; + -- The current subprogram overrides an ancestor primitive - elsif not Is_Frozen (Rec) then - if Is_Record_Type (Rec) then - Comp := First_Entity (Rec); + if Present (Over_Prim) then + return Over_Prim; - while Present (Comp) loop - if not Is_Type (Comp) - and then Needs_Finalization (Etype (Comp)) - then - return True; - end if; + -- The current subprogram is an internally generated alias of an + -- inherited ancestor primitive. - Next_Entity (Comp); - end loop; + elsif Present (Inher_Prim) then + return Inher_Prim; - return False; + -- Otherwise the current subprogram is the root of the inheritance or + -- overriding chain. - else - return - Is_Array_Type (Rec) - and then Needs_Finalization (Component_Type (Rec)); - end if; else - return False; + return Empty; end if; - end Has_Some_Controlled_Component; + end Ancestor_Primitive; - -- Start of processing for Needs_Finalization + ----------------- + -- Build_Chain -- + ----------------- - begin - -- Certain run-time configurations and targets do not provide support - -- for controlled types. + function Build_Chain + (Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id) return Elist_Id + is + Anc_Typ : Entity_Id; + Chain : Elist_Id; + Curr_Typ : Entity_Id; - if Restriction_Active (No_Finalization) then - return False; + begin + Chain := New_Elmt_List; - -- C++ types are not considered controlled. It is assumed that the + -- Add the derived type to the derivation chain + + Prepend_Elmt (Deriv_Typ, Chain); + + -- Examine all ancestors starting from the derived type climbing + -- towards parent type Par_Typ. + + Curr_Typ := Deriv_Typ; + loop + -- Work with the view which contains the discriminants and stored + -- constraints. + + Anc_Typ := Discriminated_View (Base_Type (Etype (Curr_Typ))); + + -- Use the first subtype when dealing with base types + + if Is_Itype (Anc_Typ) then + Anc_Typ := First_Subtype (Anc_Typ); + end if; + + -- Stop the climb when either the parent type has been reached or + -- there are no more ancestors left to examine. + + exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ; + + Prepend_Unique_Elmt (Anc_Typ, Chain); + Curr_Typ := Anc_Typ; + end loop; + + return Chain; + end Build_Chain; + + ------------------------ + -- Discriminated_View -- + ------------------------ + + function Discriminated_View (Typ : Entity_Id) return Entity_Id is + T : Entity_Id; + + begin + T := Typ; + + -- Use the [underlying] full view when dealing with private types + -- because the view contains all inherited discriminants or stored + -- constraints. + + if Is_Private_Type (T) then + if Present (Underlying_Full_View (T)) then + T := Underlying_Full_View (T); + + elsif Present (Full_View (T)) then + T := Full_View (T); + end if; + end if; + + -- Use the underlying record view when the type is an extenstion of + -- a parent type with unknown discriminants because the view contains + -- all inherited discriminants or stored constraints. + + if Ekind (T) = E_Record_Type + and then Present (Underlying_Record_View (T)) + then + T := Underlying_Record_View (T); + end if; + + return T; + end Discriminated_View; + + ----------------------------- + -- Find_Discriminant_Value -- + ----------------------------- + + function Find_Discriminant_Value + (Discr : Entity_Id; + Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id; + Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id + is + Discr_Pos : constant Uint := Discriminant_Number (Discr); + Typ : constant Entity_Id := Node (Typ_Elmt); + + function Find_Constraint_Value + (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id; + -- Given constraint Constr, find what it denotes. This is either: + -- + -- * An entity which is either a discriminant or a name + -- + -- * An expression + + --------------------------- + -- Find_Constraint_Value -- + --------------------------- + + function Find_Constraint_Value + (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id + is + begin + if Nkind (Constr) in N_Entity then + + -- The constraint denotes a discriminant of the curren type + -- which renames the ancestor discriminant: + + -- vv + -- type Typ (D1 : ...; DN : ...) is + -- new Anc (Discr => D1) with ... + -- ^^ + + if Ekind (Constr) = E_Discriminant then + + -- The discriminant belongs to derived type Deriv_Typ. This + -- is the final value for the ancestor discriminant as the + -- derivations chain has been fully exhausted. + + if Typ = Deriv_Typ then + return Constr; + + -- Otherwise the discriminant may be renamed or constrained + -- at a lower level. Continue looking down the derivation + -- chain. + + else + return + Find_Discriminant_Value + (Discr => Constr, + Par_Typ => Par_Typ, + Deriv_Typ => Deriv_Typ, + Typ_Elmt => Next_Elmt (Typ_Elmt)); + end if; + + -- Otherwise the constraint denotes a reference to some name + -- which results in a Girder discriminant: + + -- vvvv + -- Name : ...; + -- type Typ (D1 : ...; DN : ...) is + -- new Anc (Discr => Name) with ... + -- ^^^^ + + -- Return the name as this is the proper constraint of the + -- discriminant. + + else + return Constr; + end if; + + -- The constraint denotes a reference to a name + + elsif Is_Entity_Name (Constr) then + return Find_Constraint_Value (Entity (Constr)); + + -- Otherwise the current constraint is an expression which yields + -- a Girder discriminant: + + -- type Typ (D1 : ...; DN : ...) is + -- new Anc (Discr => ) with ... + -- ^^^^^^^^^^ + + -- Return the expression as this is the proper constraint of the + -- discriminant. + + else + return Constr; + end if; + end Find_Constraint_Value; + + -- Local variables + + Constrs : constant Elist_Id := Stored_Constraint (Typ); + + Constr_Elmt : Elmt_Id; + Pos : Uint; + Typ_Discr : Entity_Id; + + -- Start of processing for Find_Discriminant_Value + + begin + -- The algorithm for finding the value of a discriminant works as + -- follows. First, it recreates the derivation chain from Par_Typ + -- to Deriv_Typ as a list: + + -- Par_Typ (shown for completeness) + -- v + -- Ancestor_N <-- head of chain + -- v + -- Ancestor_1 + -- v + -- Deriv_Typ <-- tail of chain + + -- The algorithm then traces the fate of a parent discriminant down + -- the derivation chain. At each derivation level, the discriminant + -- may be either inherited or constrained. + + -- 1) Discriminant is inherited: there are two cases, depending on + -- which type is inheriting. + + -- 1.1) Deriv_Typ is inheriting: + + -- type Ancestor (D_1 : ...) is tagged ... + -- type Deriv_Typ is new Ancestor ... + + -- In this case the inherited discriminant is the final value of + -- the parent discriminant because the end of the derivation chain + -- has been reached. + + -- 1.2) Some other type is inheriting: + + -- type Ancestor_1 (D_1 : ...) is tagged ... + -- type Ancestor_2 is new Ancestor_1 ... + + -- In this case the algorithm continues to trace the fate of the + -- inherited discriminant down the derivation chain because it may + -- be further inherited or constrained. + + -- 2) Discriminant is constrained: there are three cases, depending + -- on what the constraint is. + + -- 2.1) The constraint is another discriminant (aka renaming): + + -- type Ancestor_1 (D_1 : ...) is tagged ... + -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ... + + -- In this case the constraining discriminant becomes the one to + -- track down the derivation chain. The algorithm already knows + -- that D_2 constrains D_1, therefore if the algorithm finds the + -- value of D_2, then this would also be the value for D_1. + + -- 2.2) The constraint is a name (aka Girder): + + -- Name : ... + -- type Ancestor_1 (D_1 : ...) is tagged ... + -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ... + + -- In this case the name is the final value of D_1 because the + -- discriminant cannot be further constrained. + + -- 2.3) The constraint is an expression (aka Girder): + + -- type Ancestor_1 (D_1 : ...) is tagged ... + -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ... + + -- Similar to 2.2, the expression is the final value of D_1 + + Pos := Uint_1; + + -- When a derived type constrains its parent type, all constaints + -- appear in the Stored_Constraint list. Examine the list looking + -- for a positional match. + + if Present (Constrs) then + Constr_Elmt := First_Elmt (Constrs); + while Present (Constr_Elmt) loop + + -- The position of the current constraint matches that of the + -- ancestor discriminant. + + if Pos = Discr_Pos then + return Find_Constraint_Value (Node (Constr_Elmt)); + end if; + + Next_Elmt (Constr_Elmt); + Pos := Pos + 1; + end loop; + + -- Otherwise the derived type does not constraint its parent type in + -- which case it inherits the parent discriminants. + + else + Typ_Discr := First_Discriminant (Typ); + while Present (Typ_Discr) loop + + -- The position of the current discriminant matches that of the + -- ancestor discriminant. + + if Pos = Discr_Pos then + return Find_Constraint_Value (Typ_Discr); + end if; + + Next_Discriminant (Typ_Discr); + Pos := Pos + 1; + end loop; + end if; + + -- A discriminant must always have a corresponding value. This is + -- either another discriminant, a name, or an expression. If this + -- point is reached, them most likely the derivation chain employs + -- the wrong views of types. + + pragma Assert (False); + + return Empty; + end Find_Discriminant_Value; + + ----------------------- + -- Map_Discriminants -- + ----------------------- + + procedure Map_Discriminants + (Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id) + is + Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ); + + Discr : Entity_Id; + Discr_Val : Node_Or_Entity_Id; + + begin + -- Examine each discriminant of parent type Par_Typ and find a + -- suitable value for it from the point of view of derived type + -- Deriv_Typ. + + if Has_Discriminants (Par_Typ) then + Discr := First_Discriminant (Par_Typ); + while Present (Discr) loop + Discr_Val := + Find_Discriminant_Value + (Discr => Discr, + Par_Typ => Par_Typ, + Deriv_Typ => Deriv_Typ, + Typ_Elmt => First_Elmt (Deriv_Chain)); + + -- Create a mapping of the form: + + -- parent type discriminant -> value + + Type_Map.Set (Discr, Discr_Val); + + Next_Discriminant (Discr); + end loop; + end if; + end Map_Discriminants; + + -------------------- + -- Map_Primitives -- + -------------------- + + procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is + Deriv_Prim : Entity_Id; + Par_Prim : Entity_Id; + Par_Prims : Elist_Id; + Prim_Elmt : Elmt_Id; + + begin + -- Inspect the primitives of the derived type and determine whether + -- they relate to the primitives of the parent type. If there is a + -- meaningful relation, create a mapping of the form: + + -- parent type primitive -> perived type primitive + + if Present (Direct_Primitive_Operations (Deriv_Typ)) then + Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ)); + while Present (Prim_Elmt) loop + Deriv_Prim := Node (Prim_Elmt); + + if Is_Subprogram (Deriv_Prim) + and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ + then + Add_Primitive (Deriv_Prim, Par_Typ); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + + -- If the parent operation is an interface operation, the overriding + -- indicator is not present. Instead, we get from the interface + -- operation the primitive of the current type that implements it. + + if Is_Interface (Par_Typ) then + Par_Prims := Collect_Primitive_Operations (Par_Typ); + + if Present (Par_Prims) then + Prim_Elmt := First_Elmt (Par_Prims); + + while Present (Prim_Elmt) loop + Par_Prim := Node (Prim_Elmt); + Deriv_Prim := + Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim); + + if Present (Deriv_Prim) then + Type_Map.Set (Par_Prim, Deriv_Prim); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + end if; + end Map_Primitives; + + -- Start of processing for Map_Types + + begin + -- Nothing to do if there are no types to work with + + if No (Parent_Type) or else No (Derived_Type) then + return; + + -- Nothing to do if the mapping already exists + + elsif Type_Map.Get (Parent_Type) = Derived_Type then + return; + + -- Nothing to do if both types are not tagged. Note that untagged types + -- do not have primitive operations and their discriminants are already + -- handled by gigi. + + elsif not Is_Tagged_Type (Parent_Type) + or else not Is_Tagged_Type (Derived_Type) + then + return; + end if; + + -- Create a mapping of the form + + -- parent type -> derived type + + -- to prevent any subsequent attempts to produce the same relations + + Type_Map.Set (Parent_Type, Derived_Type); + + -- Create mappings of the form + + -- parent type discriminant -> derived type discriminant + -- + -- parent type discriminant -> constraint + + -- Note that mapping of discriminants breaks privacy because it needs to + -- work with those views which contains the discriminants and any stored + -- constraints. + + Map_Discriminants + (Par_Typ => Discriminated_View (Parent_Type), + Deriv_Typ => Discriminated_View (Derived_Type)); + + -- Create mappings of the form + + -- parent type primitive -> derived type primitive + + Map_Primitives + (Par_Typ => Parent_Type, + Deriv_Typ => Derived_Type); + end Map_Types; + + ---------------------------- + -- Matching_Standard_Type -- + ---------------------------- + + function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is + pragma Assert (Is_Scalar_Type (Typ)); + Siz : constant Uint := Esize (Typ); + + begin + -- Floating-point cases + + if Is_Floating_Point_Type (Typ) then + if Siz <= Esize (Standard_Short_Float) then + return Standard_Short_Float; + elsif Siz <= Esize (Standard_Float) then + return Standard_Float; + elsif Siz <= Esize (Standard_Long_Float) then + return Standard_Long_Float; + elsif Siz <= Esize (Standard_Long_Long_Float) then + return Standard_Long_Long_Float; + else + raise Program_Error; + end if; + + -- Integer cases (includes fixed-point types) + + -- Unsigned integer cases (includes normal enumeration types) + + elsif Is_Unsigned_Type (Typ) then + if Siz <= Esize (Standard_Short_Short_Unsigned) then + return Standard_Short_Short_Unsigned; + elsif Siz <= Esize (Standard_Short_Unsigned) then + return Standard_Short_Unsigned; + elsif Siz <= Esize (Standard_Unsigned) then + return Standard_Unsigned; + elsif Siz <= Esize (Standard_Long_Unsigned) then + return Standard_Long_Unsigned; + elsif Siz <= Esize (Standard_Long_Long_Unsigned) then + return Standard_Long_Long_Unsigned; + else + raise Program_Error; + end if; + + -- Signed integer cases + + else + if Siz <= Esize (Standard_Short_Short_Integer) then + return Standard_Short_Short_Integer; + elsif Siz <= Esize (Standard_Short_Integer) then + return Standard_Short_Integer; + elsif Siz <= Esize (Standard_Integer) then + return Standard_Integer; + elsif Siz <= Esize (Standard_Long_Integer) then + return Standard_Long_Integer; + elsif Siz <= Esize (Standard_Long_Long_Integer) then + return Standard_Long_Long_Integer; + else + raise Program_Error; + end if; + end if; + end Matching_Standard_Type; + + ----------------------------- + -- May_Generate_Large_Temp -- + ----------------------------- + + -- At the current time, the only types that we return False for (i.e. where + -- we decide we know they cannot generate large temps) are ones where we + -- know the size is 256 bits or less at compile time, and we are still not + -- doing a thorough job on arrays and records ??? + + function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is + begin + if not Size_Known_At_Compile_Time (Typ) then + return False; + + elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then + return False; + + elsif Is_Array_Type (Typ) + and then Present (Packed_Array_Impl_Type (Typ)) + then + return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ)); + + -- We could do more here to find other small types ??? + + else + return True; + end if; + end May_Generate_Large_Temp; + + ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (T : Entity_Id) return Boolean is + function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; + -- If type is not frozen yet, check explicitly among its components, + -- because the Has_Controlled_Component flag is not necessarily set. + + ----------------------------------- + -- Has_Some_Controlled_Component -- + ----------------------------------- + + function Has_Some_Controlled_Component + (Rec : Entity_Id) return Boolean + is + Comp : Entity_Id; + + begin + if Has_Controlled_Component (Rec) then + return True; + + elsif not Is_Frozen (Rec) then + if Is_Record_Type (Rec) then + Comp := First_Entity (Rec); + + while Present (Comp) loop + if not Is_Type (Comp) + and then Needs_Finalization (Etype (Comp)) + then + return True; + end if; + + Next_Entity (Comp); + end loop; + + return False; + + else + return + Is_Array_Type (Rec) + and then Needs_Finalization (Component_Type (Rec)); + end if; + else + return False; + end if; + end Has_Some_Controlled_Component; + + -- Start of processing for Needs_Finalization + + begin + -- Certain run-time configurations and targets do not provide support + -- for controlled types. + + if Restriction_Active (No_Finalization) then + return False; + + -- C++ types are not considered controlled. It is assumed that the -- non-Ada side will handle their clean up. elsif Convention (T) = Convention_CPP then @@ -9521,6 +9895,321 @@ package body Exp_Util is Scope_Suppress := Svg_Suppress; end Remove_Side_Effects; + ------------------------ + -- Replace_References -- + ------------------------ + + procedure Replace_References + (Expr : Node_Id; + Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id; + Par_Obj : Entity_Id := Empty; + Deriv_Obj : Entity_Id := Empty) + is + function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean; + -- Determine whether node Ref denotes some component of Deriv_Obj + + function Replace_Ref (Ref : Node_Id) return Traverse_Result; + -- Substitute a reference to an entity with the corresponding value + -- stored in table Type_Map. + + function Type_Of_Formal + (Call : Node_Id; + Actual : Node_Id) return Entity_Id; + -- Find the type of the formal parameter which corresponds to actual + -- parameter Actual in subprogram call Call. + + ---------------------- + -- Is_Deriv_Obj_Ref -- + ---------------------- + + function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is + Par : constant Node_Id := Parent (Ref); + + begin + -- Detect the folowing selected component form: + + -- Deriv_Obj.(something) + + return + Nkind (Par) = N_Selected_Component + and then Is_Entity_Name (Prefix (Par)) + and then Entity (Prefix (Par)) = Deriv_Obj; + end Is_Deriv_Obj_Ref; + + ----------------- + -- Replace_Ref -- + ----------------- + + function Replace_Ref (Ref : Node_Id) return Traverse_Result is + Context : constant Node_Id := Parent (Ref); + Loc : constant Source_Ptr := Sloc (Ref); + Ref_Id : Entity_Id; + Result : Traverse_Result; + + New_Ref : Node_Id; + -- The new reference which is intended to substitute the old one + + Old_Ref : Node_Id; + -- The reference designated for replacement. In certain cases this + -- may be a node other than Ref. + + Val : Node_Or_Entity_Id; + -- The corresponding value of Ref from the type map + + begin + -- Assume that the input reference is to be replaced and that the + -- traversal should examine the children of the reference. + + Old_Ref := Ref; + Result := OK; + + -- The input denotes a meaningful reference + + if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then + Ref_Id := Entity (Ref); + Val := Type_Map.Get (Ref_Id); + + -- The reference has a corresponding value in the type map, a + -- substitution is possible. + + if Present (Val) then + + -- The reference denotes a discriminant + + if Ekind (Ref_Id) = E_Discriminant then + if Nkind (Val) in N_Entity then + + -- The value denotes another discriminant. Replace as + -- follows: + + -- _object.Discr -> _object.Val + + if Ekind (Val) = E_Discriminant then + New_Ref := New_Occurrence_Of (Val, Loc); + + -- Otherwise the value denotes the entity of a name which + -- constraints the discriminant. Replace as follows: + + -- _object.Discr -> Val + + else + pragma Assert (Is_Deriv_Obj_Ref (Old_Ref)); + + New_Ref := New_Occurrence_Of (Val, Loc); + Old_Ref := Parent (Old_Ref); + end if; + + -- Otherwise the value denotes an arbitrary expression which + -- constraints the discriminant. Replace as follows: + + -- _object.Discr -> Val + + else + pragma Assert (Is_Deriv_Obj_Ref (Old_Ref)); + + New_Ref := New_Copy_Tree (Val); + Old_Ref := Parent (Old_Ref); + end if; + + -- Otherwise the reference denotes a primitive. Replace as + -- follows: + + -- Primitive -> Val + + else + pragma Assert (Nkind (Val) in N_Entity); + New_Ref := New_Occurrence_Of (Val, Loc); + end if; + + -- The reference mentions the _object parameter of the parent + -- type's DIC procedure. Replace as follows: + + -- _object -> _object + + elsif Present (Par_Obj) + and then Present (Deriv_Obj) + and then Ref_Id = Par_Obj + then + New_Ref := New_Occurrence_Of (Deriv_Obj, Loc); + + -- The reference to _object acts as an actual parameter in a + -- subprogram call which may be invoking a primitive of the + -- parent type: + + -- Primitive (... _object ...); + + -- The parent type primitive may not be overridden nor + -- inherited when it is declared after the derived type + -- definition: + + -- type Parent is tagged private; + -- type Child is new Parent with private; + -- procedure Primitive (Obj : Parent); + + -- In this scenario the _object parameter is converted to the + -- parent type. Due to complications with partial/full views + -- and view swaps, the parent type is taken from the formal + -- parameter of the subprogram being called. + + if Nkind_In (Context, N_Function_Call, + N_Procedure_Call_Statement) + and then No (Type_Map.Get (Entity (Name (Context)))) + then + New_Ref := + Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref); + + -- Do not process the generated type conversion because + -- both the parent type and the derived type are in the + -- Type_Map table. This will clobber the type conversion + -- by resetting its subtype mark. + + Result := Skip; + end if; + + -- Otherwise there is nothing to replace + + else + New_Ref := Empty; + end if; + + if Present (New_Ref) then + Rewrite (Old_Ref, New_Ref); + + -- Update the return type when the context of the reference + -- acts as the name of a function call. Note that the update + -- should not be performed when the reference appears as an + -- actual in the call. + + if Nkind (Context) = N_Function_Call + and then Name (Context) = Old_Ref + then + Set_Etype (Context, Etype (Val)); + end if; + end if; + end if; + + -- Reanalyze the reference due to potential replacements + + if Nkind (Old_Ref) in N_Has_Etype then + Set_Analyzed (Old_Ref, False); + end if; + + return Result; + end Replace_Ref; + + procedure Replace_Refs is new Traverse_Proc (Replace_Ref); + + -------------------- + -- Type_Of_Formal -- + -------------------- + + function Type_Of_Formal + (Call : Node_Id; + Actual : Node_Id) return Entity_Id + is + A : Node_Id; + F : Entity_Id; + + begin + -- Examine the list of actual and formal parameters in parallel + + A := First (Parameter_Associations (Call)); + F := First_Formal (Entity (Name (Call))); + while Present (A) and then Present (F) loop + if A = Actual then + return Etype (F); + end if; + + Next (A); + Next_Formal (F); + end loop; + + -- The actual parameter must always have a corresponding formal + + pragma Assert (False); + + return Empty; + end Type_Of_Formal; + + -- Start of processing for Replace_References + + begin + -- Map the attributes of the parent type to the proper corresponding + -- attributes of the derived type. + + Map_Types + (Parent_Type => Par_Typ, + Derived_Type => Deriv_Typ); + + -- Inspect the input expression and perform substitutions where + -- necessary. + + Replace_Refs (Expr); + end Replace_References; + + ----------------------------- + -- Replace_Type_References -- + ----------------------------- + + procedure Replace_Type_References + (Expr : Node_Id; + Typ : Entity_Id; + Obj_Id : Entity_Id) + is + procedure Replace_Type_Ref (N : Node_Id); + -- Substitute a single reference of the current instance of type Typ + -- with a reference to Obj_Id. + + ---------------------- + -- Replace_Type_Ref -- + ---------------------- + + procedure Replace_Type_Ref (N : Node_Id) is + Ref : Node_Id; + + begin + -- Decorate the reference to Typ even though it may be rewritten + -- further down. This is done for two reasons: + + -- * ASIS has all necessary semantic information in the original + -- tree. + + -- * Routines which examine properties of the Original_Node have + -- some semantic information. + + if Nkind (N) = N_Identifier then + Set_Entity (N, Typ); + Set_Etype (N, Typ); + + elsif Nkind (N) = N_Selected_Component then + Analyze (Prefix (N)); + Set_Entity (Selector_Name (N), Typ); + Set_Etype (Selector_Name (N), Typ); + end if; + + -- Perform the following substitution: + + -- Typ -> _object + + Ref := Make_Identifier (Sloc (N), Chars (Obj_Id)); + Set_Entity (Ref, Obj_Id); + Set_Etype (Ref, Typ); + + Rewrite (N, Ref); + + Set_Comes_From_Source (N, True); + end Replace_Type_Ref; + + procedure Replace_Type_Refs is + new Replace_Type_References_Generic (Replace_Type_Ref); + + -- Start of processing for Replace_Type_References + + begin + Replace_Type_Refs (Expr, Typ); + end Replace_Type_References; + --------------------------- -- Represented_As_Scalar -- --------------------------- @@ -10964,6 +11653,15 @@ package body Exp_Util is and then Esize (Left_Typ) = Esize (Result_Typ); end Target_Has_Fixed_Ops; + ------------------- + -- Type_Map_Hash -- + ------------------- + + function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is + begin + return Type_Map_Header (Id mod Type_Map_Size); + end Type_Map_Hash; + ------------------------------------------ -- Type_May_Have_Bit_Aligned_Components -- ------------------------------------------ @@ -11015,163 +11713,11 @@ package body Exp_Util is Subp_Id : Entity_Id) is begin - Update_Primitives_Mapping_Of_Types - (Par_Typ => Find_Dispatching_Type (Inher_Id), - Deriv_Typ => Find_Dispatching_Type (Subp_Id)); + Map_Types + (Parent_Type => Find_Dispatching_Type (Inher_Id), + Derived_Type => Find_Dispatching_Type (Subp_Id)); end Update_Primitives_Mapping; - ---------------------------------------- - -- Update_Primitives_Mapping_Of_Types -- - ---------------------------------------- - - procedure Update_Primitives_Mapping_Of_Types - (Par_Typ : Entity_Id; - Deriv_Typ : Entity_Id) - is - procedure Add_Primitive (Prim : Entity_Id); - -- Find a primitive in the inheritance/overriding chain starting from - -- Prim whose dispatching type is parent type Par_Typ and add a mapping - -- between the result and primitive Prim. - - ------------------- - -- Add_Primitive -- - ------------------- - - procedure Add_Primitive (Prim : Entity_Id) is - function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id; - -- Return the next ancestor primitive in the inheritance/overriding - -- chain of subprogram Subp. Return Empty if no such primitive is - -- available. - - ------------------------ - -- Ancestor_Primitive -- - ------------------------ - - function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is - Inher_Prim : constant Entity_Id := Alias (Subp); - Over_Prim : constant Entity_Id := Overridden_Operation (Subp); - - begin - -- The current subprogram overrides an ancestor primitive - - if Present (Over_Prim) then - return Over_Prim; - - -- The current subprogram is an internally generated alias of an - -- inherited ancestor primitive. - - elsif Present (Inher_Prim) then - return Inher_Prim; - - -- Otherwise the current subprogram is the root of the inheritance - -- or overriding chain. - - else - return Empty; - end if; - end Ancestor_Primitive; - - -- Local variables - - Par_Prim : Entity_Id; - - -- Start of processing for Add_Primitive - - begin - -- Inspect both the inheritance chain through the Alias attribute and - -- the overriding chain through the Overridden_Operation looking for - -- an ancestor primitive with the appropriate dispatching type. - - Par_Prim := Prim; - while Present (Par_Prim) loop - exit when Find_Dispatching_Type (Par_Prim) = Par_Typ; - Par_Prim := Ancestor_Primitive (Par_Prim); - end loop; - - -- Create a mapping of the form: - - -- Parent type primitive -> derived type primitive - - if Present (Par_Prim) then - Primitives_Mapping.Set (Par_Prim, Prim); - end if; - end Add_Primitive; - - -- Local variables - - Deriv_Prim : Entity_Id; - Par_Prim : Entity_Id; - Par_Prims : Elist_Id; - Prim_Elmt : Elmt_Id; - - -- Start of processing for Update_Primitives_Mapping_Of_Types - - begin - -- Nothing to do if there are no types to work with - - if No (Par_Typ) or else No (Deriv_Typ) then - return; - - -- Nothing to do if the mapping already exists - - elsif Primitives_Mapping.Get (Par_Typ) = Deriv_Typ then - return; - end if; - - -- Create a mapping of the form: - - -- Parent type -> Derived type - - -- to prevent any subsequent attempts to produce the same relations. - - Primitives_Mapping.Set (Par_Typ, Deriv_Typ); - - -- Inspect the primitives of the derived type and determine whether they - -- relate to the primitives of the parent type. If there is a meaningful - -- relation, create a mapping of the form: - - -- Parent type primitive -> Derived type primitive - - if Present (Direct_Primitive_Operations (Deriv_Typ)) then - Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ)); - while Present (Prim_Elmt) loop - Deriv_Prim := Node (Prim_Elmt); - - if Is_Subprogram (Deriv_Prim) - and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ - then - Add_Primitive (Deriv_Prim); - end if; - - Next_Elmt (Prim_Elmt); - end loop; - end if; - - -- If the parent operation is an interface operation, the overriding - -- indicator is not present. Instead, we get from the interface - -- operation the primitive of the current type that implements it. - - if Is_Interface (Par_Typ) then - Par_Prims := Collect_Primitive_Operations (Par_Typ); - - if Present (Par_Prims) then - Prim_Elmt := First_Elmt (Par_Prims); - - while Present (Prim_Elmt) loop - Par_Prim := Node (Prim_Elmt); - Deriv_Prim := - Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim); - - if Present (Deriv_Prim) then - Primitives_Mapping.Set (Par_Prim, Deriv_Prim); - end if; - - Next_Elmt (Prim_Elmt); - end loop; - end if; - end if; - end Update_Primitives_Mapping_Of_Types; - ---------------------------------- -- Within_Case_Or_If_Expression -- ---------------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index a6b6b03521a..8e0021748d3 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -278,9 +278,13 @@ package Exp_Util is -- Build a call to the DIC procedure of type Typ with Obj_Id as the actual -- parameter. - procedure Build_DIC_Procedure_Body (Typ : Entity_Id); + procedure Build_DIC_Procedure_Body + (Typ : Entity_Id; + For_Freeze : Boolean := False); -- Create the body of the procedure which verifies the assertion expression - -- of pragma Default_Initial_Condition at run time. + -- of pragma Default_Initial_Condition at run time. Flag For_Freeze should + -- be set when the body is construction as part of the freezing actions for + -- Typ. procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id); -- Create the declaration of the procedure which verifies the assertion @@ -870,6 +874,19 @@ package Exp_Util is -- wide type. Set Related_Id to request an external name for the subtype -- rather than an internal temporary. + procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id); + -- Establish the following mapping between the attributes of tagged parent + -- type Parent_Type and tagged derived type Derived_Type. + -- + -- * Map each discriminant of Parent_Type to ether the corresponding + -- discriminant of Derived_Type or come constraint. + + -- * Map each primitive operation of Parent_Type to the corresponding + -- primitive of Derived_Type. + -- + -- The mapping Parent_Type -> Derived_Type is also added to the table in + -- order to prevent subsequent attempts of the same mapping. + function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id; -- Given a scalar subtype Typ, returns a matching type in standard that -- has the same object size value. For example, a 16 bit signed type will @@ -995,6 +1012,37 @@ package Exp_Util is -- renaming cannot be elaborated without evaluating the subexpression, so -- gigi would resort to method 1) or 3) under the hood for them. + procedure Replace_References + (Expr : Node_Id; + Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id; + Par_Obj : Entity_Id := Empty; + Deriv_Obj : Entity_Id := Empty); + -- Expr denotes an arbitrary expression. Par_Typ is a tagged parent type + -- in a type hierarchy. Deriv_Typ is a tagged type derived from Par_Typ + -- with optional ancestors in between. Par_Obj is a formal parameter + -- which emulates the current instance of Par_Typ. Deriv_Obj is a formal + -- parameter which emulates the current instance of Deriv_Typ. Perform the + -- following substitutions in Expr: + -- + -- * Replace a reference to Par_Obj with a reference to Deriv_Obj + -- + -- * Replace a reference to a discriminant of Par_Typ with a suitable + -- value from the point of view of Deriv_Typ. + -- + -- * Replace a call to an overridden primitive of Par_Typ with a call to + -- an overriding primitive of Deriv_Typ. + -- + -- * Replace a call to an inherited primitive of Par_Type with a call to + -- the internally-generated inherited primitive of Deriv_Typ. + + procedure Replace_Type_References + (Expr : Node_Id; + Typ : Entity_Id; + Obj_Id : Entity_Id); + -- Substitute all references of the current instance of type Typ with + -- references to formal parameter Obj_Id within expression Expr. + function Represented_As_Scalar (T : Entity_Id) return Boolean; -- Returns True iff the implementation of this type in code generation -- terms is scalar. This is true for scalars in the Ada sense, and for @@ -1103,12 +1151,6 @@ package Exp_Util is -- when elaborating a contract for a subprogram, and when freezing a type -- extension to verify legality rules on inherited conditions. - procedure Update_Primitives_Mapping_Of_Types - (Par_Typ : Entity_Id; - Deriv_Typ : Entity_Id); - -- Map the primitive operations of parent type Par_Typ to the corresponding - -- primitives of derived type Deriv_Typ. - function Within_Case_Or_If_Expression (N : Node_Id) return Boolean; -- Determine whether arbitrary node N is within a case or an if expression diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 40ee462906c..21d88d7d0a3 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -10532,10 +10532,33 @@ package body Sem_Attr is if Convention (Designated_Type (Btyp)) /= Convention (Entity (P)) then - Error_Msg_FE - ("subprogram & has wrong convention", P, Entity (P)); - Error_Msg_Sloc := Sloc (Btyp); - Error_Msg_FE ("\does not match & declared#", P, Btyp); + -- The rule in 6.3.1 (8) deserves a special error + -- message. + + if Convention (Btyp) = Convention_Intrinsic + and then Nkind (Parent (N)) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (Parent (N))) + and then Inside_A_Generic + then + declare + Subp : constant Entity_Id := + Entity (Name (Parent (N))); + begin + if Convention (Subp) = Convention_Intrinsic then + Error_Msg_FE ("subprogram and its formal " + & "parameters have convention Intrinsic", + Parent (N), Subp); + Error_Msg_N + ("actual cannot be access attribute", N); + end if; + end; + + else + Error_Msg_FE + ("subprogram & has wrong convention", P, Entity (P)); + Error_Msg_Sloc := Sloc (Btyp); + Error_Msg_FE ("\does not match & declared#", P, Btyp); + end if; if not Is_Itype (Btyp) and then not Has_Convention_Pragma (Btyp) diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index c400fa80fff..e5879dfabb6 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2568,6 +2568,11 @@ package body Sem_Ch7 is Propagate_DIC_Attributes (Full, From_Typ => Full_Base); Propagate_DIC_Attributes (Full_Base, From_Typ => Full); + -- Propagate Default_Initial_Condition-related attributes from the + -- full view to the private view. + + Propagate_DIC_Attributes (Priv, From_Typ => Full); + -- Propagate invariant-related attributes from the base type of the -- full view to the full view and vice versa. This may seem strange, -- but is necessary depending on which type triggered the generation diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 35e1b88a157..47402fb2044 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -13839,6 +13839,7 @@ package body Sem_Prag is Check_No_Identifiers; Check_At_Most_N_Arguments (1); + Typ := Empty; Stmt := Prev (N); while Present (Stmt) loop @@ -13880,6 +13881,14 @@ package body Sem_Prag is Stmt := Prev (Stmt); end loop; + -- The pragma does not apply to a legal construct, issue an error + -- and stop the analysis. + + if No (Typ) then + Pragma_Misplaced; + return; + end if; + -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code.