aboutsummaryrefslogtreecommitdiffstats
path: root/testsuite/vests/vhdl-93/billowitch/compliant/tc480.vhd
blob: 539d0b0d6b17705577e57836226f216123e4e684 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
-- Copyright (C) 2001 Bill Billowitch.

-- Some of the work to develop this test suite was done with Air Force
-- support.  The Air Force and Bill Billowitch assume no
-- responsibilities for this software.

-- This file is part of VESTs (Vhdl tESTs).

-- VESTs 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 of the License, or (at
-- your option) any later version. 

-- VESTs 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 VESTs; if not, write to the Free Software Foundation,
-- Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA 

-- ---------------------------------------------------------------------
--
-- $Id: tc480.vhd,v 1.2 2001-10-26 16:29:55 paw Exp $
-- $Revision: 1.2 $
--
-- ---------------------------------------------------------------------

ENTITY model IS
  PORT
    (
      F1:  OUT     integer := 3;
      F2:  INOUT    integer := 3;
      F3:  IN    integer
      );
END model;

architecture model of model is
begin
  process
  begin
    wait for 1 ns;
    assert F3= 3
      report"wrong initialization of F3 through type conversion" severity failure;
    assert F2 = 3
      report"wrong initialization of F2 through type conversion" severity failure;
    wait;
  end process;
end;


ENTITY c03s02b01x01p19n01i00480ent IS
END c03s02b01x01p19n01i00480ent;

ARCHITECTURE c03s02b01x01p19n01i00480arch OF c03s02b01x01p19n01i00480ent IS

  type    real_vector is array (natural range <>) of real;
  function resolution6(i:in real_vector) return real is
    variable temp : real := 3.0;
  begin
    return temp;
  end resolution6;

  subtype    real_state is resolution6 real;
  constant    C66 : real_state   := 3.0;

  function complex_scalar(s : real_state) return integer is
  begin
    return 3;
  end complex_scalar;
  function scalar_complex(s : integer) return real_state is
  begin
    return C66;
  end scalar_complex;
  component model1
    PORT
      (    
        F1:  OUT     integer;
        F2:  INOUT    integer;
        F3:  IN    integer
        );
  end component;
  for T1 : model1 use entity work.model(model);

  signal S1 : real_state;
  signal S2 : real_state;
  signal S3 : real_state:= C66;
BEGIN
  T1: model1
    port map (
      scalar_complex(F1) => S1,
      scalar_complex(F2) => complex_scalar(S2),
      F3 => complex_scalar(S3)
      );
  TESTING: PROCESS
  BEGIN
    wait for 1 ns;
    assert NOT((S1 = C66) and (S2 = C66)) 
      report "***PASSED TEST: c03s02b01x01p19n01i00480" 
      severity NOTE;
    assert ((S1 = C66) and (S2 = C66)) 
      report "***FAILED TEST: c03s02b01x01p19n01i00480 - For an interface object of mode out, buffer, inout, or linkage, if the formal part includes a type conversion function, then the parameter subtype of that function must be a constrained array subtype."
      severity ERROR;
    wait;
  END PROCESS TESTING;

END c03s02b01x01p19n01i00480arch;
'#n608'>608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731
--  GHDL Run Time (GRT) - RTI utilities.
--  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.Disp; use Grt.Disp;
with Grt.Errors; use Grt.Errors;

