unbounded records: add rti support (WIP)

1 files changed, 37 insertions, 36 deletions

diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb
index 8be2a2e75..7be70eb02 100644
--- a/src/grt/grt-rtis_addr.adb
+++ b/src/grt/grt-rtis_addr.adb
@@ -239,12 +239,10 @@ package body Grt.Rtis_Addr is
       end if;
    end Get_Instance_Context;
 
-   procedure Bound_To_Range (Bounds_Addr : Address;
-                             Def : Ghdl_Rtin_Type_Array_Acc;
-                             Res : out Ghdl_Range_Array)
+   procedure Extract_Range (Bounds : in out Address;
+                            Def : Ghdl_Rti_Access;
+                            Rng : out Ghdl_Range_Ptr)
    is
-      Bounds : Address;
-
       procedure Align (A : Ghdl_Index_Type) is
       begin
          Bounds := Align (Bounds, Ghdl_Rti_Loc (A));
@@ -254,7 +252,37 @@ package body Grt.Rtis_Addr is
       begin
          Bounds := Bounds + (S / Storage_Unit);
       end Update;
+   begin
+      if Bounds = Null_Address then
+         --  Propagate failure.
+         Rng := null;
+         return;
+      end if;
 
+      case Def.Kind is
+         when Ghdl_Rtik_Type_I32 =>
+            Align (Ghdl_Range_I32'Alignment);
+            Rng := To_Ghdl_Range_Ptr (Bounds);
+            Update (Ghdl_Range_I32'Size);
+         when Ghdl_Rtik_Type_B1 =>
+            Align (Ghdl_Range_B1'Alignment);
+            Rng := To_Ghdl_Range_Ptr (Bounds);
+            Update (Ghdl_Range_B1'Size);
+         when Ghdl_Rtik_Type_E8 =>
+            Align (Ghdl_Range_E8'Alignment);
+            Rng := To_Ghdl_Range_Ptr (Bounds);
+            Update (Ghdl_Range_E8'Size);
+         when others =>
+            --  Bounds are not known anymore.
+            Rng := null;
+      end case;
+   end Extract_Range;
+
+   procedure Bound_To_Range (Bounds_Addr : Address;
+                             Def : Ghdl_Rtin_Type_Array_Acc;
+                             Res : out Ghdl_Range_Array)
+   is
+      Bounds : Address;
       Idx_Def : Ghdl_Rti_Access;
    begin
       if Res'Length /= Def.Nbr_Dim or else Res'First /= 0 then
@@ -265,45 +293,18 @@ package body Grt.Rtis_Addr is
 
       for I in 0 .. Def.Nbr_Dim - 1 loop
          Idx_Def := Def.Indexes (I);
-
-         if Bounds = Null_Address then
-            Res (I) := null;
-         else
-            Idx_Def := Get_Base_Type (Idx_Def);
-            case Idx_Def.Kind is
-               when Ghdl_Rtik_Type_I32 =>
-                  Align (Ghdl_Range_I32'Alignment);
-                  Res (I) := To_Ghdl_Range_Ptr (Bounds);
-                  Update (Ghdl_Range_I32'Size);
-               when Ghdl_Rtik_Type_B1 =>
-                  Align (Ghdl_Range_B1'Alignment);
-                  Res (I) := To_Ghdl_Range_Ptr (Bounds);
-                  Update (Ghdl_Range_B1'Size);
-               when Ghdl_Rtik_Type_E8 =>
-                  Align (Ghdl_Range_E8'Alignment);
-                  Res (I) := To_Ghdl_Range_Ptr (Bounds);
-                  Update (Ghdl_Range_E8'Size);
-               when Ghdl_Rtik_Type_E32 =>
-                  Align (Ghdl_Range_E32'Alignment);
-                  Res (I) := To_Ghdl_Range_Ptr (Bounds);
-                  Update (Ghdl_Range_E32'Size);
-               when others =>
-                  --  Bounds are not known anymore.
-                  Bounds := Null_Address;
-            end case;
-         end if;
+         Idx_Def := Get_Base_Type (Idx_Def);
+         Extract_Range (Bounds, Idx_Def, Res (I));
       end loop;
    end Bound_To_Range;
 
-   function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access
-   is
+   function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access is
    begin
       case Atype.Kind is
          when Ghdl_Rtik_Subtype_Scalar =>
             return To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype;
          when Ghdl_Rtik_Subtype_Array =>
-            return To_Ghdl_Rti_Access
-              (To_Ghdl_Rtin_Subtype_Array_Acc (Atype).Basetype);
+            return To_Ghdl_Rtin_Subtype_Composite_Acc (Atype).Basetype;
          when Ghdl_Rtik_Type_E8
            | Ghdl_Rtik_Type_E32
            | Ghdl_Rtik_Type_B1 =>