aboutsummaryrefslogtreecommitdiffstats
path: root/src/grt
diff options
context:
space:
mode:
Diffstat (limited to 'src/grt')
-rw-r--r--src/grt/ghwlib.c267
-rw-r--r--src/grt/ghwlib.h12
-rw-r--r--src/grt/grt-disp_rti.adb3
-rw-r--r--src/grt/grt-rtis.ads40
-rw-r--r--src/grt/grt-waves.adb145
5 files changed, 337 insertions, 130 deletions
diff --git a/src/grt/ghwlib.c b/src/grt/ghwlib.c
index 7c5b80bd0..ddfab6b57 100644
--- a/src/grt/ghwlib.c
+++ b/src/grt/ghwlib.c
@@ -391,7 +391,8 @@ ghw_get_base_type (union ghw_type *t)
}
}
-int
+/* Return -1 for unbounded types. */
+static int
get_nbr_elements (union ghw_type *t)
{
switch (t->kind)
@@ -406,20 +407,21 @@ get_nbr_elements (union ghw_type *t)
case ghdl_rtik_type_p64:
case ghdl_rtik_subtype_scalar:
return 1;
+ case ghdl_rtik_type_array:
+ return -1;
case ghdl_rtik_subtype_array:
- case ghdl_rtik_subtype_array_ptr:
- return t->sa.nbr_el;
+ return t->sa.nbr_scalars;
case ghdl_rtik_type_record:
- return t->rec.nbr_el;
+ return t->rec.nbr_scalars;
case ghdl_rtik_subtype_record:
- return t->sr.base->nbr_el;
+ return t->sr.nbr_scalars;
default:
fprintf (stderr, "get_nbr_elements: unhandled type %d\n", t->kind);
abort ();
}
}
-int
+static int
get_range_length (union ghw_range *rng)
{
switch (rng->kind)
@@ -445,6 +447,91 @@ get_range_length (union ghw_range *rng)
}
}
+/* 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)
+{
+ struct ghw_subtype_array *sa;
+ int j;
+ int nbr_scalars;
+
+ 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++)
+ {
+ sa->rngs[j] = ghw_read_range (h);
+ nbr_scalars *= get_range_length (sa->rngs[j]);
+ }
+ sa->nbr_scalars = nbr_scalars;
+ return sa;
+}
+
+struct ghw_subtype_record *
+ghw_read_record_subtype (struct ghw_handler *h, struct ghw_type_record *base)
+{
+ struct ghw_subtype_record *sr;
+
+ sr = malloc (sizeof (struct ghw_subtype_record));
+ sr->kind = ghdl_rtik_subtype_record;
+ sr->name = NULL;
+ sr->base = base;
+ if (base->nbr_scalars >= 0)
+ {
+ /* Record base type is bounded. */
+ sr->nbr_scalars = base->nbr_scalars;
+ sr->els = base->els;
+ }
+ else
+ {
+ /* Read subtypes. */
+ int j;
+ int nbr_scalars;
+
+ sr->els = malloc (base->nbr_fields * sizeof (struct ghw_record_element));
+ nbr_scalars = 0;
+ for (j = 0; j < base->nbr_fields; j++)
+ {
+ union ghw_type *btype = base->els[j].type;
+ int el_nbr_scalars = get_nbr_elements (btype);
+
+ sr->els[j].name = base->els[j].name;
+ if (el_nbr_scalars >= 0)
+ {
+ /* Element is constrained. */
+ sr->els[j].type = btype;
+ }
+ 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;
+ }
+ el_nbr_scalars = get_nbr_elements (sr->els[j].type);
+ }
+ nbr_scalars += el_nbr_scalars;
+ }
+ sr->nbr_scalars = nbr_scalars;
+ }
+ return sr;
+}
+
int
ghw_read_type (struct ghw_handler *h)
{
@@ -574,66 +661,71 @@ ghw_read_type (struct ghw_handler *h)
}
break;
case ghdl_rtik_subtype_array:
- case ghdl_rtik_subtype_array_ptr:
{
struct ghw_subtype_array *sa;
- int j;
- int nbr_el;
+ const char *name;
+ struct ghw_type_array *base;
- sa = malloc (sizeof (struct ghw_subtype_array));
- sa->kind = t;
- sa->name = ghw_read_strid (h);
- sa->base = (struct ghw_type_array *)ghw_read_typeid (h);
- nbr_el = get_nbr_elements (sa->base->el);
- sa->rngs = malloc (sa->base->nbr_dim * sizeof (union ghw_range *));
- for (j = 0; j < sa->base->nbr_dim; j++)
- {
- sa->rngs[j] = ghw_read_range (h);
- nbr_el *= get_range_length (sa->rngs[j]);
- }
- sa->nbr_el = nbr_el;
- if (h->flag_verbose > 1)
- printf ("subtype array: %s (nbr_el=%d)\n", sa->name, sa->nbr_el);
+ name = ghw_read_strid (h);
+ base = (struct ghw_type_array *)ghw_read_typeid (h);
+
+ sa = ghw_read_array_subtype (h, base);
+ sa->name = name;
h->types[i] = (union ghw_type *)sa;
+ if (h->flag_verbose > 1)
+ printf ("subtype array: %s (nbr_scalars=%d)\n",
+ sa->name, sa->nbr_scalars);
}
break;
case ghdl_rtik_type_record:
{
struct ghw_type_record *rec;
int j;
- int nbr_el;
+ int nbr_scalars;
rec = malloc (sizeof (struct ghw_type_record));
rec->kind = t;
rec->name = ghw_read_strid (h);
if (ghw_read_uleb128 (h, &rec->nbr_fields) != 0)
return -1;
- rec->el = malloc
+ rec->els = malloc
(rec->nbr_fields * sizeof (struct ghw_record_element));
- nbr_el = 0;
+ nbr_scalars = 0;
for (j = 0; j < rec->nbr_fields; j++)
{
- rec->el[j].name = ghw_read_strid (h);
- rec->el[j].type = ghw_read_typeid (h);
- nbr_el += get_nbr_elements (rec->el[j].type);
+ rec->els[j].name = ghw_read_strid (h);
+ rec->els[j].type = ghw_read_typeid (h);
+ if (nbr_scalars != -1)
+ {
+ int field_nbr_scalars = get_nbr_elements (rec->els[j].type);
+ if (field_nbr_scalars == -1)
+ nbr_scalars = -1;
+ else
+ nbr_scalars += field_nbr_scalars;
+ }
}
- rec->nbr_el = nbr_el;
+ rec->nbr_scalars = nbr_scalars;
if (h->flag_verbose > 1)
- printf ("record type: %s (nbr_el=%d)\n", rec->name, rec->nbr_el);
+ printf ("record type: %s (nbr_scalars=%d)\n",
+ rec->name, rec->nbr_scalars);
h->types[i] = (union ghw_type *)rec;
}
break;
case ghdl_rtik_subtype_record:
{
struct ghw_subtype_record *sr;
+ const char *name;
+ struct ghw_type_record *base;
- sr = malloc (sizeof (struct ghw_subtype_record));
- sr->kind = t;
- sr->name = ghw_read_strid (h);
- sr->base = (struct ghw_type_record *)ghw_read_typeid (h);
- if (h->flag_verbose > 1)
- printf ("subtype record: %s\n", sr->name);
+ name = ghw_read_strid (h);
+ base = (struct ghw_type_record *)ghw_read_typeid (h);
+
+ sr = ghw_read_record_subtype (h, base);
+ sr->name = name;
h->types[i] = (union ghw_type *)sr;
+ if (h->flag_verbose > 1)
+ printf ("subtype record: %s (nbr_scalars=%d)\n",
+ sr->name, sr->nbr_scalars);
}
break;
default:
@@ -710,13 +802,12 @@ ghw_read_signal (struct ghw_handler *h, unsigned int *sigs, union ghw_type *t)
}
return 0;
case ghdl_rtik_subtype_array:
- case ghdl_rtik_subtype_array_ptr:
{
int i;
int stride;
int len;
- len = t->sa.nbr_el;
+ len = t->sa.nbr_scalars;
stride = get_nbr_elements (t->sa.base->el);
for (i = 0; i < len; i += stride)
@@ -726,20 +817,36 @@ ghw_read_signal (struct ghw_handler *h, unsigned int *sigs, union ghw_type *t)
return 0;
case ghdl_rtik_type_record:
{
+ struct ghw_type_record *r = &t->rec;
+ int nbr_fields = r->nbr_fields;
int i;
int off;
off = 0;
- for (i = 0; i < t->rec.nbr_fields; i++)
+ for (i = 0; i < nbr_fields; i++)
{
- if (ghw_read_signal (h, &sigs[off], t->rec.el[i].type) < 0)
+ if (ghw_read_signal (h, &sigs[off], r->els[i].type) < 0)
return -1;
- off += get_nbr_elements (t->rec.el[i].type);
+ off += get_nbr_elements (r->els[i].type);
}
}
return 0;
case ghdl_rtik_subtype_record:
- return ghw_read_signal (h, sigs, (union ghw_type *)t->sr.base);
+ {
+ struct ghw_subtype_record *sr = &t->sr;
+ int nbr_fields = sr->base->nbr_fields;
+ int i;
+ int off;
+
+ off = 0;
+ for (i = 0; i < nbr_fields; i++)
+ {
+ if (ghw_read_signal (h, &sigs[off], sr->els[i].type) < 0)
+ return -1;
+ off += get_nbr_elements (sr->els[i].type);
+ }
+ }
+ return 0;
default:
fprintf (stderr, "ghw_read_signal: type kind %d unhandled\n", t->kind);
abort ();
@@ -1765,6 +1872,57 @@ ghw_disp_range (union ghw_type *type, union ghw_range *rng)
}
static void
+ghw_disp_array_subtype_bounds (struct ghw_subtype_array *a)
+{
+ int i;
+
+ printf (" (");
+ for (i = 0; i < a->base->nbr_dim; i++)
+ {
+ if (i != 0)
+ printf (", ");
+ ghw_disp_range (a->base->dims[i], a->rngs[i]);
+ }
+ printf (")");
+}
+
+static void
+ghw_disp_record_subtype_bounds (struct ghw_subtype_record *sr)
+{
+ struct ghw_type_record *base = sr->base;
+ int is_first = 1;
+ int i;
+
+ for (i = 0; i < base->nbr_fields; i++)
+ {
+ if (sr->els[i].type != base->els[i].type)
+ {
+ if (is_first)
+ {
+ printf ("(");
+ is_first = 0;
+ }
+ else
+ printf (", ");
+ printf ("%s", base->els[i].name);
+ switch (sr->els[i].type->kind)
+ {
+ case ghdl_rtik_subtype_array:
+ ghw_disp_array_subtype_bounds (&sr->els[i].type->sa);
+ break;
+ case ghdl_rtik_subtype_record:
+ ghw_disp_record_subtype_bounds (&sr->els[i].type->sr);
+ break;
+ default:
+ printf ("??? (%d)", sr->els[i].type->kind);
+ }
+ }
+ }
+ if (!is_first)
+ printf (")");
+}
+
+static void
ghw_disp_subtype_definition (struct ghw_handler *h, union ghw_type *t)
{
switch (t->kind)
@@ -1778,24 +1936,20 @@ ghw_disp_subtype_definition (struct ghw_handler *h, union ghw_type *t)
}
break;
case ghdl_rtik_subtype_array:
- case ghdl_rtik_subtype_array_ptr:
{
struct ghw_subtype_array *a = &t->sa;
- int i;
ghw_disp_typename (h, (union ghw_type *)a->base);
- printf (" (");
- for (i = 0; i < a->base->nbr_dim; i++)
- {
- if (i != 0)
- printf (", ");
- ghw_disp_range (a->base->dims[i], a->rngs[i]);
- }
- printf (")");
+ ghw_disp_array_subtype_bounds (a);
}
break;
case ghdl_rtik_subtype_record:
- ghw_disp_typename (h, (union ghw_type *)t->sr.base);
+ {
+ struct ghw_subtype_record *sr = &t->sr;
+
+ ghw_disp_typename (h, (union ghw_type *)sr->base);
+ ghw_disp_record_subtype_bounds (sr);
+ }
break;
default:
printf ("ghw_disp_subtype_definition: unhandled type kind %d\n",
@@ -1893,15 +2047,14 @@ ghw_disp_type (struct ghw_handler *h, union ghw_type *t)
printf ("type %s is record\n", r->name);
for (i = 0; i < r->nbr_fields; i++)
{
- printf (" %s: ", r->el[i].name);
- ghw_disp_subtype_indication (h, r->el[i].type);
+ printf (" %s: ", r->els[i].name);
+ ghw_disp_subtype_indication (h, r->els[i].type);
printf (";\n");
}
printf ("end record;\n");
}
break;
case ghdl_rtik_subtype_array:
- case ghdl_rtik_subtype_array_ptr:
case ghdl_rtik_subtype_scalar:
case ghdl_rtik_subtype_record:
{
diff --git a/src/grt/ghwlib.h b/src/grt/ghwlib.h
index 6f65d6ba8..5ee05953a 100644
--- a/src/grt/ghwlib.h
+++ b/src/grt/ghwlib.h
@@ -65,8 +65,8 @@ enum ghdl_rtik {
ghdl_rtik_type_file,
ghdl_rtik_subtype_scalar,
ghdl_rtik_subtype_array, /* 35 */
- ghdl_rtik_subtype_array_ptr,
- ghdl_rtik_subtype_unconstrained_array,
+ ghdl_rtik_subtype_array_ptr, /* Obsolete. */
+ ghdl_rtik_subtype_unconstrained_array, /* Obsolete. */
ghdl_rtik_subtype_record,
ghdl_rtik_subtype_access,
ghdl_rtik_type_protected,
@@ -191,7 +191,7 @@ struct ghw_subtype_array
const char *name;
struct ghw_type_array *base;
- int nbr_el;
+ int nbr_scalars;
union ghw_range **rngs;
};
@@ -216,8 +216,8 @@ struct ghw_type_record
const char *name;
unsigned int nbr_fields;
- int nbr_el; /* Number of scalar signals. */
- struct ghw_record_element *el;
+ int nbr_scalars; /* Number of scalar elements (ie nbr of signals). */
+ struct ghw_record_element *els;
};
struct ghw_subtype_record
@@ -226,6 +226,8 @@ struct ghw_subtype_record
const char *name;
struct ghw_type_record *base;
+ int nbr_scalars; /* Number of scalar elements (ie nbr of signals). */
+ struct ghw_record_element *els;
};
union ghw_type
diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb
index 898300c26..9ce17ed91 100644
--- a/src/grt/grt-disp_rti.adb
+++ b/src/grt/grt-disp_rti.adb
@@ -1260,7 +1260,8 @@ package body Grt.Disp_Rti is
| Ghdl_Rtik_Type_Unbounded_Record =>
Disp_Type_Record
(To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent);
- when Ghdl_Rtik_Subtype_Record =>
+ when Ghdl_Rtik_Subtype_Record
+ | Ghdl_Rtik_Subtype_Unbounded_Record =>
Disp_Subtype_Record_Decl
(To_Ghdl_Rtin_Subtype_Composite_Acc (Rti), Ctxt, Indent);
when Ghdl_Rtik_Type_Protected =>
diff --git a/src/grt/grt-rtis.ads b/src/grt/grt-rtis.ads
index 685df3eae..afe9676c6 100644
--- a/src/grt/grt-rtis.ads
+++ b/src/grt/grt-rtis.ads
@@ -45,7 +45,7 @@ package Grt.Rtis is
Ghdl_Rtik_If_Generate,
Ghdl_Rtik_Case_Generate,
- Ghdl_Rtik_For_Generate, -- 10
+ Ghdl_Rtik_For_Generate, -- 10
Ghdl_Rtik_Generate_Body,
Ghdl_Rtik_Instance,
Ghdl_Rtik_Constant,
@@ -57,33 +57,33 @@ package Grt.Rtis is
Ghdl_Rtik_Port,
Ghdl_Rtik_Generic,
- Ghdl_Rtik_Alias, -- 20
+ Ghdl_Rtik_Alias, -- 20
Ghdl_Rtik_Guard,
Ghdl_Rtik_Component,
Ghdl_Rtik_Attribute,
- Ghdl_Rtik_Type_B1, -- Enum
+ Ghdl_Rtik_Type_B1, -- Rtin_Type_Enum
- Ghdl_Rtik_Type_E8,
+ Ghdl_Rtik_Type_E8, -- Rtin_Type_Enum
Ghdl_Rtik_Type_E32,
- Ghdl_Rtik_Type_I32, -- Scalar
- Ghdl_Rtik_Type_I64,
- Ghdl_Rtik_Type_F64,
-
- Ghdl_Rtik_Type_P32, -- 30
- Ghdl_Rtik_Type_P64,
- Ghdl_Rtik_Type_Access,
- Ghdl_Rtik_Type_Array,
- Ghdl_Rtik_Type_Record,
-
- Ghdl_Rtik_Type_Unbounded_Record,
- Ghdl_Rtik_Type_File,
- Ghdl_Rtik_Subtype_Scalar,
- Ghdl_Rtik_Subtype_Array,
+ Ghdl_Rtik_Type_I32, -- Rtin_Type_Scalar
+ Ghdl_Rtik_Type_I64, -- Rtin_Type_Scalar
+ Ghdl_Rtik_Type_F64, -- Rtin_Type_Scalar
+
+ Ghdl_Rtik_Type_P32, -- 30 -- Rtin_Type_Physical
+ Ghdl_Rtik_Type_P64, -- Rtin_Type_Physical
+ Ghdl_Rtik_Type_Access, -- Rtin_Type_Fileacc
+ Ghdl_Rtik_Type_Array, -- Rtin_Type_Array
+ Ghdl_Rtik_Type_Record, -- Rtin_Type_Record
+
+ Ghdl_Rtik_Type_Unbounded_Record, -- Rtin_Type_Record
+ Ghdl_Rtik_Type_File, -- Rtin_Type_Fileacc
+ Ghdl_Rtik_Subtype_Scalar, -- Rtin_Subtype_Scalar
+ Ghdl_Rtik_Subtype_Array, -- Rtin_Subtype_Composite
Ghdl_Rtik_Subtype_Unconstrained_Array,
- Ghdl_Rtik_Subtype_Record, -- 40
+ Ghdl_Rtik_Subtype_Record, -- 40 -- Rtin_Subtype_Composite
Ghdl_Rtik_Subtype_Unbounded_Record,
- Ghdl_Rtik_Subtype_Access,
+ Ghdl_Rtik_Subtype_Access, -- Rtin_Type_Fileacc
Ghdl_Rtik_Type_Protected,
Ghdl_Rtik_Element,
diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb
index 025f2195e..2fbfccf2a 100644
--- a/src/grt/grt-waves.adb
+++ b/src/grt/grt-waves.adb
@@ -613,9 +613,9 @@ package body Grt.Waves is
when Ghdl_Rtik_Type_B1
| Ghdl_Rtik_Type_E8 =>
declare
- Enum : Ghdl_Rtin_Type_Enum_Acc;
+ Enum : constant Ghdl_Rtin_Type_Enum_Acc :=
+ To_Ghdl_Rtin_Type_Enum_Acc (Rti);
begin
- Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti);
Create_String_Id (Enum.Name);
for I in 1 .. Enum.Nbr loop
Create_String_Id (Enum.Names (I - 1));
@@ -658,18 +658,18 @@ package body Grt.Waves is
| Ghdl_Rtik_Type_I64
| Ghdl_Rtik_Type_F64 =>
declare
- Base : Ghdl_Rtin_Type_Scalar_Acc;
+ Base : constant Ghdl_Rtin_Type_Scalar_Acc :=
+ To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
begin
- Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti);
Create_String_Id (Base.Name);
end;
when Ghdl_Rtik_Type_P32
| Ghdl_Rtik_Type_P64 =>
declare
- Base : Ghdl_Rtin_Type_Physical_Acc;
+ Base : constant Ghdl_Rtin_Type_Physical_Acc :=
+ To_Ghdl_Rtin_Type_Physical_Acc (Rti);
Unit_Name : Ghdl_C_String;
begin
- Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti);
Create_String_Id (Base.Name);
for I in 1 .. Base.Nbr loop
Unit_Name :=
@@ -677,12 +677,13 @@ package body Grt.Waves is
Create_String_Id (Unit_Name);
end loop;
end;
- when Ghdl_Rtik_Type_Record =>
+ when Ghdl_Rtik_Type_Record
+ | Ghdl_Rtik_Type_Unbounded_Record =>
declare
- Rec : Ghdl_Rtin_Type_Record_Acc;
+ Rec : constant Ghdl_Rtin_Type_Record_Acc :=
+ To_Ghdl_Rtin_Type_Record_Acc (Rti);
El : Ghdl_Rtin_Element_Acc;
begin
- Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti);
Create_String_Id (Rec.Name);
for I in 1 .. Rec.Nbrel loop
El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1));
@@ -723,12 +724,16 @@ package body Grt.Waves is
Rti := Avhpi_Get_Rti (Obj_Type);
Create_Type (Rti, Avhpi_Get_Context (Obj_Type));
- -- The the signal type is an unconstrained array, also put the object
- -- in the type AVL.
+ -- The the signal type is an unbounded type, also put the object
+ -- in the type AVL. This is for unbounded ports.
-- The real type will be written to the file.
- if Rti.Kind = Ghdl_Rtik_Type_Array then
- Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
- end if;
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_Array
+ | Ghdl_Rtik_Type_Unbounded_Record =>
+ Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
+ when others =>
+ null;
+ end case;
end Create_Object_Type;
procedure Write_Object_Type (Obj : VhpiHandleT)
@@ -744,11 +749,13 @@ package body Grt.Waves is
return;
end if;
Rti := Avhpi_Get_Rti (Obj_Type);
- if Rti.Kind = Ghdl_Rtik_Type_Array then
- Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
- else
- Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type));
- end if;
+ case Rti.Kind is
+ when Ghdl_Rtik_Type_Array
+ | Ghdl_Rtik_Type_Unbounded_Record =>
+ Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj));
+ when others =>
+ Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type));
+ end case;
end Write_Object_Type;
procedure Create_Generate_Type (Gen : VhpiHandleT)
@@ -1206,7 +1213,8 @@ package body Grt.Waves is
return Ghw_Rtik_Subtype_Array;
when Ghdl_Rtik_Type_Array =>
return Ghw_Rtik_Type_Array;
- when Ghdl_Rtik_Type_Record =>
+ 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;
@@ -1267,17 +1275,52 @@ package body Grt.Waves is
end case;
end Write_Range;
+ procedure Write_Array_Bounds (Arr : Ghdl_Rtin_Type_Array_Acc;
+ Bounds : in out Address)
+ is
+ Rng : Ghdl_Range_Ptr;
+ Index_Type : Ghdl_Rti_Access;
+ begin
+ for I in 0 .. Arr.Nbr_Dim - 1 loop
+ Index_Type := Get_Base_Type (Arr.Indexes (I));
+ Extract_Range (Bounds, Index_Type, Rng);
+ Write_Range (Index_Type, Rng);
+ end loop;
+ end Write_Array_Bounds;
+
+ procedure Write_Record_Bounds (Rec : Ghdl_Rtin_Type_Record_Acc;
+ Bounds : in out 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), Bounds);
+ when Ghdl_Rtik_Type_Unbounded_Record =>
+ Write_Record_Bounds
+ (To_Ghdl_Rtin_Type_Record_Acc (El.Eltype), Bounds);
+ when others =>
+ null;
+ end case;
+ end loop;
+ end Write_Record_Bounds;
+
procedure Write_Types
is
Rti : Ghdl_Rti_Access;
Ctxt : Rti_Context;
begin
+ -- Types header.
Wave_Section ("TYP" & NUL);
Wave_Put_Byte (0);
Wave_Put_Byte (0);
Wave_Put_Byte (0);
Wave_Put_Byte (0);
Wave_Put_I32 (Ghdl_I32 (Types_Table.Last));
+
for I in Types_Table.First .. Types_Table.Last loop
Rti := Types_Table.Table (I).Type_Rti;
Ctxt := Types_Table.Table (I).Context;
@@ -1286,23 +1329,26 @@ package body Grt.Waves is
declare
Obj_Rti : constant Ghdl_Rtin_Object_Acc :=
To_Ghdl_Rtin_Object_Acc (Rti);
- Arr : constant Ghdl_Rtin_Type_Array_Acc :=
- To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type);
- Addr : Ghdl_Uc_Array_Acc;
begin
- Wave_Put_Byte (Ghw_Rtik'Pos (Ghw_Rtik_Subtype_Array));
- Write_String_Id (null);
- Write_Type_Id (Obj_Rti.Obj_Type, Ctxt);
- Addr := To_Ghdl_Uc_Array_Acc
- (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
- declare
- Rngs : Ghdl_Range_Array (0 .. Arr.Nbr_Dim - 1);
- begin
- Bound_To_Range (Addr.Bounds, Arr, Rngs);
- for I in Rngs'Range loop
- Write_Range (Arr.Indexes (I), Rngs (I));
- end loop;
- end;
+ 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);
+ 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);
+ Addr := To_Ghdl_Uc_Array_Acc
+ (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt));
+ Bounds := Addr.Bounds;
+ Write_Array_Bounds (Arr, Bounds);
+ end;
+ when others =>
+ Internal_Error ("waves.write_types: unhandled obj kind");
+ end case;
end;
else
-- Kind.
@@ -1331,14 +1377,10 @@ package body Grt.Waves is
declare
Bt : constant Ghdl_Rtin_Type_Array_Acc :=
To_Ghdl_Rtin_Type_Array_Acc (Arr.Basetype);
- Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+ Bounds : Address;
begin
- Bound_To_Range
- (Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt),
- Bt, Rngs);
- for I in Rngs'Range loop
- Write_Range (Bt.Indexes (I), Rngs (I));
- end loop;
+ Bounds := Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt);
+ Write_Array_Bounds (Bt, Bounds);
end;
end;
when Ghdl_Rtik_Type_Array =>
@@ -1353,7 +1395,8 @@ package body Grt.Waves is
Write_Type_Id (Arr.Indexes (I - 1), Ctxt);
end loop;
end;
- when Ghdl_Rtik_Type_Record =>
+ when Ghdl_Rtik_Type_Record
+ | Ghdl_Rtik_Type_Unbounded_Record =>
declare
Rec : constant Ghdl_Rtin_Type_Record_Acc :=
To_Ghdl_Rtin_Type_Record_Acc (Rti);
@@ -1369,11 +1412,19 @@ package body Grt.Waves is
end;
when Ghdl_Rtik_Subtype_Record =>
declare
- Arr : constant Ghdl_Rtin_Subtype_Composite_Acc :=
+ 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);
+ Bounds : Address;
begin
- Write_String_Id (Arr.Name);
- Write_Type_Id (Arr.Basetype, Ctxt);
+ Write_String_Id (Rec.Name);
+ Write_Type_Id (Rec.Basetype, Ctxt);
+ if Base.Common.Kind = Ghdl_Rtik_Type_Unbounded_Record then
+ Bounds := Loc_To_Addr
+ (Rec.Common.Depth, Rec.Bounds, Ctxt);
+ Write_Record_Bounds (Base, Bounds);
+ end if;
end;
when Ghdl_Rtik_Subtype_Scalar =>
declare
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 13:20:42 +0000