package body Grt.Rtis_Utils is

   function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result
   is
      function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result;

      function Traverse_Blocks_1 (Ctxt : Rti_Context) return Traverse_Result
      is
         Blk : Ghdl_Rtin_Block_Acc;

         Res : Traverse_Result;
         Nctxt : Rti_Context;
         Index : Ghdl_Index_Type;
         Child : Ghdl_Rti_Access;
      begin
         Res := Process (Ctxt, Ctxt.Block);
         if Res /= Traverse_Ok then
            return Res;
         end if;

         Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
         Index := 0;
         while Index < Blk.Nbr_Child loop
            Child := Blk.Children (Index);
            Index := Index + 1;
            case Child.Kind is
               when Ghdl_Rtik_Process
                 | Ghdl_Rtik_Block =>
                  declare
                     Nblk : Ghdl_Rtin_Block_Acc;
                  begin
                     Nblk := To_Ghdl_Rtin_Block_Acc (Child);
                     Nctxt := (Base => Ctxt.Base + Nblk.Loc,
                               Block => Child);
                     Res := Traverse_Blocks_1 (Nctxt);
                  end;
               when Ghdl_Rtik_For_Generate =>
                  declare
                     Gen : constant Ghdl_Rtin_Generate_Acc :=
                       To_Ghdl_Rtin_Generate_Acc (Child);
                     Length : Ghdl_Index_Type;
                  begin
                     Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
                               Block => Gen.Child);
                     Length := Get_For_Generate_Length (Gen, Ctxt);
                     for I in 1 .. Length loop
                        Res := Traverse_Blocks_1 (Nctxt);
                        exit when Res = Traverse_Stop;
                        Nctxt.Base := Nctxt.Base + Gen.Size;
                     end loop;
                  end;
               when Ghdl_Rtik_If_Generate
                 | Ghdl_Rtik_Case_Generate =>
                  Nctxt := Get_If_Case_Generate_Child (Ctxt, Child);
                  if Nctxt.Base /= Null_Address then
                     Res := Traverse_Blocks_1 (Nctxt);
                  end if;
               when Ghdl_Rtik_Instance =>
                  Res := Process (Ctxt, Child);
                  if Res = Traverse_Ok then
                     declare
                        Obj : Ghdl_Rtin_Instance_Acc;
                     begin
                        Obj := To_Ghdl_Rtin_Instance_Acc (Child);

                        Get_Instance_Context (Obj, Ctxt, Nctxt);
                        if Nctxt /= Null_Context then
                           Res := Traverse_Instance (Nctxt);
                        end if;
                     end;
                  end if;
               when Ghdl_Rtik_Package
                 | Ghdl_Rtik_Entity
                 | Ghdl_Rtik_Architecture =>
                  Internal_Error ("traverse_blocks");
               when others =>
                  Res := Process (Ctxt, Child);
            end case;
            exit when Res = Traverse_Stop;
         end loop;

         return Res;
      end Traverse_Blocks_1;

      function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result
      is
         Blk : Ghdl_Rtin_Block_Acc;

         Res : Traverse_Result;
         Nctxt : Rti_Context;

      begin
         Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
         case Blk.Common.Kind is
            when Ghdl_Rtik_Architecture =>
               Nctxt := (Base => Ctxt.Base,
                         Block => Blk.Parent);
               --  The entity.
               Res := Traverse_Blocks_1 (Nctxt);
               if Res /= Traverse_Stop then
                  --  The architecture.
                  Res := Traverse_Blocks_1 (Ctxt);
               end if;
            when Ghdl_Rtik_Package_Body =>
               Nctxt := (Base => Ctxt.Base,
                         Block => Blk.Parent);
               Res := Traverse_Blocks_1 (Nctxt);
            when others =>
               Internal_Error ("traverse_blocks");
         end case;
         return Res;
      end Traverse_Instance;
   begin
      return Traverse_Instance (Ctxt);
   end Traverse_Blocks;

   --  Disp value stored at ADDR and whose type is described by RTI.
   procedure Get_Enum_Value
     (Vstr : in out Vstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
   is
      Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
   begin
      Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
      Append (Vstr, Enum_Rti.Names (Val));
   end Get_Enum_Value;

   procedure Object_To_Base_Bounds (Obj_Type : Ghdl_Rti_Access;
                                    Obj_Loc : Address;
                                    Addr : out Address;
                                    Bounds : out Address) is
   begin
      --  FIXME: put this into a function.
      Bounds := Null_Address;
      Addr := Obj_Loc;
      case Obj_Type.Kind is
         when  Ghdl_Rtik_Subtype_Array
           | Ghdl_Rtik_Type_Record
           | Ghdl_Rtik_Subtype_Record =>
            --  Object is a pointer.
            if Rti_Complex_Type (Obj_Type) then
               Addr := To_Addr_Acc (Obj_Loc).all;
            end if;
         when Ghdl_Rtik_Type_Array
           | Ghdl_Rtik_Type_Unbounded_Record
           | Ghdl_Rtik_Subtype_Unbounded_Record =>
            --  Object is a fat pointer.
            Bounds := To_Ghdl_Uc_Array_Acc (Obj_Loc).Bounds;
            Addr := To_Ghdl_Uc_Array_Acc (Obj_Loc).Base;
         when others =>
            null;
      end case;
   end Object_To_Base_Bounds;

   procedure Record_To_Element_Base (Obj : Address;
                                     El : Ghdl_Rtin_Element_Acc;
                                     Is_Sig : Boolean;
                                     Addr : out Address) is
   begin
      if Is_Sig then
         Addr := Obj + El.Sig_Off;
      else
         Addr := Obj + El.Val_Off;
      end if;
      case El.Eltype.Kind is
         when Ghdl_Rtik_Subtype_Array
           | Ghdl_Rtik_Type_Record =>
            --  Element is an offset.
            if Rti_Complex_Type (El.Eltype) then
               Addr := Obj + To_Ghdl_Index_Acc (Addr).all;
            end if;
         when Ghdl_Rtik_Type_Array
           | Ghdl_Rtik_Type_Unbounded_Record
           | Ghdl_Rtik_Subtype_Unbounded_Record =>
            --  Element is an offset.
            Addr := Obj + To_Ghdl_Index_Acc (Addr).all;
         when others =>
            null;
      end case;
   end Record_To_Element_Base;

   procedure Foreach_Scalar (Ctxt : Rti_Context;
                             Obj_Type : Ghdl_Rti_Access;
                             Obj_Addr : Address;
                             Is_Sig : Boolean;
                             Param : Param_Type)
   is
      --  Current address.
      Addr : Address;
      Bounds : Address;

      Name : Vstring;

      procedure Handle_Any (Rti : Ghdl_Rti_Access);

      procedure Handle_Scalar (Rti : Ghdl_Rti_Access)
      is
         procedure Update (S : Ghdl_Index_Type) is
         begin
            Addr := Addr + (S / Storage_Unit);
         end Update;
      begin
         Process (Addr, Name, Rti, Param);

         if Is_Sig then
            Update (Address'Size);
         else
            case Rti.Kind is
               when Ghdl_Rtik_Type_I32 =>
                  Update (32);
               when Ghdl_Rtik_Type_E8 =>
                  Update (8);
               when Ghdl_Rtik_Type_E32 =>
                  Update (32);
               when Ghdl_Rtik_Type_B1 =>
                  Update (8);
               when Ghdl_Rtik_Type_F64 =>
                  Update (64);
               when Ghdl_Rtik_Type_P64 =>
                  Update (64);
               when others =>
                  Internal_Error ("handle_scalar");
            end case;
         end if;
      end Handle_Scalar;

      procedure Range_Pos_To_Val (Rti : Ghdl_Rti_Access;
                                  Rng : Ghdl_Range_Ptr;
                                  Pos : Ghdl_Index_Type;
                                  Val : out Value_Union)
      is
      begin
         case Rti.Kind is
            when Ghdl_Rtik_Type_I32 =>
               case Rng.I32.Dir is
                  when Dir_To =>
                     Val.I32 := Rng.I32.Left + Ghdl_I32 (Pos);
                  when Dir_Downto =>
                     Val.I32 := Rng.I32.Left - Ghdl_I32 (Pos);
               end case;
            when Ghdl_Rtik_Type_E8 =>
               case Rng.E8.Dir is
                  when Dir_To =>
                     Val.E8 := Rng.E8.Left + Ghdl_E8 (Pos);
                  when Dir_Downto =>
                     Val.E8 := Rng.E8.Left - Ghdl_E8 (Pos);
               end case;
            when Ghdl_Rtik_Type_E32 =>
               case Rng.E32.Dir is
                  when Dir_To =>
                     Val.E32 := Rng.E32.Left + Ghdl_E32 (Pos);
                  when Dir_Downto =>
                     Val.E32 := Rng.E32.Left - Ghdl_E32 (Pos);
               end case;
            when Ghdl_Rtik_Type_B1 =>
               case Pos is
                  when 0 =>
                     Val.B1 := Rng.B1.Left;
                  when 1 =>
                     Val.B1 := Rng.B1.Right;
                  when others =>
                     Val.B1 := False;
               end case;
            when others =>
               Internal_Error ("grt.rtis_utils.range_pos_to_val");
         end case;
      end Range_Pos_To_Val;

      procedure Pos_To_Vstring
        (Vstr : in out Vstring;
         Rti : Ghdl_Rti_Access;
         Rng : Ghdl_Range_Ptr;
         Pos : Ghdl_Index_Type)
      is
         V : Value_Union;
      begin
         Range_Pos_To_Val (Rti, Rng, Pos, V);
         case Rti.Kind is
            when Ghdl_Rtik_Type_I32 =>
               declare
                  S : String (1 .. 12);
                  F : Natural;
               begin
                  To_String (S, F, V.I32);
                  Append (Vstr, S (F .. S'Last));
               end;
            when Ghdl_Rtik_Type_E8 =>
               Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E8));
            when Ghdl_Rtik_Type_E32 =>
               Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E32));
            when Ghdl_Rtik_Type_B1 =>
               Get_Enum_Value (Vstr, Rti, Ghdl_B1'Pos (V.B1));
            when others =>
               Append (Vstr, '?');
         end case;
      end Pos_To_Vstring;

      procedure Handle_Array_1 (Arr_Rti : Ghdl_Rtin_Type_Array_Acc;
                                Index : Ghdl_Index_Type)
      is
         Idx_Rti : constant Ghdl_Rti_Access := Arr_Rti.Indexes (Index);
         Base_Type : constant Ghdl_Rti_Access := Get_Base_Type (Idx_Rti);
         El_Rti : constant Ghdl_Rti_Access := Arr_Rti.Element;
         Last_Index : constant Ghdl_Index_Type := Arr_Rti.Nbr_Dim - 1;
         Rng : Ghdl_Range_Ptr;
         Len : Ghdl_Index_Type;
         P : Natural;
         Cur_Bounds : Address;
      begin
         P := Length (Name);
         if Index = 0 then
            Append (Name, '(');
         else
            Append (Name, ',');
         end if;

         Extract_Range (Bounds, Base_Type, Rng);
         Len := Range_To_Length (Rng, Base_Type);

         Cur_Bounds := Bounds;
         for I in 1 .. Len loop
            Bounds := Cur_Bounds;
            Pos_To_Vstring (Name, Base_Type, Rng, I - 1);
            if Index = Last_Index then
               Append (Name, ')');
               Handle_Any (El_Rti);
            else
               Handle_Array_1 (Arr_Rti, Index + 1);
            end if;
            Truncate (Name, P + 1);
         end loop;
         Truncate (Name, P);
      end Handle_Array_1;

      procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc)
      is
         El : Ghdl_Rtin_Element_Acc;
         Obj_Addr : Address;
         Last_Addr : Address;
         P : Natural;
      begin
         P := Length (Name);
         Obj_Addr := Addr;
         Last_Addr := Addr;
         for I in 1 .. Rti.Nbrel loop
            El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1));
            Record_To_Element_Base (Obj_Addr, El, Is_Sig, Addr);
            Append (Name, '.');
            Append (Name, El.Name);
            Handle_Any (El.Eltype);
            if Addr > Last_Addr then
               Last_Addr := Addr;
            end if;
            Truncate (Name, P);
         end loop;
         Addr := Last_Addr;
      end Handle_Record;

      procedure Handle_Any (Rti : Ghdl_Rti_Access) is
      begin
         case Rti.Kind is
            when Ghdl_Rtik_Subtype_Scalar =>
               Handle_Scalar (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype);
            when Ghdl_Rtik_Type_I32
              | Ghdl_Rtik_Type_E8
              | Ghdl_Rtik_Type_E32
              | Ghdl_Rtik_Type_B1 =>
               Handle_Scalar (Rti);
            when Ghdl_Rtik_Type_Array =>
               Handle_Array_1 (To_Ghdl_Rtin_Type_Array_Acc (Rti), 0);
            when Ghdl_Rtik_Subtype_Array =>
               declare
                  St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                    To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
                  Bt : constant Ghdl_Rtin_Type_Array_Acc :=
                    To_Ghdl_Rtin_Type_Array_Acc (St.Basetype);
                  Prev_Bounds : constant Address := Bounds;
               begin
                  Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt);
                  Handle_Array_1 (Bt, 0);
                  Bounds := Prev_Bounds;
               end;
