diff options
Diffstat (limited to 'src/translate/grt/grt-avhpi.adb')
| -rw-r--r-- | src/translate/grt/grt-avhpi.adb | 1142 |
1 files changed, 1142 insertions, 0 deletions
diff --git a/src/translate/grt/grt-avhpi.adb b/src/translate/grt/grt-avhpi.adb new file mode 100644 index 0000000..b935fd9 --- /dev/null +++ b/src/translate/grt/grt-avhpi.adb @@ -0,0 +1,1142 @@ +-- GHDL Run Time (GRT) - VHPI implementation for Ada. +-- 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; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; + +package body Grt.Avhpi is + procedure Get_Root_Inst (Res : out VhpiHandleT) + is + begin + Res := (Kind => VhpiRootInstK, + Ctxt => Get_Top_Context); + end Get_Root_Inst; + + procedure Get_Package_Inst (Res : out VhpiHandleT) is + begin + Res := (Kind => VhpiIteratorK, + Ctxt => (Base => Null_Address, + Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top'Address)), + Rel => VhpiPackInsts, + It_Cur => 0, + It2 => 0, + Max2 => 0); + end Get_Package_Inst; + + -- Number of elements in an array. + function Ranges_To_Length (Rngs : Ghdl_Range_Array; + Indexes : Ghdl_Rti_Arr_Acc) + return Ghdl_Index_Type + is + Res : Ghdl_Index_Type; + begin + Res := 1; + for I in Rngs'Range loop + Res := Res * Range_To_Length + (Rngs (I), Get_Base_Type (Indexes (I - Rngs'First))); + end loop; + return Res; + end Ranges_To_Length; + + procedure Vhpi_Iterator (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default value in case of success. + Res := (Kind => VhpiIteratorK, + Ctxt => Ref.Ctxt, + Rel => Rel, + It_Cur => 0, + It2 => 0, + Max2 => 0); + Error := AvhpiErrorOk; + + case Rel is + when VhpiInternalRegions => + case Ref.Kind is + when VhpiRootInstK + | VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK => + return; + when VhpiForGenerateK => + Res.It2 := 1; + return; + when VhpiCompInstStmtK => + Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); + return; + when others => + null; + end case; + when VhpiDecls => + case Ref.Kind is + when VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK => + return; + when VhpiRootInstK + | VhpiPackInstK => + Res.It2 := 1; + return; + when VhpiCompInstStmtK => + Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); + Res.It2 := 1; + return; + when others => + null; + end case; + when VhpiIndexedNames => + case Ref.Kind is + when VhpiGenericDeclK => + Res := (Kind => AvhpiNameIteratorK, + Ctxt => Ref.Ctxt, + N_Addr => Avhpi_Get_Address (Ref), + N_Type => Ref.Obj.Obj_Type, + N_Idx => 0, + N_Obj => Ref.Obj); + when VhpiIndexedNameK => + Res := (Kind => AvhpiNameIteratorK, + Ctxt => Ref.Ctxt, + N_Addr => Ref.N_Addr, + N_Type => Ref.N_Type, + N_Idx => 0, + N_Obj => Ref.N_Obj); + when others => + Error := AvhpiErrorNotImplemented; + return; + end case; + case Res.N_Type.Kind is + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Res.N_Type); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Res.Ctxt), + Bt, Rngs); + Res.N_Idx := Ranges_To_Length (Rngs, Bt.Indexes); + end; + when others => + Error := AvhpiErrorBadRel; + end case; + return; + when others => + null; + end case; + -- Failure. + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end Vhpi_Iterator; + + -- OBJ_RTI is the RTI for the base name. + function Add_Index (Ctxt : Rti_Context; + Obj_Base : Address; + Obj_Rti : Ghdl_Rtin_Object_Acc; + El_Type : Ghdl_Rti_Access; + Off : Ghdl_Index_Type) return Address + is + pragma Unreferenced (Ctxt); + Is_Sig : Boolean; + El_Size : Ghdl_Index_Type; + El_Type1 : Ghdl_Rti_Access; + begin + case Obj_Rti.Common.Kind is + when Ghdl_Rtik_Generic => + Is_Sig := False; + when others => + Internal_Error ("add_index"); + end case; + + if El_Type.Kind = Ghdl_Rtik_Subtype_Scalar then + El_Type1 := Get_Base_Type (El_Type); + else + El_Type1 := El_Type; + end if; + + case El_Type1.Kind is + when Ghdl_Rtik_Type_P64 => + if Is_Sig then + El_Size := Address'Size / Storage_Unit; + else + El_Size := Ghdl_I64'Size / Storage_Unit; + end if; + when Ghdl_Rtik_Subtype_Array => + if Is_Sig then + El_Size := Ghdl_Index_Type + (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Sigsize); + else + El_Size := Ghdl_Index_Type + (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Valsize); + end if; + when others => + Internal_Error ("add_index"); + end case; + return Obj_Base + Off * El_Size; + end Add_Index; + + procedure Vhpi_Scan_Indexed_Name (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + El_Type : Ghdl_Rti_Access; + begin + if Iterator.N_Idx = 0 then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + El_Type := To_Ghdl_Rtin_Type_Array_Acc + (Get_Base_Type (Iterator.N_Type)).Element; + + Res := (Kind => VhpiIndexedNameK, + Ctxt => Iterator.Ctxt, + N_Addr => Iterator.N_Addr, + N_Type => El_Type, + N_Idx => 0, + N_Obj => Iterator.N_Obj); + + -- Increment Address. + Iterator.N_Addr := Add_Index + (Iterator.Ctxt, Iterator.N_Addr, Iterator.N_Obj, El_Type, 1); + + Iterator.N_Idx := Iterator.N_Idx - 1; + Error := AvhpiErrorOk; + end Vhpi_Scan_Indexed_Name; + + procedure Vhpi_Scan_Internal_Regions (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + Blk : Ghdl_Rtin_Block_Acc; + Ch : Ghdl_Rti_Access; + Nblk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + if Blk = null then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + loop + << Again >> null; + if Iterator.It_Cur >= Blk.Nbr_Child then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + Ch := Blk.Children (Iterator.It_Cur); + Nblk := To_Ghdl_Rtin_Block_Acc (Ch); + + if Iterator.Max2 /= 0 then + -- A for generate. + Iterator.It2 := Iterator.It2 + 1; + if Iterator.It2 >= Iterator.Max2 then + -- End of loop. + Iterator.Max2 := 0; + Iterator.It_Cur := Iterator.It_Cur + 1; + goto Again; + else + declare + Base : Address; + begin + Base := To_Addr_Acc (Iterator.Ctxt.Base + Nblk.Loc).all; + Base := Base + Iterator.It2 * Nblk.Size; + Res := (Kind => VhpiForGenerateK, + Ctxt => (Base => Base, + Block => Ch)); + + Error := AvhpiErrorOk; + return; + end; + end if; + end if; + + + Iterator.It_Cur := Iterator.It_Cur + 1; + + case Ch.Kind is + when Ghdl_Rtik_Process => + Res := (Kind => VhpiProcessStmtK, + Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc, + Block => Ch)); + Error := AvhpiErrorOk; + return; + when Ghdl_Rtik_Block => + Res := (Kind => VhpiBlockStmtK, + Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc, + Block => Ch)); + Error := AvhpiErrorOk; + return; + when Ghdl_Rtik_If_Generate => + Res := (Kind => VhpiIfGenerateK, + Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base + + Nblk.Loc).all, + Block => Ch)); + -- Return only if the condition is true. + if Res.Ctxt.Base /= Null_Address then + Error := AvhpiErrorOk; + return; + end if; + when Ghdl_Rtik_For_Generate => + Res := (Kind => VhpiForGenerateK, + Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base + + Nblk.Loc).all, + Block => Ch)); + Iterator.Max2 := Get_For_Generate_Length (Nblk, Iterator.Ctxt); + Iterator.It2 := 0; + if Iterator.Max2 > 0 then + Iterator.It_Cur := Iterator.It_Cur - 1; + Error := AvhpiErrorOk; + return; + end if; + -- If the iterator range is nul, then continue to scan. + when Ghdl_Rtik_Instance => + Res := (Kind => VhpiCompInstStmtK, + Ctxt => Iterator.Ctxt, + Inst => To_Ghdl_Rtin_Instance_Acc (Ch)); + Error := AvhpiErrorOk; + return; + when others => + -- Next one. + null; + end case; + end loop; + end Vhpi_Scan_Internal_Regions; + + procedure Rti_To_Handle (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Res : out VhpiHandleT) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Signal => + Res := (Kind => VhpiSigDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Port => + Res := (Kind => VhpiPortDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Generic => + Res := (Kind => VhpiGenericDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Subtype_Array => + declare + Atype : Ghdl_Rtin_Subtype_Array_Acc; + Bt : Ghdl_Rtin_Type_Array_Acc; + begin + Atype := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt := Atype.Basetype; + if Atype.Name = Bt.Name then + Res := (Kind => VhpiArrayTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + else + Res := (Kind => VhpiSubtypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + end if; + end; + when Ghdl_Rtik_Type_Array => + Res := (Kind => VhpiArrayTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Res := (Kind => VhpiEnumTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + Res := (Kind => VhpiPhysTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Subtype_Scalar => + Res := (Kind => VhpiSubtypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when others => + Res := (Kind => VhpiUndefined, + Ctxt => Ctxt); + end case; + end Rti_To_Handle; + + procedure Vhpi_Scan_Decls (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + Blk : Ghdl_Rtin_Block_Acc; + Ch : Ghdl_Rti_Access; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + + -- If there is no context, returns now. + -- This may happen for a unbound compinststmt. + if Blk = null then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + if Iterator.It2 = 1 then + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + -- Iterate on the entity. + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + when Ghdl_Rtik_Package_Body => + -- Iterate on the package. + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + when Ghdl_Rtik_Package => + -- Only for std.standard. + Iterator.It2 := 0; + when others => + Internal_Error ("vhpi_scan_decls"); + end case; + end if; + loop + loop + exit when Iterator.It_Cur >= Blk.Nbr_Child; + + Ch := Blk.Children (Iterator.It_Cur); + + Iterator.It_Cur := Iterator.It_Cur + 1; + + case Ch.Kind is + when Ghdl_Rtik_Port + | Ghdl_Rtik_Generic + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Type_Array + | Ghdl_Rtik_Subtype_Array + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Subtype_Scalar => + Rti_To_Handle (Ch, Iterator.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + return; + else + Internal_Error ("vhpi_scan_decls"); + end if; + when others => + null; + end case; + end loop; + case Iterator.It2 is + when 1 => + -- Iterate on the architecture/package decl. + Iterator.It2 := 0; + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + Iterator.It_Cur := 0; + when others => + exit; + end case; + end loop; + Error := AvhpiErrorIteratorEnd; + end Vhpi_Scan_Decls; + + procedure Vhpi_Scan (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + if Iterator.Kind = AvhpiNameIteratorK then + case Iterator.N_Type.Kind is + when Ghdl_Rtik_Subtype_Array => + Vhpi_Scan_Indexed_Name (Iterator, Res, Error); + when others => + Error := AvhpiErrorHandle; + Res := Null_Handle; + end case; + return; + elsif Iterator.Kind /= VhpiIteratorK then + Error := AvhpiErrorHandle; + Res := Null_Handle; + return; + end if; + + case Iterator.Rel is + when VhpiPackInsts => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + if Iterator.It_Cur >= Blk.Nbr_Child then + Error := AvhpiErrorIteratorEnd; + return; + end if; + Res := (Kind => VhpiPackInstK, + Ctxt => (Base => Null_Address, + Block => Blk.Children (Iterator.It_Cur))); + Iterator.It_Cur := Iterator.It_Cur + 1; + Error := AvhpiErrorOk; + end; + when VhpiInternalRegions => + Vhpi_Scan_Internal_Regions (Iterator, Res, Error); + when VhpiDecls => + Vhpi_Scan_Decls (Iterator, Res, Error); + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Scan; + + function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String + is + begin + case Obj.Kind is + when VhpiEnumTypeDeclK => + return To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name; + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK + | VhpiProcessStmtK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK => + return To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name; + when VhpiRootInstK => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + return Blk.Name; + end; + when VhpiCompInstStmtK => + return Obj.Inst.Name; + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK => + return Obj.Obj.Name; + when VhpiSubtypeDeclK => + return To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name; + when others => + return null; + end case; + end Avhpi_Get_Base_Name; + + procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; + Obj : VhpiHandleT; + Res : out String; + Len : out Natural) + is + subtype R_Type is String (1 .. Res'Length); + R : R_Type renames Res; + + procedure Add (C : Character) is + begin + Len := Len + 1; + if Len <= R_Type'Last then + R (Len) := C; + end if; + end Add; + + procedure Add (Str : String) is + begin + for I in Str'Range loop + Add (Str (I)); + end loop; + end Add; + + procedure Add (Str : Ghdl_C_String) is + begin + for I in Str'Range loop + exit when Str (I) = NUL; + Add (Str (I)); + end loop; + end Add; + begin + Len := 0; + + case Property is + when VhpiNameP => + case Obj.Kind is + when VhpiEnumTypeDeclK => + Add (To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name); + when VhpiSubtypeDeclK => + Add (To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name); + when VhpiArrayTypeDeclK => + Add (To_Ghdl_Rtin_Type_Array_Acc (Obj.Atype).Name); + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK + | VhpiProcessStmtK + | VhpiBlockStmtK + | VhpiIfGenerateK => + Add (To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name); + when VhpiRootInstK => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + Add (Blk.Name); + end; + when VhpiCompInstStmtK => + Add (Obj.Inst.Name); + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK => + Add (Obj.Obj.Name); + when VhpiForGenerateK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Iter : Ghdl_Rtin_Object_Acc; + Iter_Type : Ghdl_Rti_Access; + Vptr : Ghdl_Value_Ptr; + Buf : String (1 .. 12); + Buf_Len : Natural; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Vptr := To_Ghdl_Value_Ptr + (Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Obj.Ctxt)); + Add (Blk.Name); + Add ('('); + Iter_Type := Iter.Obj_Type; + if Iter_Type.Kind = Ghdl_Rtik_Subtype_Scalar then + Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc + (Iter_Type).Basetype; + end if; + case Iter_Type.Kind is + when Ghdl_Rtik_Type_I32 => + To_String (Buf, Buf_Len, Vptr.I32); + Add (Buf (Buf_Len .. Buf'Last)); +-- when Ghdl_Rtik_Type_E8 => +-- Disp_Enum_Value +-- (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); +-- when Ghdl_Rtik_Type_E32 => +-- Disp_Enum_Value +-- (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); +-- when Ghdl_Rtik_Type_B1 => +-- Disp_Enum_Value +-- (Stream, Rti, +-- Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); + when others => + Add ('?'); + end case; + --Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); + Add (')'); + end; + when others => + null; + end case; + when VhpiCompNameP => + case Obj.Kind is + when VhpiCompInstStmtK => + declare + Comp : Ghdl_Rtin_Component_Acc; + begin + Comp := To_Ghdl_Rtin_Component_Acc (Obj.Inst.Instance); + if Comp.Common.Kind = Ghdl_Rtik_Component then + Add (Comp.Name); + end if; + end; + when others => + null; + end case; + when VhpiLibLogicalNameP => + case Obj.Kind is + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Lib : Ghdl_Rtin_Type_Scalar_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + if Blk.Common.Kind = Ghdl_Rtik_Package_Body then + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + end if; + Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); + if Lib.Common.Kind /= Ghdl_Rtik_Library then + Internal_Error ("VhpiLibLogicalNameP"); + end if; + Add (Lib.Name); + end; + when others => + null; + end case; + when VhpiFullNameP => + declare + Rstr : Rstring; + Nctxt : Rti_Context; + begin + if Obj.Kind = VhpiCompInstStmtK then + Get_Instance_Context (Obj.Inst, Obj.Ctxt, Nctxt); + Get_Path_Name (Rstr, Nctxt, ':', False); + else + Get_Path_Name (Rstr, Obj.Ctxt, ':', False); + end if; + Copy (Rstr, R, Len); + Free (Rstr); + case Obj.Kind is + when VhpiCompInstStmtK => + null; + when VhpiPortDeclK + | VhpiSigDeclK => + Add (':'); + Add (Obj.Obj.Name); + when others => + null; + end case; + end; + when others => + null; + end case; + end Vhpi_Get_Str; + + procedure Vhpi_Handle (Rel : VhpiOneToOneT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default error. + Error := AvhpiErrorNotImplemented; + + case Rel is + when VhpiDesignUnit => + case Ref.Kind is + when VhpiRootInstK => + case Ref.Ctxt.Block.Kind is + when Ghdl_Rtik_Architecture => + Res := (Kind => VhpiArchBodyK, + Ctxt => Ref.Ctxt); + Error := AvhpiErrorOk; + return; + when others => + return; + end case; + when others => + return; + end case; + when VhpiPrimaryUnit => + case Ref.Kind is + when VhpiArchBodyK => + declare + Rti : Ghdl_Rti_Access; + Ent : Ghdl_Rtin_Block_Acc; + begin + Rti := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block).Parent; + Ent := To_Ghdl_Rtin_Block_Acc (Rti); + Res := (Kind => VhpiEntityDeclK, + Ctxt => (Base => Ref.Ctxt.Base + Ent.Loc, + Block => Rti)); + Error := AvhpiErrorOk; + end; + when others => + return; + end case; + when VhpiIterScheme => + case Ref.Kind is + when VhpiForGenerateK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Iter : Ghdl_Rtin_Object_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Res := (Kind => VhpiConstDeclK, + Ctxt => Ref.Ctxt, + Obj => Iter); + Error := AvhpiErrorOk; + end; + when others => + return; + end case; + when VhpiSubtype => + case Ref.Kind is + when VhpiPortDeclK + | VhpiSigDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + Res := (Kind => VhpiSubtypeIndicK, + Ctxt => Ref.Ctxt, + Atype => Ref.Obj.Obj_Type); + Error := AvhpiErrorOk; + when others => + return; + end case; + when VhpiTypeMark => + case Ref.Kind is + when VhpiSubtypeIndicK => + -- FIXME: if the subtype is anonymous, return the base type. + Rti_To_Handle (Ref.Atype, Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + return; + when others => + return; + end case; + when VhpiBaseType => + declare + Atype : Ghdl_Rti_Access; + begin + case Ref.Kind is + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK => + Atype := Ref.Atype; + when VhpiGenericDeclK => + Atype := Ref.Obj.Obj_Type; + when VhpiIndexedNameK => + Atype := Ref.N_Type; + when others => + return; + end case; + case Atype.Kind is + when Ghdl_Rtik_Subtype_Array => + Rti_To_Handle + (To_Ghdl_Rti_Access (To_Ghdl_Rtin_Subtype_Array_Acc + (Atype).Basetype), + Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + when Ghdl_Rtik_Subtype_Scalar => + Rti_To_Handle + (To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype, + Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + when Ghdl_Rtik_Type_Array => + Res := Ref; + Error := AvhpiErrorOk; + when others => + return; + end case; + end; + when VhpiElemSubtype => + declare + Base_Type : Ghdl_Rtin_Type_Array_Acc; + begin + case Ref.Atype.Kind is + when Ghdl_Rtik_Subtype_Array => + Base_Type := + To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype).Basetype; + when Ghdl_Rtik_Type_Array => + Base_Type := To_Ghdl_Rtin_Type_Array_Acc (Ref.Atype); + when others => + return; + end case; + Rti_To_Handle (Base_Type.Element, Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + end; + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Handle; + + procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Index : Natural; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default error. + Error := AvhpiErrorNotImplemented; + + case Rel is + when VhpiConstraints => + case Ref.Kind is + when VhpiSubtypeIndicK => + if Ref.Atype.Kind = Ghdl_Rtik_Subtype_Array then + declare + Arr_Subtype : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype); + Basetype : constant Ghdl_Rtin_Type_Array_Acc := + Arr_Subtype.Basetype; + Idx : constant Ghdl_Index_Type := + Ghdl_Index_Type (Index); + Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1); + Range_Basetype : Ghdl_Rti_Access; + begin + if Idx not in 1 .. Basetype.Nbr_Dim then + Res := Null_Handle; + Error := AvhpiErrorBadIndex; + return; + end if; + -- constraint type is basetype.indexes (idx - 1) + Bound_To_Range + (Loc_To_Addr (Arr_Subtype.Common.Depth, + Arr_Subtype.Bounds, Ref.Ctxt), + Basetype, Bounds); + Res := (Kind => VhpiIntRangeK, + Ctxt => Ref.Ctxt, + Rng_Type => Basetype.Indexes (Idx - 1), + Rng_Addr => Bounds (Idx - 1)); + Range_Basetype := Get_Base_Type (Res.Rng_Type); + case Range_Basetype.Kind is + when Ghdl_Rtik_Type_I32 => + null; + when Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Res := (Kind => VhpiEnumRangeK, + Ctxt => Ref.Ctxt, + Rng_Type => Res.Rng_Type, + Rng_Addr => Res.Rng_Addr); + when others => + Internal_Error + ("vhpi_handle_by_index/constraint"); + end case; + Error := AvhpiErrorOk; + end; + end if; + when others => + return; + end case; + when VhpiIndexedNames => + declare + Base_Type, El_Type : VhpiHandleT; + begin + Vhpi_Handle (VhpiBaseType, Ref, Base_Type, Error); + if Error /= AvhpiErrorOk then + return; + end if; + if Vhpi_Get_Kind (Base_Type) /= VhpiArrayTypeDeclK then + Error := AvhpiErrorBadRel; + return; + end if; + Vhpi_Handle (VhpiElemSubtype, Base_Type, El_Type, Error); + if Error /= AvhpiErrorOk then + return; + end if; + Res := (Kind => VhpiIndexedNameK, + Ctxt => Ref.Ctxt, + N_Addr => Avhpi_Get_Address (Ref), + N_Type => El_Type.Atype, + N_Idx => Ghdl_Index_Type (Index), + N_Obj => Ref.Obj); + if Res.N_Addr = Null_Address then + Error := AvhpiErrorBadRel; + return; + end if; + Res.N_Addr := Add_Index + (Res.Ctxt, Res.N_Addr, Res.N_Obj, Res.N_Type, + Ghdl_Index_Type (Index)); + end; + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Handle_By_Index; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out VhpiIntT; + Error : out AvhpiErrorT) + is + begin + case Property is + when VhpiLeftBoundP => + if Obj.Kind /= VhpiIntRangeK then + Res := 0; + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Left; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when VhpiRightBoundP => + if Obj.Kind /= VhpiIntRangeK then + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Right; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when others => + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Get; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out Boolean; + Error : out AvhpiErrorT) + is + begin + case Property is + when VhpiIsUpP => + if Obj.Kind /= VhpiIntRangeK then + Res := False; + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Dir = Dir_To; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when others => + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Get; + + function Vhpi_Get_EntityClass (Obj : VhpiHandleT) + return VhpiEntityClassT + is + begin + case Obj.Kind is + when VhpiArchBodyK => + return VhpiArchitectureEC; + when others => + return VhpiErrorEC; + end case; + end Vhpi_Get_EntityClass; + + function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT is + begin + return Obj.Kind; + end Vhpi_Get_Kind; + + function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT is + begin + case Obj.Kind is + when VhpiPortDeclK => + case Obj.Obj.Common.Mode and Ghdl_Rti_Signal_Mode_Mask is + when Ghdl_Rti_Signal_Mode_In => + return VhpiInMode; + when Ghdl_Rti_Signal_Mode_Out => + return VhpiOutMode; + when Ghdl_Rti_Signal_Mode_Inout => + return VhpiInoutMode; + when Ghdl_Rti_Signal_Mode_Buffer => + return VhpiBufferMode; + when Ghdl_Rti_Signal_Mode_Linkage => + return VhpiLinkageMode; + when others => + return VhpiErrorMode; + end case; + when others => + return VhpiErrorMode; + end case; + end Vhpi_Get_Mode; + + function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access is + begin + case Obj.Kind is + when VhpiSubtypeIndicK + | VhpiEnumTypeDeclK => + return Obj.Atype; + when VhpiSigDeclK + | VhpiPortDeclK => + return To_Ghdl_Rti_Access (Obj.Obj); + when others => + return null; + end case; + end Avhpi_Get_Rti; + + function Avhpi_Get_Address (Obj : VhpiHandleT) return Address is + begin + case Obj.Kind is + when VhpiPortDeclK + | VhpiSigDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + return Loc_To_Addr (Obj.Ctxt.Block.Depth, + Obj.Obj.Loc, + Obj.Ctxt); + when others => + return Null_Address; + end case; + end Avhpi_Get_Address; + + function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context is + begin + return Obj.Ctxt; + end Avhpi_Get_Context; + + function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT) + return Boolean + is + begin + if Hdl1.Kind /= Hdl2.Kind then + return False; + end if; + case Hdl1.Kind is + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK + | VhpiPhysTypeDeclK => + return Hdl1.Atype = Hdl2.Atype; + when others => + -- FIXME: todo + Internal_Error ("vhpi_compare_handles"); + end case; + end Vhpi_Compare_Handles; + + function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64) + return AvhpiErrorT + is + Vptr : Ghdl_Value_Ptr; + Atype : Ghdl_Rti_Access; + begin + case Obj.Kind is + when VhpiIndexedNameK => + Vptr := To_Ghdl_Value_Ptr (Obj.N_Addr); + Atype := Obj.N_Type; + when others => + return AvhpiErrorNotImplemented; + end case; + case Get_Base_Type (Atype).Kind is + when Ghdl_Rtik_Type_P64 => + null; + when others => + return AvhpiErrorHandle; + end case; + Vptr.I64 := Val; + return AvhpiErrorOk; + end Vhpi_Put_Value; +end Grt.Avhpi; + + |