diff options
Diffstat (limited to 'translate/grt/grt-rtis_addr.adb')
| -rw-r--r-- | translate/grt/grt-rtis_addr.adb | 299 |
1 files changed, 0 insertions, 299 deletions
diff --git a/translate/grt/grt-rtis_addr.adb b/translate/grt/grt-rtis_addr.adb deleted file mode 100644 index 70a0e21..0000000 --- a/translate/grt/grt-rtis_addr.adb +++ /dev/null @@ -1,299 +0,0 @@ --- GHDL Run Time (GRT) - RTI address handling. --- Copyright (C) 2002 - 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT 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 --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. --- --- As a special exception, if other files instantiate generics from this --- unit, or you link this unit with other files to produce an executable, --- this unit does not by itself cause the resulting executable to be --- covered by the GNU General Public License. This exception does not --- however invalidate any other reasons why the executable file might be --- covered by the GNU Public License. -with Grt.Errors; use Grt.Errors; - -package body Grt.Rtis_Addr is - function "+" (L : Address; R : Ghdl_Rti_Loc) return Address - is - begin - return To_Address (To_Integer (L) + R); - end "+"; - - function "+" (L : Address; R : Ghdl_Index_Type) return Address - is - begin - return To_Address (To_Integer (L) + Integer_Address (R)); - end "+"; - - function "-" (L : Address; R : Ghdl_Rti_Loc) return Address - is - begin - return To_Address (To_Integer (L) - R); - end "-"; - - function Align (L : Address; R : Ghdl_Rti_Loc) return Address - is - Nad : Integer_Address; - begin - Nad := To_Integer (L + (R - 1)); - return To_Address (Nad - (Nad mod R)); - end Align; - - function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context - is - Blk : Ghdl_Rtin_Block_Acc; - begin - Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); - case Ctxt.Block.Kind is - when Ghdl_Rtik_Process - | Ghdl_Rtik_Block => - return (Base => Ctxt.Base - Blk.Loc, - Block => Blk.Parent); - when Ghdl_Rtik_Architecture => - if Blk.Loc /= Null_Rti_Loc then - Internal_Error ("get_parent_context(3)"); - end if; - return (Base => Ctxt.Base + Blk.Loc, - Block => Blk.Parent); - when Ghdl_Rtik_For_Generate - | Ghdl_Rtik_If_Generate => - declare - Nbase : Address; - Parent : Ghdl_Rti_Access; - Blk1 : Ghdl_Rtin_Block_Acc; - begin - -- Read the pointer to the parent. - -- This is the first field. - Nbase := To_Addr_Acc (Ctxt.Base).all; - -- Since the parent may be a grant-parent, adjust - -- the base. - Parent := Blk.Parent; - loop - case Parent.Kind is - when Ghdl_Rtik_Architecture - | Ghdl_Rtik_For_Generate - | Ghdl_Rtik_If_Generate => - exit; - when Ghdl_Rtik_Block => - Blk1 := To_Ghdl_Rtin_Block_Acc (Parent); - Nbase := Nbase + Blk1.Loc; - Parent := Blk1.Parent; - when others => - Internal_Error ("get_parent_context(2)"); - end case; - end loop; - return (Base => Nbase, - Block => Blk.Parent); - end; - when others => - Internal_Error ("get_parent_context(1)"); - end case; - end Get_Parent_Context; - - procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc; - Ctxt : out Rti_Context; - Stmt : out Ghdl_Rti_Access) - is - Obj : Ghdl_Rtin_Instance_Acc; - begin - if Link.Parent = null then - -- Top entity. - Stmt := null; - Ctxt := (Base => Null_Address, Block => null); - else - Stmt := Link.Parent.Stmt; - Obj := To_Ghdl_Rtin_Instance_Acc (Stmt); - Ctxt := (Base => Link.Parent.all'Address - Obj.Loc, - Block => Obj.Parent); - end if; - end Get_Instance_Link; - - function Loc_To_Addr (Depth : Ghdl_Rti_Depth; - Loc : Ghdl_Rti_Loc; - Ctxt : Rti_Context) - return Address - is - Cur_Ctxt : Rti_Context; - Nctxt : Rti_Context; - begin - if Depth = 0 then - return To_Address (Loc); - elsif Ctxt.Block.Depth = Depth then - --Addr := Base + Storage_Offset (Obj.Loc.Off); - return Ctxt.Base + Loc; - else - if Ctxt.Block.Depth < Depth then - Internal_Error ("loc_to_addr"); - end if; - Cur_Ctxt := Ctxt; - loop - Nctxt := Get_Parent_Context (Cur_Ctxt); - if Nctxt.Block.Depth = Depth then - return Nctxt.Base + Loc; - end if; - Cur_Ctxt := Nctxt; - end loop; - end if; - end Loc_To_Addr; - - function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access) - return Ghdl_Index_Type - is - begin - case Base_Type.Kind is - when Ghdl_Rtik_Type_B1 => - return Rng.B1.Len; - when Ghdl_Rtik_Type_E8 => - return Rng.E8.Len; - when Ghdl_Rtik_Type_E32 => - return Rng.E32.Len; - when Ghdl_Rtik_Type_I32 => - return Rng.I32.Len; - when others => - Internal_Error ("range_to_length"); - end case; - end Range_To_Length; - - function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc; - Ctxt : Rti_Context) - return Ghdl_Index_Type - is - Iter_Type : Ghdl_Rtin_Subtype_Scalar_Acc; - Rng : Ghdl_Range_Ptr; - begin - Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc - (To_Ghdl_Rtin_Object_Acc (Blk.Children (0)).Obj_Type); - if Iter_Type.Common.Kind /= Ghdl_Rtik_Subtype_Scalar then - Internal_Error ("get_for_generate_length(1)"); - end if; - Rng := To_Ghdl_Range_Ptr - (Loc_To_Addr (Iter_Type.Common.Depth, Iter_Type.Range_Loc, Ctxt)); - return Range_To_Length (Rng, Iter_Type.Basetype); - end Get_For_Generate_Length; - - procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc; - Ctxt : Rti_Context; - Sub_Ctxt : out Rti_Context) - is - Inst_Addr : Address; - Inst_Base : Address; - begin - -- Address of the field containing the address of the instance. - Inst_Addr := Ctxt.Base + Inst.Loc; - -- Read sub instance address. - Inst_Base := To_Addr_Acc (Inst_Addr).all; - -- Read instance RTI. - if Inst_Base = Null_Address then - Sub_Ctxt := (Base => Null_Address, Block => null); - else - Sub_Ctxt := (Base => Inst_Base, - Block => To_Ghdl_Rti_Acc_Acc (Inst_Base).all); - end if; - end Get_Instance_Context; - - procedure Bound_To_Range (Bounds_Addr : Address; - Def : Ghdl_Rtin_Type_Array_Acc; - Res : out Ghdl_Range_Array) - is - Bounds : Address; - - procedure Align (A : Ghdl_Index_Type) is - begin - Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); - end Align; - - procedure Update (S : Ghdl_Index_Type) is - begin - Bounds := Bounds + (S / Storage_Unit); - end Update; - - Idx_Def : Ghdl_Rti_Access; - begin - if Res'Length /= Def.Nbr_Dim or else Res'First /= 0 then - Internal_Error ("disp_rti.bound_to_range"); - end if; - - Bounds := Bounds_Addr; - - for I in 0 .. Def.Nbr_Dim - 1 loop - Idx_Def := Def.Indexes (I); - - if Bounds = Null_Address then - Res (I) := null; - else - Idx_Def := Get_Base_Type (Idx_Def); - case Idx_Def.Kind is - when Ghdl_Rtik_Type_I32 => - Align (Ghdl_Range_I32'Alignment); - Res (I) := To_Ghdl_Range_Ptr (Bounds); - Update (Ghdl_Range_I32'Size); - when Ghdl_Rtik_Type_E8 => - Align (Ghdl_Range_E8'Alignment); - Res (I) := To_Ghdl_Range_Ptr (Bounds); - Update (Ghdl_Range_E8'Size); - when Ghdl_Rtik_Type_E32 => - Align (Ghdl_Range_E32'Alignment); - Res (I) := To_Ghdl_Range_Ptr (Bounds); - Update (Ghdl_Range_E32'Size); - when others => - -- Bounds are not known anymore. - Bounds := Null_Address; - end case; - end if; - end loop; - end Bound_To_Range; - - function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access - is - begin - case Atype.Kind is - when Ghdl_Rtik_Subtype_Scalar => - return To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype; - when Ghdl_Rtik_Subtype_Array => - return To_Ghdl_Rti_Access - (To_Ghdl_Rtin_Subtype_Array_Acc (Atype).Basetype); - when Ghdl_Rtik_Type_E8 - | Ghdl_Rtik_Type_E32 - | Ghdl_Rtik_Type_B1 => - return Atype; - when others => - Internal_Error ("rtis_addr.get_base_type"); - end case; - end Get_Base_Type; - - function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean - is - begin - return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask) - = Ghdl_Rti_Type_Complex; - end Rti_Complex_Type; - - function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean - is - begin - return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask) - = Ghdl_Rti_Type_Anonymous; - end Rti_Anonymous_Type; - - function Get_Top_Context return Rti_Context - is - Ctxt : Rti_Context; - begin - Ctxt := (Base => Ghdl_Rti_Top_Instance, - Block => Ghdl_Rti_Top.Parent); - return Ctxt; - end Get_Top_Context; - -end Grt.Rtis_Addr; |