--          when Ghdl_Rtik_Type_File =>
--             declare
--                Vptr : Ghdl_Value_Ptr;
--             begin
--                Vptr := To_Ghdl_Value_Ptr (Obj);
--                Put (Stream, "File#");
--                Put_I32 (Stream, Vptr.I32);
--                --  FIXME: update OBJ (not very useful since never in a
--                --   composite type).
--             end;
            when Ghdl_Rtik_Type_Record
              | Ghdl_Rtik_Type_Unbounded_Record =>
               Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti));
            when Ghdl_Rtik_Subtype_Record =>
               declare
                  St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
                    To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
                  Bt : constant Ghdl_Rtin_Type_Record_Acc :=
                    To_Ghdl_Rtin_Type_Record_Acc (St.Basetype);
                  Prev_Bounds : constant Address := Bounds;
               begin
                  Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt);
                  Handle_Record (Bt);
                  Bounds := Prev_Bounds;
               end;
            when others =>
               Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any");
         end case;
      end Handle_Any;
   begin
      Object_To_Base_Bounds (Obj_Type, Obj_Addr, Addr, Bounds);
      Handle_Any (Obj_Type);
      Free (Name);
   end Foreach_Scalar;

   procedure Get_Value (Str : in out Vstring;
                        Value : Value_Union;
                        Type_Rti : Ghdl_Rti_Access)
   is
   begin
      case Type_Rti.Kind is
         when Ghdl_Rtik_Type_I32 =>
            declare
               S : String (1 .. 12);
               F : Natural;
            begin
               To_String (S, F, Value.I32);
               Append (Str, S (F .. S'Last));
            end;
         when Ghdl_Rtik_Type_E8 =>
            Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E8));
         when Ghdl_Rtik_Type_E32 =>
            Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E32));
         when Ghdl_Rtik_Type_B1 =>
            Get_Enum_Value
              (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1)));
         when Ghdl_Rtik_Type_F64 =>
            declare
               S : String (1 .. 32);
               L : Integer;

               function Snprintf_G (Cstr : Address;
                                    Size : Natural;
                                    Arg : Ghdl_F64)
                 return Integer;
               pragma Import (C, Snprintf_G, "__ghdl_snprintf_g");

            begin
               L := Snprintf_G (S'Address, S'Length, Value.F64);
               if L < 0 then
                  --  FIXME.
                  Append (Str, "?");
               else
                  Append (Str, S (1 .. L));
               end if;
            end;
         when Ghdl_Rtik_Type_P32 =>
            declare
               S : String (1 .. 12);
               F : Natural;
            begin
               To_String (S, F, Value.I32);
               Append (Str, S (F .. S'Last));
               Append
                 (Str, Get_Physical_Unit_Name
                    (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0)));
            end;
         when Ghdl_Rtik_Type_P64 =>
            declare
               S : String (1 .. 21);
               F : Natural;
            begin
               To_String (S, F, Value.I64);
               Append (Str, S (F .. S'Last));
               Append
                 (Str, Get_Physical_Unit_Name
                    (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0)));
            end;
         when others =>
            Internal_Error ("grt.rtis_utils.get_value");
      end case;
   end Get_Value;

   procedure Disp_Value (Stream : FILEs;
                         Value : Value_Union;
                         Type_Rti : Ghdl_Rti_Access)
   is
      Name : Vstring;
   begin
      Rtis_Utils.Get_Value (Name, Value, Type_Rti);
      Put (Stream, Name);
      Free (Name);
   end Disp_Value;

   function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access)
                                   return Ghdl_C_String
   is
   begin
      case Unit.Kind is
         when Ghdl_Rtik_Unit64 =>
            return To_Ghdl_Rtin_Unit64_Acc (Unit).Name;
         when Ghdl_Rtik_Unitptr =>
            return To_Ghdl_Rtin_Unitptr_Acc (Unit).Name;
         when others =>
            Internal_Error ("rtis_utils.physical_unit_name");
      end case;
   end Get_Physical_Unit_Name;

   function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access;
                                     Type_Rti : Ghdl_Rti_Access)
                                    return Ghdl_I64 is
   begin
      case Unit.Kind is
         when Ghdl_Rtik_Unit64 =>
            return To_Ghdl_Rtin_Unit64_Acc (Unit).Value;
         when Ghdl_Rtik_Unitptr =>
            case Type_Rti.Kind is
               when Ghdl_Rtik_Type_P64 =>
                  return To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64;
               when Ghdl_Rtik_Type_P32 =>
                  return Ghdl_I64
                    (To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32);
               when others =>
                  Internal_Error ("get_physical_unit_value(1)");
            end case;
         when others =>
            Internal_Error ("get_physical_unit_value(2)");
      end case;
   end Get_Physical_Unit_Value;

   procedure Get_Enum_Value
     (Rstr : in out Rstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type)
   is
      Enum_Rti : Ghdl_Rtin_Type_Enum_Acc;
   begin
      Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
      Prepend (Rstr, Enum_Rti.Names (Val));
   end Get_Enum_Value;


   procedure Get_Value (Rstr : in out Rstring;
                        Addr : Address;
                        Type_Rti : Ghdl_Rti_Access)
   is
      Value : constant Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr);
   begin
      case Type_Rti.Kind is
         when Ghdl_Rtik_Type_I32 =>
            declare
               S : String (1 .. 12);
               F : Natural;
            begin
               To_String (S, F, Value.I32);
               Prepend (Rstr, S (F .. S'Last));
            end;
         when Ghdl_Rtik_Type_E8 =>
            Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E8));
         when Ghdl_Rtik_Type_E32 =>
            Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E32));
         when Ghdl_Rtik_Type_B1 =>
            Get_Enum_Value
              (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1)));
         when others =>
            Internal_Error ("grt.rtis_utils.get_value(rstr)");
      end case;
   end Get_Value;

   procedure Get_Path_Name (Rstr : in out Rstring;
                            Last_Ctxt : Rti_Context;
                            Sep : Character;
                            Is_Instance : Boolean := True)
   is
      Blk : Ghdl_Rtin_Block_Acc;
      Ctxt : Rti_Context;
   begin
      Ctxt := Last_Ctxt;
      loop
         Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
         case Ctxt.Block.Kind is
            when Ghdl_Rtik_Entity =>
               declare
                  Link : Ghdl_Entity_Link_Acc;
               begin
                  Link := To_Ghdl_Entity_Link_Acc (Ctxt.Base);
                  Ctxt := (Base => Ctxt.Base,
                           Block => Link.Rti);
                  if Ctxt.Block = null then
                     --  Process in an entity.
                     --  FIXME: check.
                     Prepend (Rstr, Blk.Name);
                     return;
                  end if;
               end;
            when Ghdl_Rtik_Architecture =>
               declare
                  Entity_Ctxt: Rti_Context;
                  Link : Ghdl_Entity_Link_Acc;
                  Parent_Inst : Ghdl_Rti_Access;
               begin
                  --  Architecture name.
                  if Is_Instance then
                     Prepend (Rstr, ')');
                     Prepend (Rstr, Blk.Name);
                     Prepend (Rstr, '(');
                  end if;

                  Entity_Ctxt := Get_Parent_Context (Ctxt);

                  --  Instance parent.
                  Link := To_Ghdl_Entity_Link_Acc (Entity_Ctxt.Base);
                  Get_Instance_Link (Link, Ctxt, Parent_Inst);

                  --  Add entity name.
                  if Is_Instance or Parent_Inst = null then
                     Prepend (Rstr,
                              To_Ghdl_Rtin_Block_Acc (Entity_Ctxt.Block).Name);
                  end if;

                  if Parent_Inst = null then
                     --  Top reached.
                     Prepend (Rstr, Sep);
                     return;
                  else
                     --  Instantiation statement label.
                     if Is_Instance then
                        Prepend (Rstr, '@');
                     end if;
                     Prepend (Rstr,
                              To_Ghdl_Rtin_Object_Acc (Parent_Inst).Name);
                     Prepend (Rstr, Sep);
                  end if;
               end;
            when Ghdl_Rtik_Process
              | Ghdl_Rtik_Block =>
               Prepend (Rstr, Blk.Name);
               Prepend (Rstr, Sep);
               Ctxt := Get_Parent_Context (Ctxt);
            when Ghdl_Rtik_Generate_Body =>
               declare
                  Gen : constant Ghdl_Rtin_Generate_Acc :=
                    To_Ghdl_Rtin_Generate_Acc (Blk.Parent);
                  Iter : Ghdl_Rtin_Object_Acc;
                  Addr : Address;
               begin
                  if Blk.Parent.Kind = Ghdl_Rtik_For_Generate then
                     Prepend (Rstr, ')');
                     Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0));
                     Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
                     Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type));
                     Prepend (Rstr, '(');
                  end if;
                  Prepend (Rstr, Gen.Name);
                  Prepend (Rstr, Sep);
                  Ctxt := Get_Parent_Context (Ctxt);
               end;
            when others =>
               Internal_Error ("grt.rtis_utils.get_path_name");
         end case;
      end loop;
   end Get_Path_Name;

   procedure Put (Stream : FILEs; Ctxt : Rti_Context)
   is
      Rstr : Rstring;
   begin
      Get_Path_Name (Rstr, Ctxt, '.');
      Put (Stream, Rstr);
      Free (Rstr);
   end Put;

   function Get_Linecol_Line (Linecol : Ghdl_Index_Type) return Ghdl_U32 is
   begin
      return Ghdl_U32 (Linecol / 256);
   end Get_Linecol_Line;

   function Get_Linecol_Col (Linecol : Ghdl_Index_Type) return Ghdl_U32 is
   begin
      return Ghdl_U32 (Linecol mod 256);
   end Get_Linecol_Col;

   function Get_Filename (Ctxt : Rti_Context) return Ghdl_C_String
   is
      C : Rti_Context;
   begin
      C := Ctxt;
      loop
         case C.Block.Kind is
            when Ghdl_Rtik_Package
              | Ghdl_Rtik_Package_Body
              | Ghdl_Rtik_Architecture
              | Ghdl_Rtik_Entity =>
               declare
                  Blk : constant Ghdl_Rtin_Block_Filename_Acc :=
                    To_Ghdl_Rtin_Block_Filename_Acc (C.Block);
               begin
                  return Blk.Filename;
               end;
            when others =>
               C := Get_Parent_Context (C);
         end case;
      end loop;
   end Get_Filename;
end Grt.Rtis_Utils;