| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ A T A G -- |
| -- -- |
| -- S p e c -- |
| -- -- |
| -- Copyright (C) 2006-2008, 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- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Einfo; use Einfo; |
| with Elists; use Elists; |
| with Exp_Util; use Exp_Util; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Rtsfind; use Rtsfind; |
| with Sinfo; use Sinfo; |
| with Sem_Util; use Sem_Util; |
| with Stand; use Stand; |
| with Snames; use Snames; |
| with Tbuild; use Tbuild; |
| |
| package body Exp_Atag is |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| function Build_DT |
| (Loc : Source_Ptr; |
| Tag_Node : Node_Id) return Node_Id; |
| -- Build code that displaces the Tag to reference the base of the wrapper |
| -- record |
| -- |
| -- Generates: |
| -- To_Dispatch_Table_Ptr |
| -- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position); |
| |
| function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id; |
| -- Build code that retrieves the address of the record containing the Type |
| -- Specific Data generated by GNAT. |
| -- |
| -- Generate: To_Type_Specific_Data_Ptr |
| -- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all); |
| |
| ------------------------------------------------ |
| -- Build_Common_Dispatching_Select_Statements -- |
| ------------------------------------------------ |
| |
| procedure Build_Common_Dispatching_Select_Statements |
| (Loc : Source_Ptr; |
| DT_Ptr : Entity_Id; |
| Stmts : List_Id) |
| is |
| begin |
| -- Generate: |
| -- C := get_prim_op_kind (tag! (<type>VP), S); |
| |
| -- where C is the out parameter capturing the call kind and S is the |
| -- dispatch table slot number. |
| |
| Append_To (Stmts, |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Identifier (Loc, Name_uC), |
| Expression => |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To (DT_Ptr, Loc)), |
| Make_Identifier (Loc, Name_uS))))); |
| |
| -- Generate: |
| |
| -- if C = POK_Procedure |
| -- or else C = POK_Protected_Procedure |
| -- or else C = POK_Task_Procedure; |
| -- then |
| -- F := True; |
| -- return; |
| |
| -- where F is the out parameter capturing the status of a potential |
| -- entry call. |
| |
| Append_To (Stmts, |
| Make_If_Statement (Loc, |
| |
| Condition => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Identifier (Loc, Name_uC), |
| Right_Opnd => |
| New_Reference_To (RTE (RE_POK_Procedure), Loc)), |
| Right_Opnd => |
| Make_Or_Else (Loc, |
| Left_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Identifier (Loc, Name_uC), |
| Right_Opnd => |
| New_Reference_To (RTE ( |
| RE_POK_Protected_Procedure), Loc)), |
| Right_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Identifier (Loc, Name_uC), |
| Right_Opnd => |
| New_Reference_To (RTE ( |
| RE_POK_Task_Procedure), Loc)))), |
| |
| Then_Statements => |
| New_List ( |
| Make_Assignment_Statement (Loc, |
| Name => Make_Identifier (Loc, Name_uF), |
| Expression => New_Reference_To (Standard_True, Loc)), |
| Make_Simple_Return_Statement (Loc)))); |
| end Build_Common_Dispatching_Select_Statements; |
| |
| ------------------------- |
| -- Build_CW_Membership -- |
| ------------------------- |
| |
| function Build_CW_Membership |
| (Loc : Source_Ptr; |
| Obj_Tag_Node : Node_Id; |
| Typ_Tag_Node : Node_Id) return Node_Id |
| is |
| function Build_Pos return Node_Id; |
| -- Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth; |
| |
| function Build_Pos return Node_Id is |
| begin |
| return |
| Make_Op_Subtract (Loc, |
| Left_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)), |
| Selector_Name => |
| New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)), |
| |
| Right_Opnd => |
| Make_Selected_Component (Loc, |
| Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)), |
| Selector_Name => |
| New_Reference_To (RTE_Record_Component (RE_Idepth), Loc))); |
| end Build_Pos; |
| |
| -- Start of processing for Build_CW_Membership |
| |
| begin |
| return |
| Make_And_Then (Loc, |
| Left_Opnd => |
| Make_Op_Ge (Loc, |
| Left_Opnd => Build_Pos, |
| Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), |
| |
| Right_Opnd => |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Make_Indexed_Component (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => Build_TSD (Loc, Obj_Tag_Node), |
| Selector_Name => |
| New_Reference_To |
| (RTE_Record_Component (RE_Tags_Table), Loc)), |
| Expressions => |
| New_List (Build_Pos)), |
| |
| Right_Opnd => Typ_Tag_Node)); |
| end Build_CW_Membership; |
| |
| -------------- |
| -- Build_DT -- |
| -------------- |
| |
| function Build_DT |
| (Loc : Source_Ptr; |
| Tag_Node : Node_Id) return Node_Id is |
| begin |
| return |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (RTE (RE_DT), Loc), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Tag), Tag_Node))); |
| end Build_DT; |
| |
| ---------------------------- |
| -- Build_Get_Access_Level -- |
| ---------------------------- |
| |
| function Build_Get_Access_Level |
| (Loc : Source_Ptr; |
| Tag_Node : Node_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Selected_Component (Loc, |
| Prefix => Build_TSD (Loc, Tag_Node), |
| Selector_Name => |
| New_Reference_To |
| (RTE_Record_Component (RE_Access_Level), Loc)); |
| end Build_Get_Access_Level; |
| |
| ------------------------------------------ |
| -- Build_Get_Predefined_Prim_Op_Address -- |
| ------------------------------------------ |
| |
| function Build_Get_Predefined_Prim_Op_Address |
| (Loc : Source_Ptr; |
| Tag_Node : Node_Id; |
| Position : Uint) return Node_Id |
| is |
| begin |
| -- Build code that retrieves the address of the dispatch table |
| -- containing the predefined Ada primitives: |
| -- |
| -- Generate: |
| -- To_Predef_Prims_Table_Ptr |
| -- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all); |
| |
| return |
| Make_Indexed_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Addr_Ptr), |
| Make_Function_Call (Loc, |
| Name => |
| Make_Expanded_Name (Loc, |
| Chars => Name_Op_Subtract, |
| Prefix => |
| New_Reference_To |
| (RTU_Entity (System_Storage_Elements), Loc), |
| Selector_Name => |
| Make_Identifier (Loc, |
| Chars => Name_Op_Subtract)), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), Tag_Node), |
| New_Reference_To (RTE (RE_DT_Predef_Prims_Offset), |
| Loc)))))), |
| Expressions => |
| New_List (Make_Integer_Literal (Loc, Position))); |
| end Build_Get_Predefined_Prim_Op_Address; |
| |
| ------------------------- |
| -- Build_Inherit_Prims -- |
| ------------------------- |
| |
| function Build_Inherit_Prims |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Old_Tag_Node : Node_Id; |
| New_Tag_Node : Node_Id; |
| Num_Prims : Nat) return Node_Id |
| is |
| begin |
| if RTE_Available (RE_DT) then |
| return |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Slice (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Build_DT (Loc, New_Tag_Node), |
| Selector_Name => |
| New_Reference_To |
| (RTE_Record_Component (RE_Prims_Ptr), Loc)), |
| Discrete_Range => |
| Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, 1), |
| High_Bound => Make_Integer_Literal (Loc, Num_Prims))), |
| |
| Expression => |
| Make_Slice (Loc, |
| Prefix => |
| Make_Selected_Component (Loc, |
| Prefix => |
| Build_DT (Loc, Old_Tag_Node), |
| Selector_Name => |
| New_Reference_To |
| (RTE_Record_Component (RE_Prims_Ptr), Loc)), |
| Discrete_Range => |
| Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, 1), |
| High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); |
| else |
| return |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Slice (Loc, |
| Prefix => |
| Unchecked_Convert_To |
| (Node (Last_Elmt (Access_Disp_Table (Typ))), |
| New_Tag_Node), |
| Discrete_Range => |
| Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, 1), |
| High_Bound => Make_Integer_Literal (Loc, Num_Prims))), |
| |
| Expression => |
| Make_Slice (Loc, |
| Prefix => |
| Unchecked_Convert_To |
| (Node (Last_Elmt (Access_Disp_Table (Typ))), |
| Old_Tag_Node), |
| Discrete_Range => |
| Make_Range (Loc, |
| Low_Bound => Make_Integer_Literal (Loc, 1), |
| High_Bound => Make_Integer_Literal (Loc, Num_Prims)))); |
| end if; |
| end Build_Inherit_Prims; |
| |
| ------------------------------- |
| -- Build_Get_Prim_Op_Address -- |
| ------------------------------- |
| |
| function Build_Get_Prim_Op_Address |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Tag_Node : Node_Id; |
| Position : Uint) return Node_Id |
| is |
| begin |
| pragma Assert |
| (Position <= DT_Entry_Count (First_Tag_Component (Typ))); |
| |
| -- At the end of the Access_Disp_Table list we have the type |
| -- declaration required to convert the tag into a pointer to |
| -- the prims_ptr table (see Freeze_Record_Type). |
| |
| return |
| Make_Indexed_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To |
| (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node), |
| Expressions => New_List (Make_Integer_Literal (Loc, Position))); |
| end Build_Get_Prim_Op_Address; |
| |
| ----------------------------- |
| -- Build_Get_Transportable -- |
| ----------------------------- |
| |
| function Build_Get_Transportable |
| (Loc : Source_Ptr; |
| Tag_Node : Node_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Selected_Component (Loc, |
| Prefix => Build_TSD (Loc, Tag_Node), |
| Selector_Name => |
| New_Reference_To |
| (RTE_Record_Component (RE_Transportable), Loc)); |
| end Build_Get_Transportable; |
| |
| ------------------------------------ |
| -- Build_Inherit_Predefined_Prims -- |
| ------------------------------------ |
| |
| function Build_Inherit_Predefined_Prims |
| (Loc : Source_Ptr; |
| Old_Tag_Node : Node_Id; |
| New_Tag_Node : Node_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Slice (Loc, |
| Prefix => |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Addr_Ptr), |
| New_Tag_Node)))), |
| Discrete_Range => Make_Range (Loc, |
| Make_Integer_Literal (Loc, Uint_1), |
| New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))), |
| |
| Expression => |
| Make_Slice (Loc, |
| Prefix => |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Addr_Ptr), |
| Old_Tag_Node)))), |
| Discrete_Range => |
| Make_Range (Loc, |
| Make_Integer_Literal (Loc, 1), |
| New_Reference_To (RTE (RE_Max_Predef_Prims), Loc)))); |
| end Build_Inherit_Predefined_Prims; |
| |
| ------------------------- |
| -- Build_Offset_To_Top -- |
| ------------------------- |
| |
| function Build_Offset_To_Top |
| (Loc : Source_Ptr; |
| This_Node : Node_Id) return Node_Id |
| is |
| Tag_Node : Node_Id; |
| |
| begin |
| Tag_Node := |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node)); |
| |
| return |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), |
| Make_Function_Call (Loc, |
| Name => |
| Make_Expanded_Name (Loc, |
| Chars => Name_Op_Subtract, |
| Prefix => New_Reference_To |
| (RTU_Entity (System_Storage_Elements), Loc), |
| Selector_Name => Make_Identifier (Loc, |
| Chars => Name_Op_Subtract)), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), Tag_Node), |
| New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset), |
| Loc))))); |
| end Build_Offset_To_Top; |
| |
| ------------------------------------------ |
| -- Build_Set_Predefined_Prim_Op_Address -- |
| ------------------------------------------ |
| |
| function Build_Set_Predefined_Prim_Op_Address |
| (Loc : Source_Ptr; |
| Tag_Node : Node_Id; |
| Position : Uint; |
| Address_Node : Node_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Indexed_Component (Loc, |
| Prefix => |
| Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Addr_Ptr), Tag_Node))), |
| Expressions => |
| New_List (Make_Integer_Literal (Loc, Position))), |
| |
| Expression => Address_Node); |
| end Build_Set_Predefined_Prim_Op_Address; |
| |
| ------------------------------- |
| -- Build_Set_Prim_Op_Address -- |
| ------------------------------- |
| |
| function Build_Set_Prim_Op_Address |
| (Loc : Source_Ptr; |
| Typ : Entity_Id; |
| Tag_Node : Node_Id; |
| Position : Uint; |
| Address_Node : Node_Id) return Node_Id |
| is |
| begin |
| return |
| Make_Assignment_Statement (Loc, |
| Name => Build_Get_Prim_Op_Address |
| (Loc, Typ, Tag_Node, Position), |
| Expression => Address_Node); |
| end Build_Set_Prim_Op_Address; |
| |
| ----------------------------- |
| -- Build_Set_Size_Function -- |
| ----------------------------- |
| |
| function Build_Set_Size_Function |
| (Loc : Source_Ptr; |
| Tag_Node : Node_Id; |
| Size_Func : Entity_Id) return Node_Id is |
| begin |
| pragma Assert (Chars (Size_Func) = Name_uSize |
| and then RTE_Record_Component_Available (RE_Size_Func)); |
| return |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => Build_TSD (Loc, Tag_Node), |
| Selector_Name => |
| New_Reference_To |
| (RTE_Record_Component (RE_Size_Func), Loc)), |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Size_Ptr), |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Size_Func, Loc), |
| Attribute_Name => Name_Unrestricted_Access))); |
| end Build_Set_Size_Function; |
| |
| ------------------------------------ |
| -- Build_Set_Static_Offset_To_Top -- |
| ------------------------------------ |
| |
| function Build_Set_Static_Offset_To_Top |
| (Loc : Source_Ptr; |
| Iface_Tag : Node_Id; |
| Offset_Value : Node_Id) return Node_Id is |
| begin |
| return |
| Make_Assignment_Statement (Loc, |
| Make_Explicit_Dereference (Loc, |
| Unchecked_Convert_To (RTE (RE_Offset_To_Top_Ptr), |
| Make_Function_Call (Loc, |
| Name => |
| Make_Expanded_Name (Loc, |
| Chars => Name_Op_Subtract, |
| Prefix => New_Reference_To |
| (RTU_Entity (System_Storage_Elements), Loc), |
| Selector_Name => Make_Identifier (Loc, |
| Chars => Name_Op_Subtract)), |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), Iface_Tag), |
| New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset), |
| Loc))))), |
| Offset_Value); |
| end Build_Set_Static_Offset_To_Top; |
| |
| --------------- |
| -- Build_TSD -- |
| --------------- |
| |
| function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is |
| begin |
| return |
| Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr), |
| Make_Explicit_Dereference (Loc, |
| Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr), |
| Make_Function_Call (Loc, |
| Name => |
| Make_Expanded_Name (Loc, |
| Chars => Name_Op_Subtract, |
| Prefix => |
| New_Reference_To |
| (RTU_Entity (System_Storage_Elements), Loc), |
| Selector_Name => |
| Make_Identifier (Loc, |
| Chars => Name_Op_Subtract)), |
| |
| Parameter_Associations => New_List ( |
| Unchecked_Convert_To (RTE (RE_Address), Tag_Node), |
| New_Reference_To |
| (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))))); |
| end Build_TSD; |
| |
| end Exp_Atag; |
