diff options
Diffstat (limited to 'simulate/iir_values.adb')
| -rw-r--r-- | simulate/iir_values.adb | 1066 |
1 files changed, 0 insertions, 1066 deletions
diff --git a/simulate/iir_values.adb b/simulate/iir_values.adb deleted file mode 100644 index d80f3bf..0000000 --- a/simulate/iir_values.adb +++ /dev/null @@ -1,1066 +0,0 @@ --- Naive values for interpreted simulation --- Copyright (C) 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 GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with System; -with Ada.Unchecked_Conversion; -with GNAT.Debug_Utilities; -with Name_Table; -with Debugger; use Debugger; -with Iirs_Utils; use Iirs_Utils; - -package body Iir_Values is - - -- Functions for iir_value_literal - function Is_Equal (Left, Right: Iir_Value_Literal_Acc) return Boolean is - begin - if Left.Kind /= Right.Kind then - raise Internal_Error; - end if; - case Left.Kind is - when Iir_Value_B1 => - return Left.B1 = Right.B1; - when Iir_Value_E32 => - return Left.E32 = Right.E32; - when Iir_Value_I64 => - return Left.I64 = Right.I64; - when Iir_Value_F64 => - return Left.F64 = Right.F64; - when Iir_Value_Access => - return Left.Val_Access = Right.Val_Access; - when Iir_Value_File => - raise Internal_Error; - when Iir_Value_Array => - if Left.Bounds.Nbr_Dims /= Right.Bounds.Nbr_Dims then - raise Internal_Error; - end if; - for I in Left.Bounds.D'Range loop - if Left.Bounds.D (I).Length /= Right.Bounds.D (I).Length then - return False; - end if; - end loop; - for I in Left.Val_Array.V'Range loop - if not Is_Equal (Left.Val_Array.V (I), - Right.Val_Array.V (I)) then - return False; - end if; - end loop; - return True; - when Iir_Value_Record => - if Left.Val_Record.Len /= Right.Val_Record.Len then - raise Constraint_Error; - end if; - for I in Left.Val_Record.V'Range loop - if not Is_Equal (Left.Val_Record.V (I), - Right.Val_Record.V (I)) then - return False; - end if; - end loop; - return True; - when Iir_Value_Range => - if Left.Dir /= Right.Dir then - return False; - end if; - if not Is_Equal (Left.Left, Right.Left) then - return False; - end if; - if not Is_Equal (Left.Right, Right.Right) then - return False; - end if; - return True; - when Iir_Value_Signal - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal => - raise Internal_Error; - end case; - end Is_Equal; - - function Compare_Value (Left, Right : Iir_Value_Literal_Acc) - return Order is - begin - if Left.Kind /= Right.Kind then - raise Constraint_Error; - end if; - case Left.Kind is - when Iir_Value_B1 => - if Left.B1 < Right.B1 then - return Less; - elsif Left.B1 = Right.B1 then - return Equal; - else - return Greater; - end if; - when Iir_Value_E32 => - if Left.E32 < Right.E32 then - return Less; - elsif Left.E32 = Right.E32 then - return Equal; - else - return Greater; - end if; - when Iir_Value_I64 => - if Left.I64 < Right.I64 then - return Less; - elsif Left.I64 = Right.I64 then - return Equal; - else - return Greater; - end if; - when Iir_Value_F64 => - if Left.F64 < Right.F64 then - return Less; - elsif Left.F64 = Right.F64 then - return Equal; - elsif Left.F64 > Right.F64 then - return Greater; - else - raise Constraint_Error; - end if; - when Iir_Value_Array => - -- LRM93 §7.2.2 - -- For discrete array types, the relation < (less than) is defined - -- such as the left operand is less than the right operand if - -- and only if: - -- * the left operand is a null array and the right operand is - -- a non-null array; otherwise - -- * both operands are non-null arrays, and one of the following - -- conditions is satisfied: - -- - the leftmost element of the left operand is less than - -- that of the right; or - -- - the leftmost element of the left operand is equal to - -- that of the right, and the tail of the left operand is - -- less than that of the right (the tail consists of the - -- remaining elements to the rights of the leftmost element - -- and can be null) - -- The relation <= (less than or equal) for discrete array types - -- is defined to be the inclusive disjunction of the results of - -- the < and = operators for the same two operands. - -- The relation > (greater than) and >= (greater than of equal) - -- are defined to be the complements of the <= and < operators - -- respectively for the same two operands. - if Left.Bounds.Nbr_Dims /= 1 or Right.Bounds.Nbr_Dims /= 1 then - raise Internal_Error; - end if; - for I in 1 .. Iir_Index32'Min (Left.Bounds.D (1).Length, - Right.Bounds.D (1).Length) - loop - case Compare_Value (Left.Val_Array.V (I), - Right.Val_Array.V (I)) is - when Less => - return Less; - when Greater => - return Greater; - when Equal => - null; - end case; - end loop; - if Left.Bounds.D (1).Length < Right.Bounds.D (1).Length then - return Less; - elsif Left.Bounds.D (1).Length = Right.Bounds.D (1).Length then - return Equal; - else - return Greater; - end if; - when Iir_Value_Signal - | Iir_Value_Access - | Iir_Value_Range - | Iir_Value_Record - | Iir_Value_File - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal => - raise Internal_Error; - end case; - end Compare_Value; - - function Is_Nul_Range (Arange : Iir_Value_Literal_Acc) return Boolean - is - Cmp : Order; - begin - Cmp := Compare_Value (Arange.Left, Arange.Right); - case Arange.Dir is - when Iir_To => - return Cmp = Greater; - when Iir_Downto => - return Cmp = Less; - end case; - end Is_Nul_Range; - - procedure Increment (Val : Iir_Value_Literal_Acc) is - begin - case Val.Kind is - when Iir_Value_B1 => - if Val.B1 = False then - Val.B1 := True; - else - raise Constraint_Error; - end if; - when Iir_Value_E32 => - Val.E32 := Val.E32 + 1; - when Iir_Value_I64 => - Val.I64 := Val.I64 + 1; - when Iir_Value_F64 - | Iir_Value_Array - | Iir_Value_Record - | Iir_Value_Range - | Iir_Value_File - | Iir_Value_Access - | Iir_Value_Signal - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal => - raise Internal_Error; - end case; - end Increment; - - procedure Store (Dest : Iir_Value_Literal_Acc; Src : Iir_Value_Literal_Acc) - is - begin - if Dest.Kind /= Src.Kind then - raise Constraint_Error; - end if; - case Dest.Kind is - when Iir_Value_Array => - if Dest.Val_Array.Len /= Src.Val_Array.Len then - raise Constraint_Error; - end if; - for I in Dest.Val_Array.V'Range loop - Store (Dest.Val_Array.V (I), Src.Val_Array.V (I)); - end loop; - when Iir_Value_Record => - if Dest.Val_Record.Len /= Src.Val_Record.Len then - raise Constraint_Error; - end if; - for I in Dest.Val_Record.V'Range loop - Store (Dest.Val_Record.V (I), Src.Val_Record.V (I)); - end loop; - when Iir_Value_B1 => - Dest.B1 := Src.B1; - when Iir_Value_E32 => - Dest.E32 := Src.E32; - when Iir_Value_I64 => - Dest.I64 := Src.I64; - when Iir_Value_F64 => - Dest.F64 := Src.F64; - when Iir_Value_Access => - Dest.Val_Access := Src.Val_Access; - when Iir_Value_File => - Dest.File := Src.File; - when Iir_Value_Protected => - Dest.Prot := Src.Prot; - when Iir_Value_Signal - | Iir_Value_Range - | Iir_Value_Quantity - | Iir_Value_Terminal => - raise Internal_Error; - end case; - end Store; - - procedure Check_Bounds (Dest : Iir_Value_Literal_Acc; - Src : Iir_Value_Literal_Acc; - Loc : Iir) - is - begin - case Dest.Kind is - when Iir_Value_Array => - if Src.Kind /= Iir_Value_Array then - raise Internal_Error; - end if; - if Dest.Val_Array.Len /= Src.Val_Array.Len then - Error_Msg_Constraint (Loc); - end if; - if Dest.Val_Array.Len /= 0 then - Check_Bounds (Dest.Val_Array.V (1), Src.Val_Array.V (1), Loc); - end if; - when Iir_Value_Record => - if Src.Kind /= Iir_Value_Record then - raise Internal_Error; - end if; - if Dest.Val_Record.Len /= Src.Val_Record.Len then - raise Internal_Error; - end if; - for I in Dest.Val_Record.V'Range loop - Check_Bounds (Dest.Val_Record.V (I), Src.Val_Record.V (I), Loc); - end loop; - when Iir_Value_Access - | Iir_Value_File - | Iir_Value_Range - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal => - if Src.Kind /= Dest.Kind then - raise Internal_Error; - end if; - when Iir_Value_B1 - | Iir_Value_E32 - | Iir_Value_I64 - | Iir_Value_F64 - | Iir_Value_Signal => - return; - end case; - end Check_Bounds; - - function To_Iir_Value_Literal_Acc is new Ada.Unchecked_Conversion - (System.Address, Iir_Value_Literal_Acc); - function To_Value_Array_Acc is new Ada.Unchecked_Conversion - (System.Address, Value_Array_Acc); - function To_Value_Bounds_Array_Acc is new Ada.Unchecked_Conversion - (System.Address, Value_Bounds_Array_Acc); - - function Create_Signal_Value (Sig : Ghdl_Signal_Ptr) - return Iir_Value_Literal_Acc - is - subtype Signal_Value is Iir_Value_Literal (Iir_Value_Signal); - function Alloc is new Alloc_On_Pool_Addr (Signal_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Global_Pool'Access, - (Kind => Iir_Value_Signal, Sig => Sig))); - end Create_Signal_Value; - - function Create_Terminal_Value (Terminal : Terminal_Index_Type) - return Iir_Value_Literal_Acc - is - subtype Terminal_Value is Iir_Value_Literal (Iir_Value_Terminal); - function Alloc is new Alloc_On_Pool_Addr (Terminal_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Global_Pool'Access, - (Kind => Iir_Value_Terminal, Terminal => Terminal))); - end Create_Terminal_Value; - - function Create_Quantity_Value (Quantity : Quantity_Index_Type) - return Iir_Value_Literal_Acc - is - subtype Quantity_Value is Iir_Value_Literal (Iir_Value_Quantity); - function Alloc is new Alloc_On_Pool_Addr (Quantity_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Global_Pool'Access, - (Kind => Iir_Value_Quantity, Quantity => Quantity))); - end Create_Quantity_Value; - - function Create_Protected_Value (Prot : Protected_Index_Type) - return Iir_Value_Literal_Acc - is - subtype Protected_Value is Iir_Value_Literal (Iir_Value_Protected); - function Alloc is new Alloc_On_Pool_Addr (Protected_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Global_Pool'Access, - (Kind => Iir_Value_Protected, Prot => Prot))); - end Create_Protected_Value; - - function Create_B1_Value (Val : Ghdl_B1) return Iir_Value_Literal_Acc - is - subtype B1_Value is Iir_Value_Literal (Iir_Value_B1); - function Alloc is new Alloc_On_Pool_Addr (B1_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, (Kind => Iir_Value_B1, B1 => Val))); - end Create_B1_Value; - - function Create_E32_Value (Val : Ghdl_E32) return Iir_Value_Literal_Acc - is - subtype E32_Value is Iir_Value_Literal (Iir_Value_E32); - function Alloc is new Alloc_On_Pool_Addr (E32_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, (Kind => Iir_Value_E32, E32 => Val))); - end Create_E32_Value; - - function Create_I64_Value (Val : Ghdl_I64) return Iir_Value_Literal_Acc - is - subtype I64_Value is Iir_Value_Literal (Iir_Value_I64); - function Alloc is new Alloc_On_Pool_Addr (I64_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, (Kind => Iir_Value_I64, I64 => Val))); - end Create_I64_Value; - - function Create_F64_Value (Val : Ghdl_F64) return Iir_Value_Literal_Acc - is - subtype F64_Value is Iir_Value_Literal (Iir_Value_F64); - function Alloc is new Alloc_On_Pool_Addr (F64_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, (Kind => Iir_Value_F64, F64 => Val))); - end Create_F64_Value; - - function Create_Access_Value (Val : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - subtype Access_Value is Iir_Value_Literal (Iir_Value_Access); - function Alloc is new Alloc_On_Pool_Addr (Access_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, - (Kind => Iir_Value_Access, Val_Access => Val))); - end Create_Access_Value; - - function Create_Range_Value - (Left, Right : Iir_Value_Literal_Acc; - Dir : Iir_Direction; - Length : Iir_Index32) - return Iir_Value_Literal_Acc - is - subtype Range_Value is Iir_Value_Literal (Iir_Value_Range); - function Alloc is new Alloc_On_Pool_Addr (Range_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, - (Kind => Iir_Value_Range, - Left => Left, - Right => Right, - Dir => Dir, - Length => Length))); - end Create_Range_Value; - - function Create_File_Value (Val : Grt.Files.Ghdl_File_Index) - return Iir_Value_Literal_Acc - is - subtype File_Value is Iir_Value_Literal (Iir_Value_File); - function Alloc is new Alloc_On_Pool_Addr (File_Value); - begin - return To_Iir_Value_Literal_Acc - (Alloc (Current_Pool, - (Kind => Iir_Value_File, File => Val))); - end Create_File_Value; - - -- Create a range_value of life LIFE. - function Create_Range_Value - (Left, Right : Iir_Value_Literal_Acc; - Dir : Iir_Direction) - return Iir_Value_Literal_Acc - is - Low, High : Iir_Value_Literal_Acc; - Len : Iir_Index32; - begin - case Dir is - when Iir_To => - Low := Left; - High := Right; - when Iir_Downto => - Low := Right; - High := Left; - end case; - - case (Low.Kind) is - when Iir_Value_B1 => - if High.B1 >= Low.B1 then - Len := Ghdl_B1'Pos (High.B1) - Ghdl_B1'Pos (Low.B1) + 1; - else - Len := 0; - end if; - when Iir_Value_E32 => - if High.E32 >= Low.E32 then - Len := Iir_Index32 (High.E32 - Low.E32 + 1); - else - Len := 0; - end if; - when Iir_Value_I64 => - declare - L : Ghdl_I64; - begin - if High.I64 = Ghdl_I64'Last and Low.I64 = Ghdl_I64'First - then - -- Prevent overflow - Len := Iir_Index32'Last; - else - L := High.I64 - Low.I64; - if L >= Ghdl_I64 (Iir_Index32'Last) then - -- Prevent overflow - Len := Iir_Index32'Last; - else - L := L + 1; - if L < 0 then - -- null range. - Len := 0; - else - Len := Iir_Index32 (L); - end if; - end if; - end if; - end; - when Iir_Value_F64 => - Len := 0; - when Iir_Value_Array - | Iir_Value_Record - | Iir_Value_Access - | Iir_Value_File - | Iir_Value_Range - | Iir_Value_Signal - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal => - raise Internal_Error; - end case; - return Create_Range_Value (Left, Right, Dir, Len); - end Create_Range_Value; - - -- Return an array of length LENGTH. - function Create_Array_Value (Dim : Iir_Index32; - Pool : Areapool_Acc := Current_Pool) - return Iir_Value_Literal_Acc - is - subtype Array_Value is Iir_Value_Literal (Iir_Value_Array); - function Alloc_Array is new Alloc_On_Pool_Addr (Array_Value); - subtype Dim_Type is Value_Bounds_Array (Dim); - function Alloc_Bounds is new Alloc_On_Pool_Addr (Dim_Type); - Res : Iir_Value_Literal_Acc; - begin - Res := To_Iir_Value_Literal_Acc - (Alloc_Array (Pool, - (Kind => Iir_Value_Array, - Bounds => null, Val_Array => null))); - - Res.Bounds := To_Value_Bounds_Array_Acc - (Alloc_Bounds (Pool, Dim_Type'(Nbr_Dims => Dim, - D => (others => null)))); - - return Res; - end Create_Array_Value; - - procedure Create_Array_Data (Arr : Iir_Value_Literal_Acc; - Len : Iir_Index32; - Pool : Areapool_Acc := Current_Pool) - is - use System; - subtype Data_Type is Value_Array (Len); - Res : Address; - begin - -- Manually allocate the array to handle large arrays without - -- creating a large temporary value. - Allocate - (Pool.all, Res, Data_Type'Size / Storage_Unit, Data_Type'Alignment); - - declare - -- Discard the warnings for no pragma Import as we really want - -- to use the default initialization. - pragma Warnings (Off); - Addr1 : constant Address := Res; - Init : Data_Type; - for Init'Address use Addr1; - pragma Warnings (On); - begin - null; - end; - - Arr.Val_Array := To_Value_Array_Acc (Res); - end Create_Array_Data; - - function Create_Array_Value (Length: Iir_Index32; - Dim : Iir_Index32; - Pool : Areapool_Acc := Current_Pool) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Value (Dim, Pool); - Create_Array_Data (Res, Length, Pool); - return Res; - end Create_Array_Value; - - function Create_Record_Value - (Nbr : Iir_Index32; Pool : Areapool_Acc := Current_Pool) - return Iir_Value_Literal_Acc - is - subtype Record_Value is Iir_Value_Literal (Iir_Value_Record); - function Alloc_Record is new Alloc_On_Pool_Addr (Record_Value); - subtype Data_Type is Value_Array (Nbr); - function Alloc_Data is new Alloc_On_Pool_Addr (Data_Type); - Res : Iir_Value_Literal_Acc; - begin - Res := To_Iir_Value_Literal_Acc - (Alloc_Record (Pool, (Kind => Iir_Value_Record, Val_Record => null))); - - Res.Val_Record := To_Value_Array_Acc - (Alloc_Data (Pool, Data_Type'(Len => Nbr, V => (others => null)))); - - return Res; - end Create_Record_Value; - - -- Create a copy of SRC with a specified life. - function Copy (Src: in Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - begin - case Src.Kind is - when Iir_Value_E32 => - return Create_E32_Value (Src.E32); - when Iir_Value_I64 => - return Create_I64_Value (Src.I64); - when Iir_Value_F64 => - return Create_F64_Value (Src.F64); - when Iir_Value_B1 => - return Create_B1_Value (Src.B1); - when Iir_Value_Access => - return Create_Access_Value (Src.Val_Access); - when Iir_Value_Array => - Res := Copy_Array_Bound (Src); - for I in Src.Val_Array.V'Range loop - Res.Val_Array.V (I) := Copy (Src.Val_Array.V (I)); - end loop; - return Res; - - when Iir_Value_Range => - return Create_Range_Value - (Left => Copy (Src.Left), - Right => Copy (Src.Right), - Dir => Src.Dir, - Length => Src.Length); - - when Iir_Value_Record => - Res := Copy_Record (Src); - for I in Src.Val_Record.V'Range loop - Res.Val_Record.V (I) := Copy (Src.Val_Record.V (I)); - end loop; - return Res; - - when Iir_Value_File => - return Create_File_Value (Src.File); - when Iir_Value_Protected => - return Create_Protected_Value (Src.Prot); - - when Iir_Value_Signal - | Iir_Value_Quantity - | Iir_Value_Terminal => - raise Internal_Error; - end case; - end Copy; - - function Copy_Array_Bound (Src : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims); - for I in Res.Bounds.D'Range loop - Res.Bounds.D (I) := Copy (Src.Bounds.D (I)); - end loop; - return Res; - end Copy_Array_Bound; - - function Copy_Record (Src : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Create_Record_Value (Src.Val_Record.Len); - end Copy_Record; - - function Unshare (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) - return Iir_Value_Literal_Acc - is - Prev_Pool : constant Areapool_Acc := Current_Pool; - Res : Iir_Value_Literal_Acc; - begin - Current_Pool := Pool; - Res := Copy (Src); - Current_Pool := Prev_Pool; - return Res; - end Unshare; - - function Unshare_Bounds (Src : Iir_Value_Literal_Acc; Pool : Areapool_Acc) - return Iir_Value_Literal_Acc is - begin - if Src.Kind /= Iir_Value_Array then - return Src; - end if; - declare - Prev_Pool : constant Areapool_Acc := Current_Pool; - Res : Iir_Value_Literal_Acc; - begin - Current_Pool := Pool; - Res := Create_Array_Value (Src.Val_Array.Len, Src.Bounds.Nbr_Dims); - for I in Src.Bounds.D'Range loop - Res.Bounds.D (I) := Copy (Src.Bounds.D (I)); - end loop; - Res.Val_Array.V := Src.Val_Array.V; - Current_Pool := Prev_Pool; - return Res; - end; - end Unshare_Bounds; - - Heap_Pool : aliased Areapool; - - function Unshare_Heap (Src : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - -- FIXME: this is never free. - return Unshare (Src, Heap_Pool'Access); - end Unshare_Heap; - - procedure Free_Heap_Value (Acc : Iir_Value_Literal_Acc) is - begin - null; - end Free_Heap_Value; - - function Get_Nbr_Of_Scalars (Val : Iir_Value_Literal_Acc) return Natural is - begin - case Val.Kind is - when Iir_Value_Scalars - | Iir_Value_Access - | Iir_Value_Signal => - return 1; - when Iir_Value_Record => - declare - Total : Natural := 0; - begin - for I in Val.Val_Record.V'Range loop - Total := Total + Get_Nbr_Of_Scalars (Val.Val_Record.V (I)); - end loop; - return Total; - end; - when Iir_Value_Array => - if Val.Val_Array.Len = 0 then - -- Nul array - return 0; - else - -- At least one element. - return Natural (Val.Val_Array.Len) - * Get_Nbr_Of_Scalars (Val.Val_Array.V (1)); - end if; - when Iir_Value_File - | Iir_Value_Range - | Iir_Value_Protected - | Iir_Value_Terminal - | Iir_Value_Quantity => - raise Internal_Error; - end case; - end Get_Nbr_Of_Scalars; - - function Get_Enum_Pos (Val : Iir_Value_Literal_Acc) return Natural is - begin - case Val.Kind is - when Iir_Value_E32 => - return Ghdl_E32'Pos (Val.E32); - when Iir_Value_B1 => - return Ghdl_B1'Pos (Val.B1); - when others => - raise Internal_Error; - end case; - end Get_Enum_Pos; - - procedure Disp_Value_Tab (Value: Iir_Value_Literal_Acc; - Tab: Ada.Text_IO.Count) - is - use Ada.Text_IO; - use GNAT.Debug_Utilities; - begin - Set_Col (Tab); - if Value = null then - Put_Line ("*NULL*"); - return; - end if; - - if Boolean'(True) then - Put (Image (Value.all'Address) & ' '); - end if; - - case Value.Kind is - when Iir_Value_B1 => - Put_Line ("b1:" & Ghdl_B1'Image (Value.B1)); - when Iir_Value_E32 => - Put_Line ("e32:" & Ghdl_E32'Image (Value.E32)); - when Iir_Value_I64 => - Put_Line ("i64:" & Ghdl_I64'Image (Value.I64)); - when Iir_Value_F64 => - Put_Line ("F64:" & Ghdl_F64'Image (Value.F64)); - when Iir_Value_Access => - -- FIXME. - if Value.Val_Access = null then - Put_Line ("access: null"); - else - Put ("access: "); - Put_Line (Image (Value.Val_Access.all'Address)); - end if; - when Iir_Value_Array => - if Value.Val_Array = null then - Put_Line ("array, without elements"); - return; - else - Put_Line ("array, length: " - & Iir_Index32'Image (Value.Val_Array.Len)); - declare - Ntab: constant Count := Tab + Indentation; - begin - Set_Col (Ntab); - if Value.Bounds /= null then - Put_Line ("bounds 1 .." - & Iir_Index32'Image (Value.Bounds.Nbr_Dims) - & ':'); - for I in Value.Bounds.D'Range loop - Disp_Value_Tab (Value.Bounds.D (I), Ntab); - end loop; - else - Put_Line ("bounds = null"); - end if; - Set_Col (Ntab); - Put_Line ("values 1 .." - & Iir_Index32'Image (Value.Val_Array.Len) - & ':'); - for I in Value.Val_Array.V'Range loop - Disp_Value_Tab (Value.Val_Array.V (I), Ntab); - end loop; - end; - end if; - - when Iir_Value_Range => - Put_Line ("range:"); - Set_Col (Tab); - Put (" direction: "); - Put (Iir_Direction'Image (Value.Dir)); - Put (", length:"); - Put_Line (Iir_Index32'Image (Value.Length)); - if Value.Left /= null then - Set_Col (Tab); - Put (" left bound: "); - Disp_Value_Tab (Value.Left, Col); - end if; - if Value.Right /= null then - Set_Col (Tab); - Put (" right bound: "); - Disp_Value_Tab (Value.Right, Col); - end if; - - when Iir_Value_Record => - Put_Line ("record:"); - for I in Value.Val_Record.V'Range loop - Disp_Value_Tab (Value.Val_Record.V (I), Tab + Indentation); - end loop; - when Iir_Value_Signal => - Put ("signal: "); - if Value.Sig = null then - Put_Line ("(not created)"); - else - Put_Line (Image (Value.Sig.all'Address)); - end if; - - when Iir_Value_File => - Put_Line ("file:" & Grt.Files.Ghdl_File_Index'Image (Value.File)); - when Iir_Value_Protected => - Put_Line ("protected"); - when Iir_Value_Quantity => - Put_Line ("quantity"); - when Iir_Value_Terminal => - Put_Line ("terminal"); - end case; - end Disp_Value_Tab; - - procedure Disp_Value (Value: Iir_Value_Literal_Acc) is - begin - Disp_Value_Tab (Value, 1); - end Disp_Value; - - -- Return TRUE if VALUE has an indirect value. - function Is_Indirect (Value : Iir_Value_Literal_Acc) return Boolean is - begin - case Value.Kind is - when Iir_Value_Scalars - | Iir_Value_Access - | Iir_Value_File - | Iir_Value_Protected - | Iir_Value_Quantity - | Iir_Value_Terminal => - return False; - when Iir_Value_Range => - return Is_Indirect (Value.Left) - or else Is_Indirect (Value.Right); - when Iir_Value_Array => - for I in Value.Val_Array.V'Range loop - if Is_Indirect (Value.Val_Array.V (I)) then - return True; - end if; - end loop; - return False; - when Iir_Value_Record => - for I in Value.Val_Record.V'Range loop - if Is_Indirect (Value.Val_Record.V (I)) then - return True; - end if; - end loop; - return False; - when Iir_Value_Signal => - return True; - end case; - end Is_Indirect; - - procedure Disp_Iir_Value_Array (Value: Iir_Value_Literal_Acc; - A_Type: Iir; - Dim: Iir_Index32; - Off : in out Iir_Index32) - is - use Ada.Text_IO; - type Last_Enum_Type is (None, Char, Identifier); - Last_Enum: Last_Enum_Type; - El_Type: Iir; - Enum_List: Iir_List; - El_Id : Name_Id; - El_Pos : Natural; - begin - if Dim = Value.Bounds.Nbr_Dims then - -- Last dimension - El_Type := Get_Base_Type (Get_Element_Subtype (A_Type)); - - -- Pretty print vectors of enumerated types - if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition - and then not Is_Indirect (Value) - then - Last_Enum := None; - Enum_List := Get_Enumeration_Literal_List (El_Type); - for I in 1 .. Value.Bounds.D (Dim).Length loop - El_Pos := Get_Enum_Pos (Value.Val_Array.V (Off)); - Off := Off + 1; - El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos)); - if Name_Table.Is_Character (El_Id) then - case Last_Enum is - when None => - Put (""""); - when Identifier => - Put (" & """); - when Char => - null; - end case; - Put (Name_Table.Get_Character (El_Id)); - Last_Enum := Char; - else - case Last_Enum is - when None => - null; - when Identifier => - Put (" & "); - when Char => - Put (""" & "); - end case; - Put (Name_Table.Image (El_Id)); - Last_Enum := Identifier; - end if; - end loop; - case Last_Enum is - when None => - Put (""""); - when Identifier => - null; - when Char => - Put (""""); - end case; - else - Put ("("); - for I in 1 .. Value.Bounds.D (Dim).Length loop - if I /= 1 then - Put (", "); - end if; - Disp_Iir_Value (Value.Val_Array.V (Off), El_Type); - Off := Off + 1; - end loop; - Put (")"); - end if; - else - Put ("("); - for I in 1 .. Value.Bounds.D (Dim).Length loop - if I /= 1 then - Put (", "); - end if; - Disp_Iir_Value_Array (Value, A_Type, Dim + 1, Off); - end loop; - Put (")"); - end if; - end Disp_Iir_Value_Array; - - procedure Disp_Iir_Value_Record - (Value: Iir_Value_Literal_Acc; A_Type: Iir) - is - use Ada.Text_IO; - El : Iir_Element_Declaration; - List : Iir_List; - begin - List := Get_Elements_Declaration_List (Get_Base_Type (A_Type)); - Put ("("); - for I in Value.Val_Record.V'Range loop - El := Get_Nth_Element (List, Natural (I - 1)); - if I /= 1 then - Put (", "); - end if; - Put (Name_Table.Image (Get_Identifier (El))); - Put (" => "); - Disp_Iir_Value (Value.Val_Record.V (I), Get_Type (El)); - end loop; - Put (")"); - end Disp_Iir_Value_Record; - - procedure Disp_Iir_Value (Value: Iir_Value_Literal_Acc; A_Type: Iir) is - use Ada.Text_IO; - begin - if Value = null then - Put ("!NULL!"); - return; - end if; - case Value.Kind is - when Iir_Value_I64 => - Put (Ghdl_I64'Image (Value.I64)); - when Iir_Value_F64 => - Put (Ghdl_F64'Image (Value.F64)); - when Iir_Value_E32 - | Iir_Value_B1 => - declare - Bt : constant Iir := Get_Base_Type (A_Type); - Id : Name_Id; - Pos : Integer; - begin - if Value.Kind = Iir_Value_E32 then - Pos := Ghdl_E32'Pos (Value.E32); - else - Pos := Ghdl_B1'Pos (Value.B1); - end if; - Id := Get_Identifier - (Get_Nth_Element (Get_Enumeration_Literal_List (Bt), Pos)); - Put (Name_Table.Image (Id)); - end; - when Iir_Value_Access => - if Value.Val_Access = null then - Put ("null"); - else - -- FIXME. - Put ("*acc*"); - end if; - when Iir_Value_Array => - declare - Off : Iir_Index32; - begin - Off := 1; - Disp_Iir_Value_Array (Value, A_Type, 1, Off); - pragma Assert (Off = Value.Val_Array.Len + 1); - end; - when Iir_Value_File => - raise Internal_Error; - when Iir_Value_Record => - Disp_Iir_Value_Record (Value, A_Type); - when Iir_Value_Range => - -- FIXME. - raise Internal_Error; - when Iir_Value_Quantity => - Put ("[quantity]"); - when Iir_Value_Terminal => - Put ("[terminal]"); - when Iir_Value_Signal => - Put ("[signal]"); - when Iir_Value_Protected => - Put ("[protected]"); - end case; - end Disp_Iir_Value; -end Iir_Values; |