diff options
| -rw-r--r-- | translate/grt/grt-avhpi.adb | 326 | ||||
| -rw-r--r-- | translate/grt/grt-avhpi.ads | 107 | ||||
| -rw-r--r-- | translate/grt/grt-rtis_addr.ads | 4 | ||||
| -rw-r--r-- | translate/grt/grt-sdf.adb | 280 | ||||
| -rw-r--r-- | translate/grt/grt-sdf.ads | 13 | ||||
| -rw-r--r-- | translate/grt/grt-vital_annotate.adb | 249 | ||||
| -rw-r--r-- | translate/grt/grt-waves.adb | 4 |
7 files changed, 783 insertions, 200 deletions
diff --git a/translate/grt/grt-avhpi.adb b/translate/grt/grt-avhpi.adb index 4b4086f..36826fe 100644 --- a/translate/grt/grt-avhpi.adb +++ b/translate/grt/grt-avhpi.adb @@ -108,12 +108,17 @@ package body Grt.Avhpi is when VhpiGenericDeclK => Res := (Kind => AvhpiNameIteratorK, Ctxt => Ref.Ctxt, - N_Addr => Loc_To_Addr (Ref.Obj.Common.Depth, - Ref.Obj.Loc, - 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; @@ -143,16 +148,55 @@ package body Grt.Avhpi is 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 + 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 := + To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Sigsize.Off; + else + El_Size := + To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Valsize.Off; + 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 - procedure Update (S : Ghdl_Index_Type) is - begin - Iterator.N_Addr := Iterator.N_Addr + (S / Storage_Unit); - end Update; - - Is_Sig : Boolean; El_Type : Ghdl_Rti_Access; begin if Iterator.N_Idx = 0 then @@ -171,23 +215,9 @@ package body Grt.Avhpi is N_Obj => Iterator.N_Obj); -- Increment Address. - case Iterator.N_Obj.Common.Kind is - when Ghdl_Rtik_Generic => - Is_Sig := False; - when others => - Internal_Error ("vhpi_scan_indexed_name(1)"); - end case; + Iterator.N_Addr := Add_Index + (Iterator.Ctxt, Iterator.N_Addr, Iterator.N_Obj, El_Type, 1); - case Get_Base_Type (El_Type).Kind is - when Ghdl_Rtik_Type_P64 => - if Is_Sig then - Update (Address'Size); - else - Update (Ghdl_I64'Size); - end if; - when others => - Internal_Error ("vhpi_scan_indexed_name"); - end case; Iterator.N_Idx := Iterator.N_Idx - 1; Error := AvhpiErrorOk; end Vhpi_Scan_Indexed_Name; @@ -328,12 +358,25 @@ package body Grt.Avhpi is Atype => Rti); end if; end; + when Ghdl_Rtik_Type_Array => + Res := (Kind => VhpiArrayTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); when Ghdl_Rtik_Type_B2 | 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); @@ -385,17 +428,19 @@ package body Grt.Avhpi is when Ghdl_Rtik_Port | Ghdl_Rtik_Generic | Ghdl_Rtik_Signal + | Ghdl_Rtik_Type_Array | Ghdl_Rtik_Subtype_Array | Ghdl_Rtik_Subtype_Array_Ptr | Ghdl_Rtik_Type_E8 | Ghdl_Rtik_Type_E32 - | Ghdl_Rtik_Type_B2 => + | Ghdl_Rtik_Type_B2 + | Ghdl_Rtik_Subtype_Scalar => Rti_To_Handle (Ch, Iterator.Ctxt, Res); if Res.Kind /= VhpiUndefined then Error := AvhpiErrorOk; return; else - Internal_Error ("vhpi_handle"); + Internal_Error ("vhpi_scan_decls"); end if; when others => null; @@ -533,6 +578,10 @@ package body Grt.Avhpi is 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 @@ -554,8 +603,6 @@ package body Grt.Avhpi is | VhpiPortDeclK | VhpiGenericDeclK => Add (Obj.Obj.Name); - when VhpiSubtypeDeclK => - Add (To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name); when VhpiForGenerateK => declare Blk : Ghdl_Rtin_Block_Acc; @@ -605,7 +652,7 @@ package body Grt.Avhpi is declare Comp : Ghdl_Rtin_Component_Acc; begin - Comp := To_Ghdl_Rtin_Component_Acc (Obj.Obj.Obj_Type); + Comp := To_Ghdl_Rtin_Component_Acc (Obj.Inst.Instance); if Comp.Common.Kind = Ghdl_Rtik_Component then Add (Comp.Name); end if; @@ -748,12 +795,226 @@ package body Grt.Avhpi is 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 : Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype); + Basetype : Ghdl_Rtin_Type_Array_Acc := + Arr_Subtype.Basetype; + Idx : 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 + 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 + 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 @@ -771,7 +1032,7 @@ package body Grt.Avhpi is return Obj.Kind; end Vhpi_Get_Kind; - function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeP is + function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT is begin case Obj.Kind is when VhpiPortDeclK => @@ -838,7 +1099,8 @@ package body Grt.Avhpi is case Hdl1.Kind is when VhpiSubtypeIndicK | VhpiSubtypeDeclK - | VhpiArrayTypeDeclK => + | VhpiArrayTypeDeclK + | VhpiPhysTypeDeclK => return Hdl1.Atype = Hdl2.Atype; when others => -- FIXME: todo diff --git a/translate/grt/grt-avhpi.ads b/translate/grt/grt-avhpi.ads index 8242d5b..771bfb8 100644 --- a/translate/grt/grt-avhpi.ads +++ b/translate/grt/grt-avhpi.ads @@ -294,6 +294,80 @@ package Grt.Avhpi is VhpiLibraryDecls ); + type VhpiIntPropertyT is + ( + VhpiAccessP, + VhpiArgcP, + VhpiAttrKindP, + VhpiBaseIndexP, + VhpiBeginLineNoP, + VhpiEndLineNoP, + VhpiEntityClassP, + VhpiForeignKindP, + VhpiFrameLevelP, + VhpiGenerateIndexP, + VhpiIntValP, + VhpiIsAnonymousP, + VhpiIsBasicP, + VhpiIsCompositeP, + VhpiIsDefaultP, + VhpiIsDeferredP, + VhpiIsDiscreteP, + VhpiIsForcedP, + VhpiIsForeignP, + VhpiIsGuardedP, + VhpiIsImplicitDeclP, + VhpiIsInvalidP_DEPRECATED, + VhpiIsLocalP, + VhpiIsNamedP, + VhpiIsNullP, + VhpiIsOpenP, + VhpiIsPLIP, + VhpiIsPassiveP, + VhpiIsPostponedP, + VhpiIsProtectedTypeP, + VhpiIsPureP, + VhpiIsResolvedP, + VhpiIsScalarP, + VhpiIsSeqStmtP, + VhpiIsSharedP, + VhpiIsTransportP, + VhpiIsUnaffectedP, + VhpiIsUnconstrainedP, + VhpiIsUninstantiatedP, + VhpiIsUpP, + VhpiIsVitalP, + VhpiIteratorTypeP, + VhpiKindP, + VhpiLeftBoundP, + VhpiLevelP_DEPRECATED, + VhpiLineNoP, + VhpiLineOffsetP, + VhpiLoopIndexP, + VhpiModeP, + VhpiNumDimensionsP, + VhpiNumFieldsP_DEPRECATED, + VhpiNumGensP, + VhpiNumLiteralsP, + VhpiNumMembersP, + VhpiNumParamsP, + VhpiNumPortsP, + VhpiOpenModeP, + VhpiPhaseP, + VhpiPositionP, + VhpiPredefAttrP, + VhpiReasonP, + VhpiRightBoundP, + VhpiSigKindP, + VhpiSizeP, + VhpiStartLineNoP, + VhpiStateP, + VhpiStaticnessP, + VhpiVHDLversionP, + VhpiIdP, + VhpiCapabilitiesP + ); + -- String properties. type VhpiStrPropertyT is ( @@ -323,7 +397,8 @@ package Grt.Avhpi is AvhpiErrorBadRel, AvhpiErrorHandle, AvhpiErrorNotImplemented, - AvhpiErrorIteratorEnd + AvhpiErrorIteratorEnd, + AvhpiErrorBadIndex ); type VhpiHandleT is private; @@ -342,6 +417,12 @@ package Grt.Avhpi is Res : out VhpiHandleT; Error : out AvhpiErrorT); + procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Index : Natural; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + procedure Vhpi_Iterator (Rel : VhpiOneToManyT; Ref : VhpiHandleT; Res : out VhpiHandleT; @@ -355,6 +436,17 @@ package Grt.Avhpi is Res : out String; Len : out Natural); + subtype VhpiIntT is Ghdl_I32; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out VhpiIntT; + Error : out AvhpiErrorT); + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out Boolean; + Error : out AvhpiErrorT); + -- Almost the same as Vhpi_Get_Str (VhpiName, OBJ), but there is not -- indexes for generate stmt. function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String; @@ -392,7 +484,7 @@ package Grt.Avhpi is function Vhpi_Get_EntityClass (Obj : VhpiHandleT) return VhpiEntityClassT; - type VhpiModeP is + type VhpiModeT is ( VhpiErrorMode, VhpiInMode, @@ -401,7 +493,7 @@ package Grt.Avhpi is VhpiBufferMode, VhpiLinkageMode ); - function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeP; + function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT; function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access; @@ -438,10 +530,17 @@ private when VhpiSubtypeIndicK | VhpiSubtypeDeclK | VhpiArrayTypeDeclK - | VhpiEnumTypeDeclK => + | VhpiEnumTypeDeclK + | VhpiPhysTypeDeclK => Atype : Ghdl_Rti_Access; when VhpiCompInstStmtK => Inst : Ghdl_Rtin_Instance_Acc; + when VhpiIntRangeK + | VhpiEnumRangeK + | VhpiFloatRangeK + | VhpiPhysRangeK => + Rng_Type : Ghdl_Rti_Access; + Rng_Addr : Ghdl_Range_Ptr; when others => null; end case; diff --git a/translate/grt/grt-rtis_addr.ads b/translate/grt/grt-rtis_addr.ads index 3f6b73e..15a05a4 100644 --- a/translate/grt/grt-rtis_addr.ads +++ b/translate/grt/grt-rtis_addr.ads @@ -43,6 +43,10 @@ package Grt.Rtis_Addr is function To_Addr_Acc is new Ada.Unchecked_Conversion (Source => Address, Target => Addr_Acc); + type Ghdl_Index_Acc is access Ghdl_Index_Type; + function To_Ghdl_Index_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Index_Acc); + -- Get the parent context of CTXT. -- The parent of an architecture is its entity. function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context; diff --git a/translate/grt/grt-sdf.adb b/translate/grt/grt-sdf.adb index 360b461..b564017 100644 --- a/translate/grt/grt-sdf.adb +++ b/translate/grt/grt-sdf.adb @@ -267,7 +267,7 @@ package body Grt.Sdf is Pos := 1; end Refill_Buf; - function Get_Token return Sdf_Token_Type + procedure Skip_Spaces is use Ada.Characters.Latin_1; begin @@ -277,21 +277,20 @@ package body Grt.Sdf is end loop; loop - -- Be sure there is at least 4 characters. - if Pos + 4 >= Buf_Len then + -- Be sure there is at least 1 character. + if Pos + 1 >= Buf_Len then Refill_Buf; end if; case Buf (Pos) is when EOT => if Pos /= Buf_Len then - Error_Bad_Character; - return Tok_Error; + return; end if; Pos := 1; Read_Sdf; if Buf_Len = 1 then - return Tok_Eof; + return; end if; when LF => Pos := Pos + 1; @@ -307,16 +306,12 @@ package body Grt.Sdf is end if; Line_Start := Pos; Sdf_Line := Sdf_Line + 1; - when '"' => -- " - Scan_Qstring; - return Tok_Qstring; when ' ' | HT => Pos := Pos + 1; when '/' => - Pos := Pos + 1; - if Buf (Pos) = '/' then - Pos := Pos + 1; + if Buf (Pos + 1) = '/' then + Pos := Pos + 2; -- Skip line comment. loop exit when Buf (Pos) = CR; @@ -328,31 +323,62 @@ package body Grt.Sdf is end if; end loop; else - return Tok_Div; + return; end if; - when '.' => - Pos := Pos + 1; - return Tok_Dot; - when ':' => - Pos := Pos + 1; - return Tok_Cln; - when '(' => - Pos := Pos + 1; - return Tok_Oparen; - when ')' => - Pos := Pos + 1; - return Tok_Cparen; - when 'a' .. 'z' - | 'A' .. 'Z' => - Scan_Identifier; - return Tok_Identifier; - when '0' .. '9' => - return Scan_Number; when others => - Error_Bad_Character; - return Tok_Error; + return; end case; end loop; + end Skip_Spaces; + + function Get_Token return Sdf_Token_Type + is + use Ada.Characters.Latin_1; + begin + Skip_Spaces; + + -- Be sure there is at least 4 characters. + if Pos + 4 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when EOT => + if Buf_Len = 1 then + return Tok_Eof; + else + Error_Bad_Character; + return Tok_Error; + end if; + when '"' => -- " + Scan_Qstring; + return Tok_Qstring; + when '/' => + -- Skip_Spaces has already handled line comments. + Pos := Pos + 1; + return Tok_Div; + when '.' => + Pos := Pos + 1; + return Tok_Dot; + when ':' => + Pos := Pos + 1; + return Tok_Cln; + when '(' => + Pos := Pos + 1; + return Tok_Oparen; + when ')' => + Pos := Pos + 1; + return Tok_Cparen; + when 'a' .. 'z' + | 'A' .. 'Z' => + Scan_Identifier; + return Tok_Identifier; + when '0' .. '9' => + return Scan_Number; + when others => + Error_Bad_Character; + return Tok_Error; + end case; end Get_Token; function Is_White_Space (C : Character) return Boolean @@ -374,90 +400,57 @@ package body Grt.Sdf is is use Ada.Characters.Latin_1; begin - loop - -- Be sure there is at least 4 characters. - if Pos + 4 >= Buf_Len then - Refill_Buf; - end if; + Skip_Spaces; - case Buf (Pos) is - when EOT => - if Pos /= Buf_Len then - exit; - end if; - Pos := 1; - Read_Sdf; - if Buf_Len = 1 then - exit; - end if; - when LF => - Pos := Pos + 1; - if Buf (Pos) = CR then - Pos := Pos + 1; - end if; - Line_Start := Pos; - Sdf_Line := Sdf_Line + 1; - when CR => - Pos := Pos + 1; - if Buf (Pos) = LF then - Pos := Pos + 1; - end if; - Line_Start := Pos; - Sdf_Line := Sdf_Line + 1; - when ' ' - | HT => - Pos := Pos + 1; - when '0' => - if Is_White_Space (Buf (Pos + 2)) then - if Buf (Pos + 1) = 'z' then - Pos := Pos + 2; - return Edge_0z; - elsif Buf (Pos + 1) = '1' then - Pos := Pos + 2; - return Edge_01; - end if; - end if; - exit; - when '1' => - if Is_White_Space (Buf (Pos + 2)) then - if Buf (Pos + 1) = 'z' then - Pos := Pos + 2; - return Edge_1z; - elsif Buf (Pos + 1) = '0' then - Pos := Pos + 2; - return Edge_10; - end if; - end if; - exit; - when 'z' => - if Is_White_Space (Buf (Pos + 2)) then - if Buf (Pos + 1) = '0' then - Pos := Pos + 2; - return Edge_Z0; - elsif Buf (Pos + 1) = '1' then - Pos := Pos + 2; - return Edge_Z1; - end if; + -- Be sure there is at least 4 characters. + if Pos + 4 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when '0' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = 'z' then + Pos := Pos + 2; + return Edge_0z; + elsif Buf (Pos + 1) = '1' then + Pos := Pos + 2; + return Edge_01; end if; - exit; - when 'p' => - Scan_Identifier; - if Is_Ident ("posedge") then - return Edge_Posedge; - else - exit; + end if; + when '1' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = 'z' then + Pos := Pos + 2; + return Edge_1z; + elsif Buf (Pos + 1) = '0' then + Pos := Pos + 2; + return Edge_10; end if; - when 'n' => - Scan_Identifier; - if Is_Ident ("negedge") then - return Edge_Negedge; - else - exit; + end if; + when 'z' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = '0' then + Pos := Pos + 2; + return Edge_Z0; + elsif Buf (Pos + 1) = '1' then + Pos := Pos + 2; + return Edge_Z1; end if; - when others => - exit; - end case; - end loop; + end if; + when 'p' => + Scan_Identifier; + if Is_Ident ("posedge") then + return Edge_Posedge; + end if; + when 'n' => + Scan_Identifier; + if Is_Ident ("negedge") then + return Edge_Negedge; + end if; + when others => + null; + end case; Error_Sdf ("edge_identifier expected"); return Edge_Error; end Get_Edge_Token; @@ -524,6 +517,8 @@ package body Grt.Sdf is begin Sdf_Context.Kind := Kind; Sdf_Context.Port_Num := 0; + Sdf_Context.Ports (1).L := Invalid_Dnumber; + Sdf_Context.Ports (2).L := Invalid_Dnumber; Sdf_Context.Ports (1).Edge := Edge_None; Sdf_Context.Ports (2).Edge := Edge_None; end Start_Generic_Name; @@ -665,6 +660,35 @@ package body Grt.Sdf is Port_Spec.Name (Len) := To_Lower (Buf (I)); end loop; Port_Spec.Name_Len := Len; + + -- Parse [ DNUMBER ] + -- | [ DNUMBER : DNUMBER ] + Skip_Spaces; + if Buf (Pos) = '[' then + Port_Spec.R := Invalid_Dnumber; + Pos := Pos + 1; + if Get_Token /= Tok_Dnumber then + Error_Sdf (Tok); + else + Port_Spec.L := Ghdl_I32 (Scan_Int); + end if; + Skip_Spaces; + if Buf (Pos) = ':' then + Pos := Pos + 1; + if Get_Token /= Tok_Dnumber then + Error_Sdf (Tok); + else + Port_Spec.R := Ghdl_I32 (Scan_Int); + end if; + Skip_Spaces; + end if; + if Buf (Pos) /= ']' then + Error_Sdf ("']' expected"); + else + Pos := Pos + 1; + end if; + end if; + return True; end Parse_Port_Path1; @@ -1115,20 +1139,24 @@ package body Grt.Sdf is exit when not Is_Ident ("INSTANCE"); Tok := Get_Token; if Tok /= Tok_Cparen then - if Tok /= Tok_Identifier then - Error_Sdf ("instance identifier expected"); - return False; - end if; - for I in Ident_Start .. Ident_End loop - Buf (I) := To_Lower (Buf (I)); + loop + if Tok /= Tok_Identifier then + Error_Sdf ("instance identifier expected"); + return False; + end if; + for I in Ident_Start .. Ident_End loop + Buf (I) := To_Lower (Buf (I)); + end loop; + Vital_Annotate.Sdf_Instance + (Sdf_Context.all, Buf (Ident_Start .. Ident_End), Ok); + if not Ok then + Error_Sdf ("cannot find instance"); + return False; + end if; + Tok := Get_Token; + exit when Tok /= Tok_Dot; + Tok := Get_Token; end loop; - Vital_Annotate.Sdf_Instance - (Sdf_Context.all, Buf (Ident_Start .. Ident_End), Ok); - if not Ok then - Error_Sdf ("cannot find instance"); - return False; - end if; - Tok := Get_Token; end if; if Tok /= Tok_Cparen or else Get_Token /= Tok_Oparen diff --git a/translate/grt/grt-sdf.ads b/translate/grt/grt-sdf.ads index 9e24776..c6d0514 100644 --- a/translate/grt/grt-sdf.ads +++ b/translate/grt/grt-sdf.ads @@ -68,11 +68,22 @@ package Grt.Sdf is Read_Size : constant Natural := 4096; Buf_Size : constant Natural := Read_Size + 1024 + 1; + Invalid_Dnumber : constant Ghdl_I32 := -1; + type Port_Spec_Type is record - Name : String (1 .. 1024); + -- Port identifier. + Name : String (1 .. 128); Name_Len : Natural; + + -- Left and Right range. + -- If L = R = Invalid_Dnumber, this is a simple scalar port. + -- If R = Invalid_Dnumber, this is a scalar port (from a vector) + -- Otherwise, this is a bus port. + L, R : Ghdl_I32; + -- Cond : String (1 .. 1024); -- Cond_Len : Natural; + Edge : Edge_Type; end record; diff --git a/translate/grt/grt-vital_annotate.adb b/translate/grt/grt-vital_annotate.adb index 9a31bf4..5c8c1d0 100644 --- a/translate/grt/grt-vital_annotate.adb +++ b/translate/grt/grt-vital_annotate.adb @@ -78,27 +78,66 @@ package body Grt.Vital_Annotate is -- New_Line; end Find_Instance; - procedure Find_Generic - (Name : String; Res : out VhpiHandleT; Ok : out Boolean) + procedure Find_Generic (Gen_Name : String; + Gen_Handle : out VhpiHandleT; + Port1_Name : String; + Port1_Handle : out VhpiHandleT; + Port2_Name : String; + Port2_Handle : out VhpiHandleT) is Error : AvhpiErrorT; It : VhpiHandleT; + Decl : VhpiHandleT; begin - Ok := False; + Gen_Handle := Null_Handle; + Port1_Handle := Null_Handle; + Port2_Handle := Null_Handle; + Vhpi_Iterator (VhpiDecls, Sdf_Inst, It, Error); if Error /= AvhpiErrorOk then return; end if; + + -- Look for the generic. loop - Vhpi_Scan (It, Res, Error); - exit when Error /= AvhpiErrorOk; - exit when Vhpi_Get_Kind (Res) /= VhpiGenericDeclK; - if Name_Compare (Res, Name) then - Ok := True; + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then return; end if; + exit when Vhpi_Get_Kind (Decl) /= VhpiGenericDeclK; + if Name_Compare (Decl, Gen_Name) then + Gen_Handle := Decl; + exit; + end if; end loop; - return; + + -- Skip generics. + while Vhpi_Get_Kind (Decl) = VhpiGenericDeclK loop + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + end loop; + + -- Look for ports. + loop + exit when Vhpi_Get_Kind (Decl) /= VhpiPortDeclK; + if Name_Compare (Decl, Port1_Name) then + Port1_Handle := Decl; + exit when Port2_Name'Length = 0; + end if; + if Port2_Name'Length > 0 + and then Name_Compare (Decl, Port2_Name) + then + Port2_Handle := Decl; + exit when Vhpi_Get_Kind (Port1_Handle) /= VhpiUndefined; + end if; + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + end loop; + end Find_Generic; procedure Sdf_Header (Context : in out Sdf_Context_Type) @@ -191,6 +230,9 @@ package body Grt.Vital_Annotate is end Sdf_Instance_End; VitalDelayType01 : VhpiHandleT; + VitalDelayArrayType01 : VhpiHandleT; + VitalDelayType : VhpiHandleT; + VitalDelayArrayType : VhpiHandleT; type Map_Type is array (1 .. 12) of Natural; Map_1 : constant Map_Type := (1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0); @@ -233,12 +275,88 @@ package body Grt.Vital_Annotate is return True; end Write_Td_Delay_Generic; + function Write_Td_Delay_Generic (Context : Sdf_Context_Type; + Gen : VhpiHandleT) + return Boolean + is + Gen_Basetype : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("write_td_delay_generic: vhpiBaseType"); + return False; + end if; + if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) then + case Context.Timing_Nbr is + when 1 => + return Write_Td_Delay_Generic (Context, Gen, 2, Map_1); + when 2 => + return Write_Td_Delay_Generic (Context, Gen, 2, Map_2); + when others => + Errors.Error + ("timing generic type mismatch SDF timing specification"); + end case; + elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType) then + if Vhpi_Put_Value (Gen, Context.Timing (1) * 1000) /= AvhpiErrorOk + then + Internal_Error ("vhpi_put_value (vitaldelaytype)"); + else + return True; + end if; + else + Internal_Error ("write_td_delay_generic: unhandled generic type"); + end if; + end Write_Td_Delay_Generic; + + procedure Generic_Get_Bounds (Port : VhpiHandleT; + Left : out Ghdl_I32; + Len : out Ghdl_Index_Type; + Up : out Boolean) + is + Port_Type, Port_Range : VhpiHandleT; + Error : AvhpiErrorT; + Right : VhpiIntT; + begin + Vhpi_Handle (VhpiSubtype, Port, Port_Type, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiSubtype - port"); + return; + end if; + Vhpi_Handle_By_Index (VhpiConstraints, Port_Type, 1, Port_Range, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexConstraints - port"); + return; + end if; + Vhpi_Get (VhpiLeftBoundP, Port_Range, Left, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiLeftBoundP - port"); + return; + end if; + Vhpi_Get (VhpiRightBoundP, Port_Range, Right, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiRightBoundP - port"); + return; + end if; + Vhpi_Get (VhpiIsUpP, Port_Range, Up, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIsUpP - port"); + return; + end if; + if Up then + Len := Ghdl_Index_Type (Right - Left) + 1; + else + Len := Ghdl_Index_Type (Left - Right) + 1; + end if; + end Generic_Get_Bounds; + procedure Sdf_Generic (Context : in out Sdf_Context_Type; Name : String; Ok : out Boolean) is Gen : VhpiHandleT; - Gen_Type : VhpiHandleT; + Gen_Basetype : VhpiHandleT; + Port1, Port2 : VhpiHandleT; Error : AvhpiErrorT; begin if Flag_Dump then @@ -263,36 +381,75 @@ package body Grt.Vital_Annotate is return; end if; - Find_Generic (Name, Gen, Ok); - if not Ok then - return; - end if; - Ok := False; - -- Extract subtype. - Vhpi_Handle (VhpiSubtype, Gen, Gen_Type, Error); - if Error /= AvhpiErrorOk then - Internal_Error ("vhpiSubtype"); + if Context.Port_Num = 1 then + Context.Ports (2).Name_Len := 0; + end if; + Find_Generic + (Name, Gen, + Context.Ports (1).Name (1 .. Context.Ports (1).Name_Len), Port1, + Context.Ports (2).Name (1 .. Context.Ports (2).Name_Len), Port2); + if Vhpi_Get_Kind (Gen) = VhpiUndefined + or else Vhpi_Get_Kind (Port1) = VhpiUndefined + or else (Context.Port_Num = 2 + and then Vhpi_Get_Kind (Port2) = VhpiUndefined) + then return; end if; - Vhpi_Handle (VhpiTypeMark, Gen_Type, Gen_Type, Error); + + -- Extract subtype. + Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error); if Error /= AvhpiErrorOk then - Internal_Error ("vhpiTypeMark"); + Internal_Error ("vhpiBaseType"); return; end if; - if Vhpi_Compare_Handles (Gen_Type, VitalDelayType01) then - case Context.Timing_Nbr is - when 1 => - Ok := Write_Td_Delay_Generic (Context, Gen, 2, Map_1); - when 2 => - Ok := Write_Td_Delay_Generic (Context, Gen, 2, Map_2); - when others => - Errors.Error - ("timing generic type mismatch SDF timing specification"); - end case; + if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) then + Ok := Write_Td_Delay_Generic (Context, Gen); + elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType01) + or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType) + then + declare + Left_Gen, Left1, Left2 : Ghdl_I32; + Len_Gen, Len1, Len2 : Ghdl_Index_Type; + Up_Gen, Up1, Up2 : Boolean; + Pos : Ghdl_Index_Type; + Gen_El : VhpiHandleT; + begin + Generic_Get_Bounds (Gen, Left_Gen, Len_Gen, Up_Gen); + if Context.Port_Num >= 1 + and then Context.Ports (1).L /= Invalid_Dnumber + then + Generic_Get_Bounds (Port1, Left1, Len1, Up1); + if Up1 then + Pos := Ghdl_Index_Type (Context.Ports (1).L - Left1); + else + Pos := Ghdl_Index_Type (Left1 - Context.Ports (1).L); + end if; + else + Pos := 0; + end if; + if Context.Port_Num >= 2 + and then Context.Ports (2).L /= Invalid_Dnumber + then + Generic_Get_Bounds (Port2, Left2, Len2, Up2); + Pos := Pos * Len2; + if Up1 then + Pos := Pos + Ghdl_Index_Type (Context.Ports (2).L - Left2); + else + Pos := Pos + Ghdl_Index_Type (Left1 - Context.Ports (2).L); + end if; + end if; + Vhpi_Handle_By_Index + (VhpiIndexedNames, Gen, Integer (Pos), Gen_El, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexedNames - gen_el"); + return; + end if; + Ok := Write_Td_Delay_Generic (Context, Gen_El); + end; else - Errors.Error ("bad generic type"); + Errors.Error ("vital: unhandled generic type"); end if; end Sdf_Generic; @@ -357,6 +514,7 @@ package body Grt.Vital_Annotate is It : VhpiHandleT; Pkg : VhpiHandleT; Decl : VhpiHandleT; + Basetype : VhpiHandleT; Status : AvhpiErrorT; begin Get_Package_Inst (It); @@ -378,12 +536,33 @@ package body Grt.Vital_Annotate is loop Vhpi_Scan (It, Decl, Status); exit when Status /= AvhpiErrorOk; - if Name_Compare (Decl, "vitaldelaytype01") then - VitalDelayType01 := Decl; + if Vhpi_Get_Kind (Decl) = VhpiSubtypeDeclK + or else Vhpi_Get_Kind (Decl) = VhpiArrayTypeDeclK + then + Vhpi_Handle (VhpiBaseType, Decl, Basetype, Status); + if Status = AvhpiErrorOk then + if Name_Compare (Decl, "vitaldelaytype01") then + VitalDelayType01 := Basetype; + elsif Name_Compare (Decl, "vitaldelayarraytype01") then + VitalDelayArrayType01 := Basetype; + elsif Name_Compare (Decl, "vitaldelaytype") then + VitalDelayType := Basetype; + elsif Name_Compare (Decl, "vitaldelayarraytype") then + VitalDelayArrayType := Basetype; + end if; + end if; end if; end loop; if Vhpi_Get_Kind (VitalDelayType01) = VhpiUndefined then - Error ("cannot found VitalDelayType01 in ieee.vital_timing"); + Error ("cannot find VitalDelayType01 in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayArrayType01) = VhpiUndefined then + Error ("cannot find VitalDelayArrayType01 in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayType) = VhpiUndefined then + Error ("cannot find VitalDelayType in ieee.vital_timing"); return; end if; end Extract_Vital_Delay_Type; diff --git a/translate/grt/grt-waves.adb b/translate/grt/grt-waves.adb index fed4086..c2c0138 100644 --- a/translate/grt/grt-waves.adb +++ b/translate/grt/grt-waves.adb @@ -62,7 +62,7 @@ package body Grt.Waves is Ghw_Hie_Port_Buffer : constant Unsigned_8 := 20; -- Port Ghw_Hie_Port_Linkage : constant Unsigned_8 := 21; -- Port - -- Return TRUE if OPT is an option for VCD. + -- Return TRUE if OPT is an option for wave. function Wave_Option (Opt : String) return Boolean is F : Natural := Opt'First; @@ -842,7 +842,7 @@ package body Grt.Waves is procedure Write_Hierarchy_El (Decl : VhpiHandleT) is - Mode2hie : constant array (VhpiModeP) of Unsigned_8 := + Mode2hie : constant array (VhpiModeT) of Unsigned_8 := (VhpiErrorMode => Ghw_Hie_Signal, VhpiInMode => Ghw_Hie_Port_In, VhpiOutMode => Ghw_Hie_Port_Out, |