First import from sources

1 files changed, 268 insertions, 0 deletions

diff --git a/translate/grt/grt-rtis_addr.adb b/translate/grt/grt-rtis_addr.adb
new file mode 100644
index 000000000..4f24fe776
--- /dev/null
+++ b/translate/grt/grt-rtis_addr.adb
@@ -0,0 +1,268 @@
+--  GHDL Run Time (GRT) -  RTI address handling.
+--  Copyright (C) 2002, 2003, 2004, 2005 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.
+with Ada.Unchecked_Conversion;
+with Grt.Errors; use Grt.Errors;
+
+package body Grt.Rtis_Addr is
+   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_Index_Type) return Address
+   is
+   begin
+      return To_Address (To_Integer (L) - Integer_Address (R));
+   end "-";
+
+   function Align (L : Address; R : Ghdl_Index_Type) return Address
+   is
+      Nad : Integer_Address;
+   begin
+      Nad := To_Integer (L + (R - 1));
+      return To_Address (Nad - (Nad mod Integer_Address (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.Off,
+                    Block => Blk.Parent);
+         when Ghdl_Rtik_Architecture =>
+            if Blk.Loc.Off /= 0 then
+               Internal_Error ("get_parent_context(3)");
+            end if;
+            return (Base => Ctxt.Base + Blk.Loc.Off,
+                    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.Off;
+                        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.Off,
+                  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 Loc.Addr;
+      elsif Ctxt.Block.Depth = Depth then
+         --Addr := Base + Storage_Offset (Obj.Loc.Off);
+         return Ctxt.Base + Loc.Off;
+      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.Off;
+            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_B2 =>
+            return Rng.B2.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.Off;
+      --  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, 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 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_B2 =>
+            return Atype;
+         when others =>
+            Internal_Error ("rtis_addr.get_base_type");
+      end case;
+   end Get_Base_Type;
+
+   function Get_Top_Context return Rti_Context
+   is
+      Ctxt : Rti_Context;
+   begin
+      Ctxt := (Base => To_Address (Ghdl_Rti_Top_Instance),
+               Block => Ghdl_Rti_Top_Ptr.Parent);
+      return Ctxt;
+   end Get_Top_Context;
+
+end Grt.Rtis_Addr;