-- 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 => "=");
-----------------------
-- 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)));
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;
-- 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;
-- 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 --
-------------------
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);
-- 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.
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.
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);
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
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);
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 <Work_Typ>DIC (_object : <Work_Typ>) is
- -- begin
- -- <Stmts>
- -- end <Work_Typ>DIC;
+ if No (Stmts) then
+ Stmts := New_List (Make_Null_Statement (Loc));
+ end if;
+
+ -- Generate:
+ -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
+ -- begin
+ -- <Stmts>
+ -- end <Work_Typ>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;
<<Leave>>
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 --
--------------------
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
+ -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> 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 => <expression>) 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
+ -- <or>
+ -- 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
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 --
---------------------------
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 --
------------------------------------------
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 --
----------------------------------
projects / gcc.git / commitdiff