aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/grt/ghwlib.c116
-rw-r--r--src/grt/ghwlib.h34
-rw-r--r--src/grt/grt-disp_rti.adb101
-rw-r--r--src/grt/grt-ghw.ads2
-rw-r--r--src/grt/grt-rtis_addr.adb43
-rw-r--r--src/grt/grt-rtis_addr.ads2
-rw-r--r--src/grt/grt-waves.adb345
7 files changed, 390 insertions, 253 deletions
diff --git a/src/grt/ghwlib.c b/src/grt/ghwlib.c
index 218f8cb2c..816a2b392 100644
--- a/src/grt/ghwlib.c
+++ b/src/grt/ghwlib.c
@@ -439,11 +439,14 @@ ghw_get_base_type (union ghw_type *t)
case ghdl_rtik_type_f64:
case ghdl_rtik_type_p32:
case ghdl_rtik_type_p64:
+ case ghdl_rtik_type_array:
return t;
case ghdl_rtik_subtype_scalar:
return t->ss.base;
case ghdl_rtik_subtype_array:
- return (union ghw_type*)(t->sa.base);
+ return t->sa.base;
+ case ghdl_rtik_subtype_unbounded_array:
+ return t->sua.base;
default:
fprintf (stderr, "ghw_get_base_type: cannot handle type %d\n", t->kind);
abort ();
@@ -474,6 +477,9 @@ get_nbr_elements (union ghw_type *t)
return t->rec.nbr_scalars;
case ghdl_rtik_subtype_record:
return t->sr.nbr_scalars;
+ case ghdl_rtik_subtype_unbounded_record:
+ case ghdl_rtik_subtype_unbounded_array:
+ return -1;
default:
fprintf (stderr, "get_nbr_elements: unhandled type %d\n", t->kind);
abort ();
@@ -515,27 +521,45 @@ ghw_get_range_length (union ghw_range *rng)
return (res <= 0) ? 0 : res;
}
+static union ghw_type *
+ghw_read_type_bounds (struct ghw_handler *h, union ghw_type *base);
+
/* Create an array subtype using BASE and ranges read from H. */
struct ghw_subtype_array *
-ghw_read_array_subtype (struct ghw_handler *h, struct ghw_type_array *base)
+ghw_read_array_subtype (struct ghw_handler *h, union ghw_type *base)
{
+ struct ghw_type_array *arr =
+ (struct ghw_type_array *)ghw_get_base_type (base);
struct ghw_subtype_array *sa;
unsigned j;
int nbr_scalars;
+ int nbr_els;
sa = malloc (sizeof (struct ghw_subtype_array));
sa->kind = ghdl_rtik_subtype_array;
sa->name = NULL;
sa->base = base;
- nbr_scalars = get_nbr_elements (base->el);
- sa->rngs = malloc (base->nbr_dim * sizeof (union ghw_range *));
- for (j = 0; j < base->nbr_dim; j++)
+ nbr_els = get_nbr_elements (arr->el);
+ nbr_scalars = 1;
+ sa->rngs = malloc (arr->nbr_dim * sizeof (union ghw_range *));
+ for (j = 0; j < arr->nbr_dim; j++)
{
sa->rngs[j] = ghw_read_range (h);
nbr_scalars *= ghw_get_range_length (sa->rngs[j]);
}
- sa->nbr_scalars = nbr_scalars;
+ if (nbr_els >= 0)
+ {
+ /* Element type is bounded. */
+ sa->el = arr->el;
+ }
+ else
+ {
+ /* Read bounds for the elements. */
+ sa->el = ghw_read_type_bounds(h, arr->el);
+ nbr_els = get_nbr_elements (sa->el);
+ }
+ sa->nbr_scalars = nbr_scalars * nbr_els;
return sa;
}
@@ -575,22 +599,7 @@ ghw_read_record_subtype (struct ghw_handler *h, struct ghw_type_record *base)
}
else
{
- switch (btype->kind)
- {
- case ghdl_rtik_type_array:
- sr->els[j].type = (union ghw_type *)
- ghw_read_array_subtype (h, &btype->ar);
- break;
- case ghdl_rtik_type_record:
- sr->els[j].type = (union ghw_type *)
- ghw_read_record_subtype (h, &btype->rec);
- break;
- default:
- fprintf
- (stderr, "ghw_read_record_subtype: unhandled kind %d\n",
- btype->kind);
- return NULL;
- }
+ sr->els[j].type = ghw_read_type_bounds(h, btype);
el_nbr_scalars = get_nbr_elements (sr->els[j].type);
}
nbr_scalars += el_nbr_scalars;
@@ -600,6 +609,28 @@ ghw_read_record_subtype (struct ghw_handler *h, struct ghw_type_record *base)
return sr;
}
+/* Read bounds for BASE and create a subtype. */
+
+static union ghw_type *
+ghw_read_type_bounds (struct ghw_handler *h, union ghw_type *base)
+{
+ switch (base->kind)
+ {
+ case ghdl_rtik_type_array:
+ case ghdl_rtik_subtype_unbounded_array:
+ return (union ghw_type *)ghw_read_array_subtype (h, base);
+ break;
+ case ghdl_rtik_type_record:
+ case ghdl_rtik_subtype_unbounded_record:
+ return (union ghw_type *)ghw_read_record_subtype (h, &base->rec);
+ break;
+ default:
+ fprintf (stderr, "ghw_read_type_bounds: unhandled kind %d\n",
+ base->kind);
+ return NULL;
+ }
+}
+
int
ghw_read_type (struct ghw_handler *h)
{
@@ -622,7 +653,8 @@ ghw_read_type (struct ghw_handler *h)
t = fgetc (h->stream);
if (t == EOF)
return -1;
- /* printf ("type[%d]= %d\n", i, t); */
+ if (h->flag_verbose > 2)
+ printf ("type[%d]= %d\n", i, t);
switch (t)
{
case ghdl_rtik_type_b2:
@@ -734,7 +766,8 @@ ghw_read_type (struct ghw_handler *h)
for (j = 0; j < arr->nbr_dim; j++)
arr->dims[j] = ghw_read_typeid (h);
if (h->flag_verbose > 1)
- printf ("array: %s\n", arr->name);
+ printf ("array: %s (ndim=%u) of %s\n",
+ arr->name, arr->nbr_dim, arr->el->common.name);
h->types[i] = (union ghw_type *)arr;
break;
err_array:
@@ -746,10 +779,10 @@ ghw_read_type (struct ghw_handler *h)
{
struct ghw_subtype_array *sa;
const char *name;
- struct ghw_type_array *base;
+ union ghw_type *base;
name = ghw_read_strid (h);
- base = (struct ghw_type_array *)ghw_read_typeid (h);
+ base = ghw_read_typeid (h);
sa = ghw_read_array_subtype (h, base);
sa->name = name;
@@ -759,6 +792,19 @@ ghw_read_type (struct ghw_handler *h)
sa->name, sa->nbr_scalars);
}
break;
+ case ghdl_rtik_subtype_unbounded_array:
+ {
+ struct ghw_subtype_unbounded_array *sua;
+
+ sua = malloc (sizeof (struct ghw_subtype_unbounded_array));
+ sua->kind = t;
+ sua->name = ghw_read_strid (h);
+ sua->base = ghw_read_typeid (h);
+ h->types[i] = (union ghw_type *)sua;
+ if (h->flag_verbose > 1)
+ printf ("subtype unbounded array: %s\n", sua->name);
+ }
+ break;
case ghdl_rtik_type_record:
{
struct ghw_type_record *rec;
@@ -897,10 +943,10 @@ ghw_read_signal (struct ghw_handler *h, unsigned int *sigs, union ghw_type *t)
int len;
len = t->sa.nbr_scalars;
- stride = get_nbr_elements (t->sa.base->el);
+ stride = get_nbr_elements (t->sa.el);
for (i = 0; i < len; i += stride)
- if (ghw_read_signal (h, &sigs[i], t->sa.base->el) < 0)
+ if (ghw_read_signal (h, &sigs[i], t->sa.el) < 0)
return -1;
}
return 0;
@@ -1975,13 +2021,15 @@ static void
ghw_disp_array_subtype_bounds (struct ghw_subtype_array *a)
{
unsigned i;
+ struct ghw_type_array *base =
+ (struct ghw_type_array *)ghw_get_base_type (a->base);
printf (" (");
- for (i = 0; i < a->base->nbr_dim; i++)
+ for (i = 0; i < base->nbr_dim; i++)
{
if (i != 0)
printf (", ");
- ghw_disp_range (a->base->dims[i], a->rngs[i]);
+ ghw_disp_range (base->dims[i], a->rngs[i]);
}
printf (")");
}
@@ -2051,6 +2099,13 @@ ghw_disp_subtype_definition (struct ghw_handler *h, union ghw_type *t)
ghw_disp_record_subtype_bounds (sr);
}
break;
+ case ghdl_rtik_subtype_unbounded_array:
+ {
+ struct ghw_subtype_unbounded_record *sur = &t->sur;
+
+ ghw_disp_typename (h, (union ghw_type *)sur->base);
+ }
+ break;
default:
printf ("ghw_disp_subtype_definition: unhandled type kind %d\n",
t->kind);
@@ -2158,6 +2213,7 @@ ghw_disp_type (struct ghw_handler *h, union ghw_type *t)
case ghdl_rtik_subtype_array:
case ghdl_rtik_subtype_scalar:
case ghdl_rtik_subtype_record:
+ case ghdl_rtik_subtype_unbounded_array:
{
struct ghw_type_common *c = &t->common;
printf ("subtype %s is ", c->name);
diff --git a/src/grt/ghwlib.h b/src/grt/ghwlib.h
index 9fdbd1eb8..3c0fecc10 100644
--- a/src/grt/ghwlib.h
+++ b/src/grt/ghwlib.h
@@ -78,16 +78,19 @@ enum ghdl_rtik {
ghdl_rtik_type_file,
ghdl_rtik_subtype_scalar,
ghdl_rtik_subtype_array, /* 35 */
- ghdl_rtik_subtype_array_ptr, /* Obsolete. */
- ghdl_rtik_subtype_unconstrained_array, /* Obsolete. */
+ ghdl_rtik_subtype_array_ptr, /* Obsolete. */
+ ghdl_rtik_subtype_unbounded_array,
ghdl_rtik_subtype_record,
- ghdl_rtik_subtype_access,
+ ghdl_rtik_subtype_unbounded_record,
+#if 0
+ ghdl_rtik_subtype_access, /* 40 */
ghdl_rtik_type_protected,
ghdl_rtik_element,
ghdl_rtik_unit,
ghdl_rtik_attribute_transaction,
ghdl_rtik_attribute_quiet,
ghdl_rtik_attribute_stable,
+#endif
ghdl_rtik_error
};
@@ -198,14 +201,23 @@ struct ghw_type_array
union ghw_type **dims;
};
+struct ghw_subtype_unbounded_array
+{
+ enum ghdl_rtik kind;
+ const char *name;
+
+ union ghw_type *base;
+};
+
struct ghw_subtype_array
{
enum ghdl_rtik kind;
const char *name;
- struct ghw_type_array *base;
+ union ghw_type *base;
int nbr_scalars;
union ghw_range **rngs;
+ union ghw_type *el;
};
struct ghw_subtype_scalar
@@ -243,6 +255,14 @@ struct ghw_subtype_record
struct ghw_record_element *els;
};
+struct ghw_subtype_unbounded_record
+{
+ enum ghdl_rtik kind;
+ const char *name;
+
+ struct ghw_type_record *base;
+};
+
union ghw_type
{
enum ghdl_rtik kind;
@@ -251,10 +271,12 @@ union ghw_type
struct ghw_type_scalar sc;
struct ghw_type_physical ph;
struct ghw_subtype_scalar ss;
- struct ghw_subtype_array sa;
- struct ghw_subtype_record sr;
struct ghw_type_array ar;
struct ghw_type_record rec;
+ struct ghw_subtype_array sa;
+ struct ghw_subtype_unbounded_array sua;
+ struct ghw_subtype_record sr;
+ struct ghw_subtype_unbounded_record sur;
};
union ghw_val
diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb
index cd2400b78..f56c1a921 100644
--- a/src/grt/grt-disp_rti.adb
+++ b/src/grt/grt-disp_rti.adb
@@ -578,12 +578,29 @@ package body Grt.Disp_Rti is
end case;
end Disp_Scalar_Type_Name;
+ function Is_Unbounded (Rti : Ghdl_Rti_Access) return Boolean is
+ begin
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_Array
+ | Ghdl_Rtik_Subtype_Unbounded_Array
+ | Ghdl_Rtik_Type_Unbounded_Record
+ | Ghdl_Rtik_Subtype_Unbounded_Record =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_Unbounded;
+
+ procedure Disp_Type_Composite_Bounds
+ (Def : Ghdl_Rti_Access; Bounds : Address);
+
procedure Disp_Type_Array_Bounds (Def : Ghdl_Rtin_Type_Array_Acc;
Bounds : Address)
is
Rng : Ghdl_Range_Ptr;
Idx_Base : Ghdl_Rti_Access;
Bounds1 : Address;
+ El_Type : Ghdl_Rti_Access;
begin
Bounds1 := Bounds;
Put (" (");
@@ -600,6 +617,10 @@ package body Grt.Disp_Rti is
Disp_Range (stdout, Idx_Base, Rng);
end loop;
Put (")");
+ El_Type := Def.Element;
+ if Is_Unbounded (El_Type) then
+ Disp_Type_Composite_Bounds (El_Type, Bounds1);
+ end if;
end Disp_Type_Array_Bounds;
procedure Disp_Type_Record_Bounds (Def : Ghdl_Rtin_Type_Record_Acc;
@@ -607,40 +628,47 @@ package body Grt.Disp_Rti is
is
El : Ghdl_Rtin_Element_Acc;
El_Layout : Address;
+ El_Type : Ghdl_Rti_Access;
First : Boolean;
begin
Put (" (");
First := True;
for I in 1 .. Def.Nbrel loop
El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1));
- case El.Eltype.Kind is
- when Ghdl_Rtik_Type_Array
- | Ghdl_Rtik_Type_Unbounded_Record =>
- if First then
- First := False;
- else
- Put (", ");
- end if;
- Put (El.Name);
- El_Layout := Layout + El.Layout_Off;
- case El.Eltype.Kind is
- when Ghdl_Rtik_Type_Array =>
- Disp_Type_Array_Bounds
- (To_Ghdl_Rtin_Type_Array_Acc (El.Eltype),
- Array_Layout_To_Bounds (El_Layout));
- when Ghdl_Rtik_Type_Unbounded_Record =>
- Disp_Type_Record_Bounds
- (To_Ghdl_Rtin_Type_Record_Acc (El.Eltype), El_Layout);
- when others =>
- raise Program_Error;
- end case;
- when others =>
- null;
- end case;
+ El_Type := El.Eltype;
+ if Is_Unbounded (El_Type) then
+ if First then
+ First := False;
+ else
+ Put (", ");
+ end if;
+ Put (El.Name);
+ El_Layout := Layout + El.Layout_Off;
+ Disp_Type_Composite_Bounds (El_Type, El_Layout);
+ end if;
end loop;
Put (")");
end Disp_Type_Record_Bounds;
+
+ procedure Disp_Type_Composite_Bounds
+ (Def : Ghdl_Rti_Access; Bounds : Address)
+ is
+ El_Type : constant Ghdl_Rti_Access := Get_Base_Type (Def);
+ begin
+ case El_Type.Kind is
+ when Ghdl_Rtik_Type_Array =>
+ Disp_Type_Array_Bounds
+ (To_Ghdl_Rtin_Type_Array_Acc (El_Type),
+ Array_Layout_To_Bounds (Bounds));
+ when Ghdl_Rtik_Type_Unbounded_Record =>
+ Disp_Type_Record_Bounds
+ (To_Ghdl_Rtin_Type_Record_Acc (El_Type), Bounds);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Disp_Type_Composite_Bounds;
+
procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc;
Bounds_Ptr : Address)
is
@@ -1069,7 +1097,9 @@ package body Grt.Disp_Rti is
Bt := Def.Basetype;
case Bt.Kind is
when Ghdl_Rtik_Type_I32
- | Ghdl_Rtik_Type_F64 =>
+ | Ghdl_Rtik_Type_F64
+ | Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32 =>
declare
Bdef : Ghdl_Rtin_Type_Scalar_Acc;
begin
@@ -1179,6 +1209,24 @@ package body Grt.Disp_Rti is
New_Line;
end Disp_Subtype_Array_Decl;
+ procedure Disp_Subtype_Unbounded_Array_Decl
+ (Def : Ghdl_Rtin_Subtype_Composite_Acc;
+ Ctxt : Rti_Context;
+ Indent : Natural)
+ is
+ pragma Unreferenced (Ctxt);
+ Basetype : constant Ghdl_Rtin_Type_Array_Acc :=
+ To_Ghdl_Rtin_Type_Array_Acc (Def.Basetype);
+ begin
+ Disp_Indent (Indent);
+ Disp_Kind (Def.Common.Kind);
+ Put (": ");
+ Disp_Name (Def.Name);
+ Put (" is ");
+ Disp_Name (Basetype.Name);
+ New_Line;
+ end Disp_Subtype_Unbounded_Array_Decl;
+
procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc;
Ctxt : Rti_Context;
Indent : Natural)
@@ -1316,6 +1364,9 @@ package body Grt.Disp_Rti is
when Ghdl_Rtik_Subtype_Array =>
Disp_Subtype_Array_Decl
(To_Ghdl_Rtin_Subtype_Composite_Acc (Rti), Ctxt, Indent);
+ when Ghdl_Rtik_Subtype_Unbounded_Array =>
+ Disp_Subtype_Unbounded_Array_Decl
+ (To_Ghdl_Rtin_Subtype_Composite_Acc (Rti), Ctxt, Indent);
when Ghdl_Rtik_Type_Access
| Ghdl_Rtik_Type_File =>
Disp_Type_File_Or_Access
diff --git a/src/grt/grt-ghw.ads b/src/grt/grt-ghw.ads
index a605138e7..97a1e997f 100644
--- a/src/grt/grt-ghw.ads
+++ b/src/grt/grt-ghw.ads
@@ -68,7 +68,9 @@ package Grt.Ghw is
Ghw_Rtik_Type_Record : constant Ghw_Rtik := 32;
Ghw_Rtik_Subtype_Scalar : constant Ghw_Rtik := 34;
Ghw_Rtik_Subtype_Array : constant Ghw_Rtik := 35;
+ Ghw_Rtik_Subtype_Unbounded_Array : constant Ghw_Rtik := 37;
Ghw_Rtik_Subtype_Record : constant Ghw_Rtik := 38;
+ Ghw_Rtik_Subtype_Unbounded_Record : constant Ghw_Rtik := 39;
-- Not used in waves
Ghw_Rtik_Subtype_B1 : constant Ghw_Rtik := 41;
diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb
index e02aa8e89..c3273917c 100644
--- a/src/grt/grt-rtis_addr.adb
+++ b/src/grt/grt-rtis_addr.adb
@@ -323,20 +323,37 @@ package body Grt.Rtis_Addr is
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
+ Res : Ghdl_Rti_Access;
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_Rtin_Subtype_Composite_Acc (Atype).Basetype;
- when Ghdl_Rtik_Type_E8
- | Ghdl_Rtik_Type_E32
- | Ghdl_Rtik_Type_B1 =>
- return Atype;
- when others =>
- Internal_Error ("rtis_addr.get_base_type");
- end case;
+ Res := Atype;
+ loop
+ case Res.Kind is
+ when Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64
+ | Ghdl_Rtik_Type_P32
+ | Ghdl_Rtik_Type_P64
+ | Ghdl_Rtik_Type_F64 =>
+ return Res;
+ when Ghdl_Rtik_Subtype_Scalar =>
+ Res := To_Ghdl_Rtin_Subtype_Scalar_Acc (Res).Basetype;
+ when Ghdl_Rtik_Type_Array
+ | Ghdl_Rtik_Type_Record
+ | Ghdl_Rtik_Type_Unbounded_Record =>
+ return Res;
+ when Ghdl_Rtik_Subtype_Array
+ | Ghdl_Rtik_Subtype_Unbounded_Array
+ | Ghdl_Rtik_Subtype_Record
+ | Ghdl_Rtik_Subtype_Unbounded_Record =>
+ Res := To_Ghdl_Rtin_Subtype_Composite_Acc (Res).Basetype;
+ when others =>
+ Internal_Error ("rtis_addr.get_base_type");
+ end case;
+ end loop;
end Get_Base_Type;
function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean is
diff --git a/src/grt/grt-rtis_addr.ads b/src/grt/grt-rtis_addr.ads
index 7bce81b66..77b4e933b 100644
--- a/src/grt/grt-rtis_addr.ads
+++ b/src/grt/grt-rtis_addr.ads
@@ -95,7 +95,7 @@ package Grt.Rtis_Addr is
function Array_Layout_To_Bounds (Layout : Address) return Address;
- -- Return bounds (for arrays) or layout (for recors) of array
+ -- Return bounds (for arrays) or layout (for records) of array
-- layout LAYOUT according to element type EL_RTI.
function Array_Layout_To_Element
(Layout : Address; El_Rti : Ghdl_Rti_Access) return Address;
diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb
index b03d7e0ec..f97f55ac7 100644
--- a/src/grt/grt-waves.adb
+++ b/src/grt/grt-waves.adb
@@ -622,39 +622,6 @@ package body Grt.Waves is
Create_String_Id (Enum.Names (I - 1));
end loop;
end;
- when Ghdl_Rtik_Subtype_Array =>
- declare
- Arr : constant Ghdl_Rtin_Subtype_Composite_Acc :=
- To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
- B_Ctxt : Rti_Context;
- begin
- Create_String_Id (Arr.Name);
- if Rti_Complex_Type (Rti) then
- B_Ctxt := Ctxt;
- else
- B_Ctxt := N_Ctxt;
- end if;
- Create_Type (Arr.Basetype, B_Ctxt);
- end;
- when Ghdl_Rtik_Type_Array =>
- declare
- Arr : constant Ghdl_Rtin_Type_Array_Acc :=
- To_Ghdl_Rtin_Type_Array_Acc (Rti);
- begin
- Create_String_Id (Arr.Name);
- Create_Type (Arr.Element, N_Ctxt);
- for I in 1 .. Arr.Nbr_Dim loop
- Create_Type (Arr.Indexes (I - 1), N_Ctxt);
- end loop;
- end;
- when Ghdl_Rtik_Subtype_Scalar =>
- declare
- Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
- To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
- begin
- Create_String_Id (Sub.Name);
- Create_Type (Sub.Basetype, N_Ctxt);
- end;
when Ghdl_Rtik_Type_I32
| Ghdl_Rtik_Type_I64
| Ghdl_Rtik_Type_F64 =>
@@ -678,6 +645,25 @@ package body Grt.Waves is
Create_String_Id (Unit_Name);
end loop;
end;
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
+ To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
+ begin
+ Create_String_Id (Sub.Name);
+ Create_Type (Sub.Basetype, N_Ctxt);
+ end;
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Arr : constant Ghdl_Rtin_Type_Array_Acc :=
+ To_Ghdl_Rtin_Type_Array_Acc (Rti);
+ begin
+ Create_String_Id (Arr.Name);
+ Create_Type (Arr.Element, N_Ctxt);
+ for I in 1 .. Arr.Nbr_Dim loop
+ Create_Type (Arr.Indexes (I - 1), N_Ctxt);
+ end loop;
+ end;
when Ghdl_Rtik_Type_Record
| Ghdl_Rtik_Type_Unbounded_Record =>
declare
@@ -692,30 +678,22 @@ package body Grt.Waves is
Create_Type (El.Eltype, N_Ctxt);
end loop;
end;
- when Ghdl_Rtik_Subtype_Record =>
- declare
- Rec : constant Ghdl_Rtin_Subtype_Composite_Acc :=
- To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
- begin
- Create_String_Id (Rec.Name);
- Create_Type (Rec.Basetype, N_Ctxt);
- end;
- when Ghdl_Rtik_Subtype_Unbounded_Record
+ when Ghdl_Rtik_Subtype_Array
+ | Ghdl_Rtik_Subtype_Record
+ | Ghdl_Rtik_Subtype_Unbounded_Record
| Ghdl_Rtik_Subtype_Unbounded_Array =>
- -- Only the base type.
declare
- St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
+ Arr : constant Ghdl_Rtin_Subtype_Composite_Acc :=
To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
B_Ctxt : Rti_Context;
begin
+ Create_String_Id (Arr.Name);
if Rti_Complex_Type (Rti) then
B_Ctxt := Ctxt;
else
B_Ctxt := N_Ctxt;
end if;
- Create_Type (St.Basetype, B_Ctxt);
-
--- return;
+ Create_Type (Arr.Basetype, B_Ctxt);
end;
when others =>
Internal_Error ("wave.create_type");
@@ -1235,11 +1213,15 @@ package body Grt.Waves is
return Ghw_Rtik_Subtype_Array;
when Ghdl_Rtik_Type_Array =>
return Ghw_Rtik_Type_Array;
+ when Ghdl_Rtik_Subtype_Unbounded_Array =>
+ return Ghw_Rtik_Subtype_Unbounded_Array;
when Ghdl_Rtik_Type_Record
| Ghdl_Rtik_Type_Unbounded_Record =>
return Ghw_Rtik_Type_Record;
when Ghdl_Rtik_Subtype_Record =>
return Ghw_Rtik_Subtype_Record;
+ when Ghdl_Rtik_Subtype_Unbounded_Record =>
+ return Ghw_Rtik_Subtype_Unbounded_Record;
when Ghdl_Rtik_Subtype_Scalar =>
return Ghw_Rtik_Subtype_Scalar;
when Ghdl_Rtik_Type_I32 =>
@@ -1253,7 +1235,7 @@ package body Grt.Waves is
when Ghdl_Rtik_Type_P64 =>
return Ghw_Rtik_Type_P64;
when others =>
- return Ghw_Rtik_Error;
+ Internal_Error ("waves.ghdl_rtik_to_ghw_rtik: unhandled kind");
end case;
end Ghdl_Rtik_To_Ghw_Rtik;
@@ -1297,45 +1279,64 @@ package body Grt.Waves is
end case;
end Write_Range;
- procedure Write_Array_Bounds (Arr : Ghdl_Rtin_Type_Array_Acc;
- Bounds : Address)
- is
- Rng : Ghdl_Range_Ptr;
- Index_Type : Ghdl_Rti_Access;
- Bounds1 : Address;
- begin
- Bounds1 := Bounds;
- for I in 0 .. Arr.Nbr_Dim - 1 loop
- Index_Type := Get_Base_Type (Arr.Indexes (I));
- Extract_Range (Bounds1, Index_Type, Rng);
- Write_Range (Index_Type, Rng);
- end loop;
- end Write_Array_Bounds;
-
- procedure Write_Record_Bounds (Rec : Ghdl_Rtin_Type_Record_Acc;
- Layout : Address)
+ procedure Write_Composite_Bounds (Rti : Ghdl_Rti_Access; Bounds : Address)
is
- El : Ghdl_Rtin_Element_Acc;
begin
- for I in 1 .. Rec.Nbrel loop
- El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
- case El.Eltype.Kind is
- when Ghdl_Rtik_Type_Array =>
- Write_Array_Bounds
- (To_Ghdl_Rtin_Type_Array_Acc (El.Eltype),
- Array_Layout_To_Bounds (Layout + El.Layout_Off));
- when Ghdl_Rtik_Type_Unbounded_Record =>
- Write_Record_Bounds
- (To_Ghdl_Rtin_Type_Record_Acc (El.Eltype),
- Layout + El.Layout_Off);
- when others =>
- null;
- end case;
- end loop;
- end Write_Record_Bounds;
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_E8
+ | Ghdl_Rtik_Type_E32
+ | Ghdl_Rtik_Type_B1
+ | Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64
+ | Ghdl_Rtik_Type_P32
+ | Ghdl_Rtik_Type_P64
+ | Ghdl_Rtik_Type_F64 =>
+ return;
+ when Ghdl_Rtik_Type_Array =>
+ declare
+ Arr : constant Ghdl_Rtin_Type_Array_Acc :=
+ To_Ghdl_Rtin_Type_Array_Acc (Rti);
+ Rng : Ghdl_Range_Ptr;
+ Index_Type : Ghdl_Rti_Access;
+ Bounds1 : Address;
+ begin
+ Bounds1 := Bounds;
+ for I in 0 .. Arr.Nbr_Dim - 1 loop
+ Index_Type := Get_Base_Type (Arr.Indexes (I));
+ Extract_Range (Bounds1, Index_Type, Rng);
+ Write_Range (Index_Type, Rng);
+ end loop;
+ Bounds1 := Array_Layout_To_Element (Bounds1, Arr.Element);
+ Write_Composite_Bounds (Get_Base_Type (Arr.Element), Bounds1);
+ end;
+ when Ghdl_Rtik_Type_Record =>
+ return;
+ when Ghdl_Rtik_Type_Unbounded_Record =>
+ declare
+ Rec : constant Ghdl_Rtin_Type_Record_Acc :=
+ To_Ghdl_Rtin_Type_Record_Acc (Rti);
+ El : Ghdl_Rtin_Element_Acc;
+ Eltype : Ghdl_Rti_Access;
+ Bounds1 : Address;
+ begin
+ for I in 1 .. Rec.Nbrel loop
+ El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
+ Eltype := Get_Base_Type (El.Eltype);
+ Bounds1 := Array_Layout_To_Element
+ (Bounds + El.Layout_Off, Eltype);
+ Write_Composite_Bounds (Eltype, Bounds1);
+ end loop;
+ end;
+ when others =>
+ Internal_Error ("waves.write_composite_bounds");
+ end case;
+ end Write_Composite_Bounds;
procedure Write_Types
is
+ subtype Ghw_Rtik_Types is Ghw_Rtik
+ range Ghw_Rtik_Type_B2 .. Ghw_Rtik_Subtype_Unbounded_Record;
+ Kind : Ghw_Rtik_Types;
Rti : Ghdl_Rti_Access;
Ctxt : Rti_Context;
begin
@@ -1360,57 +1361,48 @@ package body Grt.Waves is
case Obj_Rti.Obj_Type.Kind is
when Ghdl_Rtik_Type_Array =>
declare
- Arr : constant Ghdl_Rtin_Type_Array_Acc :=
- To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type);
+ Typ : constant Ghdl_Rti_Access := Obj_Rti.Obj_Type;
Addr : Ghdl_Uc_Array_Acc;
- Bounds : Address;
begin
Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Array));
Write_String_Id (null);
- Write_Type_Id (Obj_Rti.Obj_Type, Ctxt);
+ Write_Type_Id (Typ, Ctxt);
Addr := To_Ghdl_Uc_Array_Acc
(Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
- Bounds := Addr.Bounds;
- Write_Array_Bounds (Arr, Bounds);
+ Write_Composite_Bounds (Typ, Addr.Bounds);
end;
when Ghdl_Rtik_Subtype_Unbounded_Array =>
declare
St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
To_Ghdl_Rtin_Subtype_Composite_Acc
(Obj_Rti.Obj_Type);
- Arr : constant Ghdl_Rtin_Type_Array_Acc :=
- To_Ghdl_Rtin_Type_Array_Acc (St.Basetype);
Addr : Ghdl_Uc_Array_Acc;
- Bounds : Address;
begin
Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Array));
Write_String_Id (null);
Write_Type_Id (St.Basetype, Ctxt);
Addr := To_Ghdl_Uc_Array_Acc
(Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
- Bounds := Addr.Bounds;
- Write_Array_Bounds (Arr, Bounds);
+ Write_Composite_Bounds (Get_Base_Type (St.Basetype),
+ Addr.Bounds);
end;
when Ghdl_Rtik_Type_Unbounded_Record =>
declare
- Rec : constant Ghdl_Rtin_Type_Record_Acc :=
- To_Ghdl_Rtin_Type_Record_Acc (Obj_Rti.Obj_Type);
+ Typ : constant Ghdl_Rti_Access := Obj_Rti.Obj_Type;
Addr : Ghdl_Uc_Array_Acc;
begin
Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Record));
Write_String_Id (null);
- Write_Type_Id (Obj_Rti.Obj_Type, Ctxt);
+ Write_Type_Id (Typ, Ctxt);
Addr := To_Ghdl_Uc_Array_Acc
(Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
- Write_Record_Bounds (Rec, Addr.Bounds);
+ Write_Composite_Bounds (Typ, Addr.Bounds);
end;
when Ghdl_Rtik_Subtype_Unbounded_Record =>
declare
St : constant Ghdl_Rtin_Subtype_Composite_Acc :=
To_Ghdl_Rtin_Subtype_Composite_Acc
(Obj_Rti.Obj_Type);
- Rec : constant Ghdl_Rtin_Type_Record_Acc :=
- To_Ghdl_Rtin_Type_Record_Acc (St.Basetype);
Addr : Ghdl_Uc_Array_Acc;
begin
Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Record));
@@ -1418,7 +1410,8 @@ package body Grt.Waves is
Write_Type_Id (St.Basetype, Ctxt);
Addr := To_Ghdl_Uc_Array_Acc
(Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
- Write_Record_Bounds (Rec, Addr.Bounds);
+ Write_Composite_Bounds (Get_Base_Type (St.Basetype),
+ Addr.Bounds);
end;
when others =>
Internal_Error ("waves.write_types: unhandled obj kind");
@@ -1426,7 +1419,8 @@ package body Grt.Waves is
end;
else
-- Kind.
- Wave_Put_Byte (Ghw_Rtik'Pos (Ghdl_Rtik_To_Ghw_Rtik (Rti.Kind)));
+ Kind := Ghdl_Rtik_To_Ghw_Rtik (Rti.Kind);
+ Wave_Put_Byte (Ghw_Rtik_Types'Pos (Kind));
case Rti.Kind is
when Ghdl_Rtik_Type_B1
@@ -1441,22 +1435,64 @@ package body Grt.Waves is
Write_String_Id (Enum.Names (I - 1));
end loop;
end;
- when Ghdl_Rtik_Subtype_Array =>
+ when Ghdl_Rtik_Type_I32
+ | Ghdl_Rtik_Type_I64
+ | Ghdl_Rtik_Type_F64 =>
declare
- Arr : constant Ghdl_Rtin_Subtype_Composite_Acc :=
- To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
+ Base : constant Ghdl_Rtin_Type_Scalar_Acc :=
+ To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
begin
- Write_String_Id (Arr.Name);
- Write_Type_Id (Arr.Basetype, Ctxt);
- declare
- Bt : constant Ghdl_Rtin_Type_Array_Acc :=
- To_Ghdl_Rtin_Type_Array_Acc (Arr.Basetype);
- Layout : Address;
- begin
- Layout := Loc_To_Addr (Rti.Depth, Arr.Layout, Ctxt);
- Write_Array_Bounds
- (Bt, Array_Layout_To_Bounds (Layout));
- end;
+ Write_String_Id (Base.Name);
+ end;
+ when Ghdl_Rtik_Type_P32
+ | Ghdl_Rtik_Type_P64 =>
+ declare
+ Base : constant Ghdl_Rtin_Type_Physical_Acc :=
+ To_Ghdl_Rtin_Type_Physical_Acc (Rti);
+ Unit : Ghdl_Rti_Access;
+ begin
+ Write_String_Id (Base.Name);
+ Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr));
+ for I in 1 .. Base.Nbr loop
+ Unit := Base.Units (I - 1);
+ Write_String_Id
+ (Rtis_Utils.Get_Physical_Unit_Name (Unit));
+ case Unit.Kind is
+ when Ghdl_Rtik_Unit64 =>
+ Wave_Put_LSLEB128
+ (To_Ghdl_Rtin_Unit64_Acc (Unit).Value);
+ when Ghdl_Rtik_Unitptr =>
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_P64 =>
+ Wave_Put_LSLEB128
+ (To_Ghdl_Rtin_Unitptr_Acc (Unit).
+ Addr.I64);
+ when Ghdl_Rtik_Type_P32 =>
+ Wave_Put_SLEB128
+ (To_Ghdl_Rtin_Unitptr_Acc (Unit).
+ Addr.I32);
+ when others =>
+ Internal_Error
+ ("wave.write_types(P32/P64-1)");
+ end case;
+ when others =>
+ Internal_Error
+ ("wave.write_types(P32/P64-2)");
+ end case;
+ end loop;
+ end;
+ when Ghdl_Rtik_Subtype_Scalar =>
+ declare
+ Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
+ To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
+ begin
+ Write_String_Id (Sub.Name);
+ Write_Type_Id (Sub.Basetype, Ctxt);
+ Write_Range
+ (Sub.Basetype,
+ To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth,
+ Sub.Range_Loc,
+ Ctxt)));
end;
when Ghdl_Rtik_Type_Array =>
declare
@@ -1470,6 +1506,18 @@ package body Grt.Waves is
Write_Type_Id (Arr.Indexes (I - 1), Ctxt);
end loop;
end;
+ when Ghdl_Rtik_Subtype_Array =>
+ declare
+ Arr : constant Ghdl_Rtin_Subtype_Composite_Acc :=
+ To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
+ Layout : Address;
+ begin
+ Write_String_Id (Arr.Name);
+ Write_Type_Id (Arr.Basetype, Ctxt);
+ Layout := Loc_To_Addr (Rti.Depth, Arr.Layout, Ctxt);
+ Write_Composite_Bounds (Get_Base_Type (Arr.Basetype),
+ Array_Layout_To_Bounds (Layout));
+ end;
when Ghdl_Rtik_Type_Record
| Ghdl_Rtik_Type_Unbounded_Record =>
declare
@@ -1489,16 +1537,16 @@ package body Grt.Waves is
declare
Rec : constant Ghdl_Rtin_Subtype_Composite_Acc :=
To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
- Base : constant Ghdl_Rtin_Type_Record_Acc :=
- To_Ghdl_Rtin_Type_Record_Acc (Rec.Basetype);
+ Base : Ghdl_Rti_Access;
Layout : Address;
begin
Write_String_Id (Rec.Name);
Write_Type_Id (Rec.Basetype, Ctxt);
- if Base.Common.Kind = Ghdl_Rtik_Type_Unbounded_Record then
+ Base := Get_Base_Type (Rec.Basetype);
+ if Base.Kind = Ghdl_Rtik_Type_Unbounded_Record then
Layout := Loc_To_Addr
(Rec.Common.Depth, Rec.Layout, Ctxt);
- Write_Record_Bounds (Base, Layout);
+ Write_Composite_Bounds (Base, Layout);
end if;
end;
when Ghdl_Rtik_Subtype_Unbounded_Record
@@ -1510,65 +1558,6 @@ package body Grt.Waves is
Write_String_Id (Rec.Name);
Write_Type_Id (Rec.Basetype, Ctxt);
end;
- when Ghdl_Rtik_Subtype_Scalar =>
- declare
- Sub : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
- To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti);
- begin
- Write_String_Id (Sub.Name);
- Write_Type_Id (Sub.Basetype, Ctxt);
- Write_Range
- (Sub.Basetype,
- To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth,
- Sub.Range_Loc,
- Ctxt)));
- end;
- when Ghdl_Rtik_Type_I32
- | Ghdl_Rtik_Type_I64
- | Ghdl_Rtik_Type_F64 =>
- declare
- Base : constant Ghdl_Rtin_Type_Scalar_Acc :=
- To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
- begin
- Write_String_Id (Base.Name);
- end;
- when Ghdl_Rtik_Type_P32
- | Ghdl_Rtik_Type_P64 =>
- declare
- Base : constant Ghdl_Rtin_Type_Physical_Acc :=
- To_Ghdl_Rtin_Type_Physical_Acc (Rti);
- Unit : Ghdl_Rti_Access;
- begin
- Write_String_Id (Base.Name);
- Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr));
- for I in 1 .. Base.Nbr loop
- Unit := Base.Units (I - 1);
- Write_String_Id
- (Rtis_Utils.Get_Physical_Unit_Name (Unit));
- case Unit.Kind is
- when Ghdl_Rtik_Unit64 =>
- Wave_Put_LSLEB128
- (To_Ghdl_Rtin_Unit64_Acc (Unit).Value);
- when Ghdl_Rtik_Unitptr =>
- case Rti.Kind is
- when Ghdl_Rtik_Type_P64 =>
- Wave_Put_LSLEB128
- (To_Ghdl_Rtin_Unitptr_Acc (Unit).
- Addr.I64);
- when Ghdl_Rtik_Type_P32 =>
- Wave_Put_SLEB128
- (To_Ghdl_Rtin_Unitptr_Acc (Unit).
- Addr.I32);
- when others =>
- Internal_Error
- ("wave.write_types(P32/P64-1)");
- end case;
- when others =>
- Internal_Error
- ("wave.write_types(P32/P64-2)");
- end case;
- end loop;
- end;
when others =>
Internal_Error ("wave.write_types");
-- Internal_Error ("wave.write_types: does not handle " &
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 03:06:06 +0000