aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--src/grt/grt-avhpi.adb35
-rw-r--r--src/grt/grt-disp_rti.adb76
-rw-r--r--src/grt/grt-rtis.ads18
-rw-r--r--src/grt/grt-rtis_addr.adb5
-rw-r--r--src/grt/grt-rtis_addr.ads6
-rw-r--r--src/grt/grt-rtis_utils.adb92
-rw-r--r--src/grt/grt-rtis_utils.ads10
-rw-r--r--src/grt/grt-types.ads10
-rw-r--r--src/grt/grt-vcd.adb3
-rw-r--r--src/grt/grt-waves.adb21
-rw-r--r--src/ortho/debug/ortho_debug-disp.adb23
-rw-r--r--src/ortho/debug/ortho_debug.adb74
-rw-r--r--src/ortho/debug/ortho_debug.private.ads41
-rw-r--r--src/ortho/gcc/ortho_gcc.adb11
-rw-r--r--src/ortho/gcc/ortho_gcc.ads22
-rw-r--r--src/ortho/gcc/ortho_gcc.private.ads2
-rw-r--r--src/ortho/llvm-nodebug/ortho_llvm.adb66
-rw-r--r--src/ortho/llvm-nodebug/ortho_llvm.private.ads7
-rw-r--r--src/ortho/llvm/ortho_llvm.adb67
-rw-r--r--src/ortho/llvm/ortho_llvm.ads27
-rw-r--r--src/ortho/llvm/ortho_llvm.private.ads7
-rw-r--r--src/ortho/llvm4-nodebug/ortho_llvm.adb66
-rw-r--r--src/ortho/llvm4-nodebug/ortho_llvm.ads27
-rw-r--r--src/ortho/llvm4-nodebug/ortho_llvm.private.ads7
-rw-r--r--src/ortho/mcode/ortho_code-consts.adb138
-rw-r--r--src/ortho/mcode/ortho_code-consts.ads21
-rw-r--r--src/ortho/mcode/ortho_code-decls.ads72
-rw-r--r--src/ortho/mcode/ortho_code-disps.adb8
-rw-r--r--src/ortho/mcode/ortho_code-exprs.adb36
-rw-r--r--src/ortho/mcode/ortho_code-exprs.ads14
-rw-r--r--src/ortho/mcode/ortho_code-types.ads3
-rw-r--r--src/ortho/mcode/ortho_code-x86-abi.adb16
-rw-r--r--src/ortho/mcode/ortho_code-x86-emits.adb27
-rw-r--r--src/ortho/mcode/ortho_code-x86-insns.adb8
-rw-r--r--src/ortho/mcode/ortho_code.ads4
-rw-r--r--src/ortho/mcode/ortho_mcode.adb24
-rw-r--r--src/ortho/mcode/ortho_mcode.ads22
-rw-r--r--src/ortho/mcode/ortho_mcode.private.ads2
-rw-r--r--src/ortho/oread/ortho_front.adb59
-rw-r--r--src/ortho/ortho_nodes.common.ads20
-rw-r--r--src/vhdl/iirs.ads2
-rw-r--r--src/vhdl/sem_assocs.adb19
-rw-r--r--src/vhdl/sem_types.adb36
-rw-r--r--src/vhdl/translate/trans-chap12.adb9
-rw-r--r--src/vhdl/translate/trans-chap14.adb6
-rw-r--r--src/vhdl/translate/trans-chap2.adb46
-rw-r--r--src/vhdl/translate/trans-chap3.adb1426
-rw-r--r--src/vhdl/translate/trans-chap3.ads37
-rw-r--r--src/vhdl/translate/trans-chap4.adb93
-rw-r--r--src/vhdl/translate/trans-chap5.adb34
-rw-r--r--src/vhdl/translate/trans-chap6.adb44
-rw-r--r--src/vhdl/translate/trans-chap7.adb56
-rw-r--r--src/vhdl/translate/trans-chap8.adb5
-rw-r--r--src/vhdl/translate/trans-chap9.adb7
-rw-r--r--src/vhdl/translate/trans-helpers2.adb15
-rw-r--r--src/vhdl/translate/trans-rtis.adb249
-rw-r--r--src/vhdl/translate/trans-rtis.ads4
-rw-r--r--src/vhdl/translate/trans.adb49
-rw-r--r--src/vhdl/translate/trans.ads248
-rw-r--r--src/vhdl/translate/translation.adb35
60 files changed, 2109 insertions, 1508 deletions
diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb
index 065d64ef1..1a6239f1a 100644
--- a/src/grt/grt-avhpi.adb
+++ b/src/grt/grt-avhpi.adb
@@ -151,10 +151,12 @@ package body Grt.Avhpi is
Bt : constant Ghdl_Rtin_Type_Array_Acc :=
To_Ghdl_Rtin_Type_Array_Acc (St.Basetype);
Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1);
+ Layout : Address;
begin
+ Layout :=
+ Loc_To_Addr (St.Common.Depth, St.Layout, Res.Ctxt);
Bound_To_Range
- (Loc_To_Addr (St.Common.Depth, St.Bounds, Res.Ctxt),
- Bt, Rngs);
+ (Array_Layout_To_Bounds (Layout), Bt, Rngs);
Res.N_Idx := Ranges_To_Length (Rngs, Bt.Indexes);
end;
when others =>
@@ -176,7 +178,6 @@ package body Grt.Avhpi is
El_Type : Ghdl_Rti_Access;
Off : Ghdl_Index_Type) return Address
is
- pragma Unreferenced (Ctxt);
Is_Sig : Boolean;
El_Size : Ghdl_Index_Type;
El_Type1 : Ghdl_Rti_Access;
@@ -202,13 +203,20 @@ package body Grt.Avhpi is
El_Size := Ghdl_I64'Size / Storage_Unit;
end if;
when Ghdl_Rtik_Subtype_Array =>
- if Is_Sig then
- El_Size := Ghdl_Index_Type
- (To_Ghdl_Rtin_Subtype_Composite_Acc (El_Type1).Sigsize);
- else
- El_Size := Ghdl_Index_Type
- (To_Ghdl_Rtin_Subtype_Composite_Acc (El_Type1).Valsize);
- end if;
+ declare
+ Sizes : Ghdl_Indexes_Ptr;
+ begin
+ Sizes := To_Ghdl_Indexes_Ptr
+ (Loc_To_Addr
+ (El_Type1.Depth,
+ To_Ghdl_Rtin_Subtype_Composite_Acc (El_Type1).Layout,
+ Ctxt));
+ if Is_Sig then
+ El_Size := Sizes.Signal;
+ else
+ El_Size := Sizes.Value;
+ end if;
+ end;
when others =>
Internal_Error ("add_index");
end case;
@@ -1003,6 +1011,7 @@ package body Grt.Avhpi is
To_Ghdl_Rtin_Type_Array_Acc (Arr_Subtype.Basetype);
Idx : constant Ghdl_Index_Type :=
Ghdl_Index_Type (Index);
+ Layout : Address;
Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1);
Range_Basetype : Ghdl_Rti_Access;
begin
@@ -1012,10 +1021,10 @@ package body Grt.Avhpi is
return;
end if;
-- constraint type is basetype.indexes (idx - 1)
+ Layout := Loc_To_Addr (Arr_Subtype.Common.Depth,
+ Arr_Subtype.Layout, Ref.Ctxt);
Bound_To_Range
- (Loc_To_Addr (Arr_Subtype.Common.Depth,
- Arr_Subtype.Bounds, Ref.Ctxt),
- Basetype, Bounds);
+ (Array_Layout_To_Bounds (Layout), Basetype, Bounds);
Res := (Kind => VhpiIntRangeK,
Ctxt => Ref.Ctxt,
Rng_Type => Basetype.Indexes (Idx - 1),
diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb
index 7440480da..81e7e2b4c 100644
--- a/src/grt/grt-disp_rti.adb
+++ b/src/grt/grt-disp_rti.adb
@@ -245,11 +245,12 @@ package body Grt.Disp_Rti is
Rti : Ghdl_Rtin_Type_Record_Acc;
Ctxt : Rti_Context;
Obj : Address;
- Bounds : in out Address;
+ Obj_Layout : Address;
Is_Sig : Boolean)
is
El : Ghdl_Rtin_Element_Acc;
El_Addr : Address;
+ El_Bounds : Address;
begin
Put (Stream, "(");
for I in 1 .. Rti.Nbrel loop
@@ -259,8 +260,9 @@ package body Grt.Disp_Rti is
end if;
Put (Stream, El.Name);
Put (" => ");
- Record_To_Element_Base (Obj, El, Is_Sig, El_Addr);
- Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Bounds, Is_Sig);
+ Record_To_Element
+ (Obj, El, Is_Sig, Obj_Layout, El_Addr, El_Bounds);
+ Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, El_Bounds, Is_Sig);
end loop;
Put (")");
-- FIXME: update ADDR.
@@ -294,9 +296,11 @@ package body Grt.Disp_Rti is
To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
Bt : constant Ghdl_Rtin_Type_Array_Acc :=
To_Ghdl_Rtin_Type_Array_Acc (St.Basetype);
+ Layout : Address;
Bounds : Address;
begin
- Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt);
+ Layout := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt);
+ Bounds := Array_Layout_To_Bounds (Layout);
Disp_Array_Value_1 (Stream, Bt, Ctxt, 0, Obj, Bounds, Is_Sig);
end;
when Ghdl_Rtik_Type_File =>
@@ -309,8 +313,20 @@ package body Grt.Disp_Rti is
-- FIXME: update OBJ (not very useful since never in a
-- composite type).
end;
- when Ghdl_Rtik_Type_Record
- | Ghdl_Rtik_Type_Unbounded_Record =>
+ when Ghdl_Rtik_Type_Record =>
+ declare
+ Bt : constant Ghdl_Rtin_Type_Record_Acc :=
+ To_Ghdl_Rtin_Type_Record_Acc (Rti);
+ Rec_Layout : Address;
+ begin
+ if Rti_Complex_Type (Rti) then
+ Rec_Layout := Loc_To_Addr (Bt.Common.Depth, Bt.Layout, Ctxt);
+ else
+ Rec_Layout := Bounds;
+ end if;
+ Disp_Record_Value (Stream, Bt, Ctxt, Obj, Rec_Layout, Is_Sig);
+ end;
+ when Ghdl_Rtik_Type_Unbounded_Record =>
Disp_Record_Value
(Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt,
Obj, Bounds, Is_Sig);
@@ -320,10 +336,10 @@ package body Grt.Disp_Rti is
To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
Bt : constant Ghdl_Rtin_Type_Record_Acc :=
To_Ghdl_Rtin_Type_Record_Acc (St.Basetype);
- Bounds : Address;
+ Layout : Address;
begin
- Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt);
- Disp_Record_Value (Stream, Bt, Ctxt, Obj, Bounds, Is_Sig);
+ Layout := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt);
+ Disp_Record_Value (Stream, Bt, Ctxt, Obj, Layout, Is_Sig);
end;
when Ghdl_Rtik_Type_Protected =>
Put (Stream, "Unhandled protected type");
@@ -536,11 +552,13 @@ package body Grt.Disp_Rti is
end Disp_Scalar_Type_Name;
procedure Disp_Type_Array_Bounds (Def : Ghdl_Rtin_Type_Array_Acc;
- Bounds : in out Address)
+ Bounds : Address)
is
Rng : Ghdl_Range_Ptr;
Idx_Base : Ghdl_Rti_Access;
+ Bounds1 : Address;
begin
+ Bounds1 := Bounds;
Put (" (");
for I in 0 .. Def.Nbr_Dim - 1 loop
if I /= 0 then
@@ -551,16 +569,17 @@ package body Grt.Disp_Rti is
Put (" range ");
end if;
Idx_Base := Get_Base_Type (Def.Indexes (I));
- Extract_Range (Bounds, Idx_Base, Rng);
+ Extract_Range (Bounds1, Idx_Base, Rng);
Disp_Range (stdout, Idx_Base, Rng);
end loop;
Put (")");
end Disp_Type_Array_Bounds;
procedure Disp_Type_Record_Bounds (Def : Ghdl_Rtin_Type_Record_Acc;
- Bounds : in out Address)
+ Layout : Address)
is
El : Ghdl_Rtin_Element_Acc;
+ El_Layout : Address;
First : Boolean;
begin
Put (" (");
@@ -576,13 +595,15 @@ package body Grt.Disp_Rti is
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), 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), Bounds);
+ (To_Ghdl_Rtin_Type_Record_Acc (El.Eltype), El_Layout);
when others =>
raise Program_Error;
end case;
@@ -607,16 +628,16 @@ package body Grt.Disp_Rti is
end Disp_Type_Array_Name;
procedure Disp_Type_Record_Name (Def : Ghdl_Rtin_Type_Record_Acc;
- Bounds_Ptr : Address)
+ Layout_Ptr : Address)
is
- Bounds : Address;
+ Layout : Address;
begin
Disp_Name (Def.Name);
- if Bounds_Ptr = Null_Address then
+ if Layout_Ptr = Null_Address then
return;
end if;
- Bounds := Bounds_Ptr;
- Disp_Type_Record_Bounds (Def, Bounds);
+ Layout := Layout_Ptr;
+ Disp_Type_Record_Bounds (Def, Layout);
end Disp_Type_Record_Name;
procedure Disp_Subtype_Scalar_Range
@@ -675,7 +696,7 @@ package body Grt.Disp_Rti is
else
Disp_Type_Record_Name
(To_Ghdl_Rtin_Type_Record_Acc (Sdef.Basetype),
- Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt));
+ Loc_To_Addr (Sdef.Common.Depth, Sdef.Layout, Ctxt));
end if;
end;
when Ghdl_Rtik_Type_Array =>
@@ -694,13 +715,15 @@ package body Grt.Disp_Rti is
declare
Sdef : constant Ghdl_Rtin_Subtype_Composite_Acc :=
To_Ghdl_Rtin_Subtype_Composite_Acc (Def);
+ Layout : Address;
begin
if Sdef.Name /= null then
Disp_Name (Sdef.Name);
else
+ Layout := Loc_To_Addr (Sdef.Common.Depth, Sdef.Layout, Ctxt);
Disp_Type_Array_Name
(To_Ghdl_Rtin_Type_Array_Acc (Sdef.Basetype),
- Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt));
+ Array_Layout_To_Bounds (Layout));
end if;
end;
when Ghdl_Rtik_Type_Protected =>
@@ -1102,14 +1125,15 @@ package body Grt.Disp_Rti is
is
Basetype : constant Ghdl_Rtin_Type_Array_Acc :=
To_Ghdl_Rtin_Type_Array_Acc (Def.Basetype);
+ Layout : Address;
begin
Disp_Indent (Indent);
Disp_Kind (Def.Common.Kind);
Put (": ");
Disp_Name (Def.Name);
Put (" is ");
- Disp_Type_Array_Name
- (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt));
+ Layout := Loc_To_Addr (Def.Common.Depth, Def.Layout, Ctxt);
+ Disp_Type_Array_Name (Basetype, Array_Layout_To_Bounds (Layout));
if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then
Put (" of ");
Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address);
@@ -1169,7 +1193,7 @@ package body Grt.Disp_Rti is
is
Basetype : constant Ghdl_Rtin_Type_Record_Acc :=
To_Ghdl_Rtin_Type_Record_Acc (Def.Basetype);
- Bounds : Address;
+ Layout : Address;
begin
Disp_Indent (Indent);
Disp_Kind (Def.Common.Kind);
@@ -1178,8 +1202,8 @@ package body Grt.Disp_Rti is
Put (" is ");
Disp_Name (Basetype.Name);
if Def.Common.Kind = Ghdl_Rtik_Subtype_Record then
- Bounds := Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt);
- Disp_Type_Record_Bounds (Basetype, Bounds);
+ Layout := Loc_To_Addr (Def.Common.Depth, Def.Layout, Ctxt);
+ Disp_Type_Record_Bounds (Basetype, Layout);
end if;
New_Line;
end Disp_Subtype_Record_Decl;
diff --git a/src/grt/grt-rtis.ads b/src/grt/grt-rtis.ads
index afe9676c6..030cd7e04 100644
--- a/src/grt/grt-rtis.ads
+++ b/src/grt/grt-rtis.ads
@@ -120,6 +120,8 @@ package Grt.Rtis is
-- bit 0: set for complex type
-- bit 1: set for anonymous type definition
-- bit 2: set only for physical type with non-static units (time)
+ -- * record elements:
+ -- bit 0: set for complex type (copy of the type complex bit).
-- * signals:
-- bit 0-3: mode (1: linkage, 2: buffer, 3 : out, 4 : inout, 5: in)
-- bit 4-5: kind (0 : none, 1 : register, 2 : bus)
@@ -311,9 +313,7 @@ package Grt.Rtis is
Common : Ghdl_Rti_Common;
Name : Ghdl_C_String;
Basetype : Ghdl_Rti_Access;
- Bounds : Ghdl_Rti_Loc;
- Valsize : Ghdl_Rti_Loc;
- Sigsize : Ghdl_Rti_Loc;
+ Layout : Ghdl_Rti_Loc;
end record;
pragma Convention (C, Ghdl_Rtin_Subtype_Composite);
type Ghdl_Rtin_Subtype_Composite_Acc is access Ghdl_Rtin_Subtype_Composite;
@@ -332,12 +332,22 @@ package Grt.Rtis is
function To_Ghdl_Rtin_Type_Fileacc_Acc is new Ada.Unchecked_Conversion
(Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Fileacc_Acc);
+ -- Set in the mode field to know what Val_Off and Sig_Off are relative to.
+ -- This could also be extrated from the element type.
+ Ghdl_Rti_Element_Static : constant Ghdl_Rti_U8 := 0;
+ Ghdl_Rti_Element_Complex : constant Ghdl_Rti_U8 := 1;
+ Ghdl_Rti_Element_Unbounded : constant Ghdl_Rti_U8 := 2;
+
type Ghdl_Rtin_Element is record
Common : Ghdl_Rti_Common;
Name : Ghdl_C_String;
Eltype : Ghdl_Rti_Access;
+ -- For static element: offset in the record.
+ -- For complex element: offset in the type layout or object layout.
Val_Off : Ghdl_Index_Type;
Sig_Off : Ghdl_Index_Type;
+ -- For unbounded records: element layout offset in the layout.
+ Layout_Off : Ghdl_Index_Type;
end record;
pragma Convention (C, Ghdl_Rtin_Element);
type Ghdl_Rtin_Element_Acc is access Ghdl_Rtin_Element;
@@ -349,6 +359,8 @@ package Grt.Rtis is
Name : Ghdl_C_String;
Nbrel : Ghdl_Index_Type;
Elements : Ghdl_Rti_Arr_Acc;
+ -- Layout variable for the record, if it is complex.
+ Layout : Ghdl_Rti_Loc;
end record;
pragma Convention (C, Ghdl_Rtin_Type_Record);
type Ghdl_Rtin_Type_Record_Acc is access Ghdl_Rtin_Type_Record;
diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb
index 7be70eb02..4881a5abd 100644
--- a/src/grt/grt-rtis_addr.adb
+++ b/src/grt/grt-rtis_addr.adb
@@ -278,6 +278,11 @@ package body Grt.Rtis_Addr is
end case;
end Extract_Range;
+ function Array_Layout_To_Bounds (Layout : Address) return Address is
+ begin
+ return Layout + Ghdl_Index_Type'(Ghdl_Indexes_Type'Size / 8);
+ end Array_Layout_To_Bounds;
+
procedure Bound_To_Range (Bounds_Addr : Address;
Def : Ghdl_Rtin_Type_Array_Acc;
Res : out Ghdl_Range_Array)
diff --git a/src/grt/grt-rtis_addr.ads b/src/grt/grt-rtis_addr.ads
index 550576733..db8e15264 100644
--- a/src/grt/grt-rtis_addr.ads
+++ b/src/grt/grt-rtis_addr.ads
@@ -51,10 +51,6 @@ package Grt.Rtis_Addr is
function To_Addr_Acc is new Ada.Unchecked_Conversion
(Source => Address, Target => Addr_Acc);
- type Ghdl_Index_Acc is access Ghdl_Index_Type;
- function To_Ghdl_Index_Acc is new Ada.Unchecked_Conversion
- (Source => Address, Target => Ghdl_Index_Acc);
-
-- Get the parent context of CTXT.
-- The parent of an architecture is its entity.
function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context;
@@ -91,6 +87,8 @@ package Grt.Rtis_Addr is
Def : Ghdl_Rti_Access;
Rng : out Ghdl_Range_Ptr);
+ function Array_Layout_To_Bounds (Layout : Address) return Address;
+
-- Extract range of every dimension from bounds.
procedure Bound_To_Range (Bounds_Addr : Address;
Def : Ghdl_Rtin_Type_Array_Acc;
diff --git a/src/grt/grt-rtis_utils.adb b/src/grt/grt-rtis_utils.adb
index 695de7315..ed4429744 100644
--- a/src/grt/grt-rtis_utils.adb
+++ b/src/grt/grt-rtis_utils.adb
@@ -22,7 +22,7 @@
-- 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
@@ -178,32 +178,41 @@ package body Grt.Rtis_Utils is
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
+ procedure Record_To_Element (Obj : Address;
+ El : Ghdl_Rtin_Element_Acc;
+ Is_Sig : Boolean;
+ Rec_Layout : Address;
+ El_Addr : out Address;
+ El_Bounds : out Address)
+ is
+ Off : Ghdl_Index_Type;
+ Off_Addr : Address;
begin
if Is_Sig then
- Addr := Obj + El.Sig_Off;
+ Off := El.Sig_Off;
else
- Addr := Obj + El.Val_Off;
+ Off := 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;
+
+ case El.Common.Mode is
+ when Ghdl_Rti_Element_Static =>
+ El_Addr := Obj + Off;
+ El_Bounds := Null_Address;
+ when Ghdl_Rti_Element_Complex =>
+ Off_Addr := Rec_Layout + Off;
+ El_Addr := Obj + To_Ghdl_Index_Ptr (Off_Addr).all;
+ El_Bounds := Null_Address;
+ when Ghdl_Rti_Element_Unbounded =>
+ Off_Addr := Rec_Layout + Off;
+ El_Addr := Obj + To_Ghdl_Index_Ptr (Off_Addr).all;
+ El_Bounds := Rec_Layout + El.Layout_Off;
+ if El.Eltype.Kind = Ghdl_Rtik_Type_Array then
+ El_Bounds := Array_Layout_To_Bounds (El_Bounds);
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;
+ Internal_Error ("record_to_element");
end case;
- end Record_To_Element_Base;
+ end Record_To_Element;
procedure Foreach_Scalar (Ctxt : Rti_Context;
Obj_Type : Ghdl_Rti_Access;
@@ -360,26 +369,31 @@ package body Grt.Rtis_Utils is
procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc)
is
+ Rec_Addr : constant Address := Addr;
+ Rec_Bounds : constant Address := Bounds;
+ Sizes : constant Ghdl_Indexes_Ptr :=
+ To_Ghdl_Indexes_Ptr (Bounds);
El : Ghdl_Rtin_Element_Acc;
- Obj_Addr : Address;
- Last_Addr : Address;
+ El_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);
+ Record_To_Element
+ (Rec_Addr, El, Is_Sig, Rec_Bounds, El_Addr, Bounds);
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;
+ if Is_Sig then
+ Addr := Rec_Addr + Sizes.Signal;
+ else
+ Addr := Rec_Addr + Sizes.Value;
+ end if;
+ -- Bounds was fully used, no need to restore it.
+ Bounds := Null_Address;
end Handle_Record;
procedure Handle_Any (Rti : Ghdl_Rti_Access) is
@@ -401,8 +415,10 @@ package body Grt.Rtis_Utils is
Bt : constant Ghdl_Rtin_Type_Array_Acc :=
To_Ghdl_Rtin_Type_Array_Acc (St.Basetype);
Prev_Bounds : constant Address := Bounds;
+ Layout : Address;
begin
- Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt);
+ Layout := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt);
+ Bounds := Array_Layout_To_Bounds (Layout);
Handle_Array_1 (Bt, 0);
Bounds := Prev_Bounds;
end;
@@ -416,8 +432,18 @@ package body Grt.Rtis_Utils is
-- -- FIXME: update OBJ (not very useful since never in a
-- -- composite type).
-- end;
- when Ghdl_Rtik_Type_Record
- | Ghdl_Rtik_Type_Unbounded_Record =>
+ when Ghdl_Rtik_Type_Record =>
+ declare
+ Bt : constant Ghdl_Rtin_Type_Record_Acc :=
+ To_Ghdl_Rtin_Type_Record_Acc (Rti);
+ Prev_Bounds : constant Address := Bounds;
+ begin
+ Bounds := Loc_To_Addr (Bt.Common.Depth, Bt.Layout, Ctxt);
+ Handle_Record (Bt);
+ Bounds := Prev_Bounds;
+ end;
+ when Ghdl_Rtik_Type_Unbounded_Record =>
+ -- Bounds (layout) must have been extracted.
Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti));
when Ghdl_Rtik_Subtype_Record =>
declare
@@ -427,7 +453,7 @@ package body Grt.Rtis_Utils is
To_Ghdl_Rtin_Type_Record_Acc (St.Basetype);
Prev_Bounds : constant Address := Bounds;
begin
- Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt);
+ Bounds := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt);
Handle_Record (Bt);
Bounds := Prev_Bounds;
end;
diff --git a/src/grt/grt-rtis_utils.ads b/src/grt/grt-rtis_utils.ads
index 71d9e963b..537f1bff8 100644
--- a/src/grt/grt-rtis_utils.ads
+++ b/src/grt/grt-rtis_utils.ads
@@ -70,10 +70,12 @@ package Grt.Rtis_Utils is
Bounds : out Address);
-- Get address of element EL for record at OBJ.
- procedure Record_To_Element_Base (Obj : Address;
- El : Ghdl_Rtin_Element_Acc;
- Is_Sig : Boolean;
- Addr : out Address);
+ procedure Record_To_Element (Obj : Address;
+ El : Ghdl_Rtin_Element_Acc;
+ Is_Sig : Boolean;
+ Rec_Layout : Address;
+ El_Addr : out Address;
+ El_Bounds : out Address);
procedure Get_Value (Str : in out Vstring;
Value : Value_Union;
diff --git a/src/grt/grt-types.ads b/src/grt/grt-types.ads
index d9b17f67e..f75711eeb 100644
--- a/src/grt/grt-types.ads
+++ b/src/grt/grt-types.ads
@@ -285,6 +285,16 @@ package Grt.Types is
type Ghdl_Range_Array is array (Ghdl_Index_Type range <>) of Ghdl_Range_Ptr;
+ type Ghdl_Indexes_Type is record
+ Value : Ghdl_Index_Type;
+ Signal : Ghdl_Index_Type;
+ end record;
+
+ type Ghdl_Indexes_Ptr is access all Ghdl_Indexes_Type;
+
+ function To_Ghdl_Indexes_Ptr is new Ada.Unchecked_Conversion
+ (Source => Address, Target => Ghdl_Indexes_Ptr);
+
-- For PSL counters.
type Ghdl_Index_Ptr is access all Ghdl_Index_Type;
diff --git a/src/grt/grt-vcd.adb b/src/grt/grt-vcd.adb
index 180bfeeb9..9050a26a4 100644
--- a/src/grt/grt-vcd.adb
+++ b/src/grt/grt-vcd.adb
@@ -360,8 +360,9 @@ package body Grt.Vcd is
Get_Base_Type (Arr_Rti.Indexes (0));
begin
Kind := Rti_To_Vcd_Kind (Arr_Rti);
- Bounds := Loc_To_Addr (St.Common.Depth, St.Bounds,
+ Bounds := Loc_To_Addr (St.Common.Depth, St.Layout,
Avhpi_Get_Context (Sig));
+ Bounds := Array_Layout_To_Bounds (Bounds);
Extract_Range (Bounds, Idx_Rti, Irange);
end;
when Ghdl_Rtik_Type_Array =>
diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb
index 74d764e67..ffe174bf6 100644
--- a/src/grt/grt-waves.adb
+++ b/src/grt/grt-waves.adb
@@ -1276,14 +1276,16 @@ package body Grt.Waves is
end Write_Range;
procedure Write_Array_Bounds (Arr : Ghdl_Rtin_Type_Array_Acc;
- Bounds : in out Address)
+ 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 (Bounds, Index_Type, Rng);
+ Extract_Range (Bounds1, Index_Type, Rng);
Write_Range (Index_Type, Rng);
end loop;
end Write_Array_Bounds;
@@ -1393,10 +1395,11 @@ package body Grt.Waves is
declare
Bt : constant Ghdl_Rtin_Type_Array_Acc :=
To_Ghdl_Rtin_Type_Array_Acc (Arr.Basetype);
- Bounds : Address;
+ Layout : Address;
begin
- Bounds := Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt);
- Write_Array_Bounds (Bt, Bounds);
+ Layout := Loc_To_Addr (Rti.Depth, Arr.Layout, Ctxt);
+ Write_Array_Bounds
+ (Bt, Array_Layout_To_Bounds (Layout));
end;
end;
when Ghdl_Rtik_Type_Array =>
@@ -1432,14 +1435,14 @@ package body Grt.Waves is
To_Ghdl_Rtin_Subtype_Composite_Acc (Rti);
Base : constant Ghdl_Rtin_Type_Record_Acc :=
To_Ghdl_Rtin_Type_Record_Acc (Rec.Basetype);
- Bounds : Address;
+ Layout : Address;
begin
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);
+ Layout := Loc_To_Addr
+ (Rec.Common.Depth, Rec.Layout, Ctxt);
+ Write_Record_Bounds (Base, Layout);
end if;
end;
when Ghdl_Rtik_Subtype_Scalar =>
diff --git a/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb
index 53e4a6767..51707786e 100644
--- a/src/ortho/debug/ortho_debug-disp.adb
+++ b/src/ortho/debug/ortho_debug-disp.adb
@@ -264,6 +264,7 @@ package body Ortho_Debug.Disp is
procedure Disp_Enode (E : O_Enode; Etype : O_Tnode);
procedure Disp_Lnode (Node : O_Lnode);
+ procedure Disp_Gnode (Node : O_Gnode);
procedure Disp_Snode (First, Last : O_Snode);
procedure Disp_Dnode (Decl : O_Dnode);
procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean);
@@ -556,17 +557,17 @@ package body Ortho_Debug.Disp is
when OC_Address =>
Disp_Tnode_Name (C.Ctype);
Put ("'address (");
- Disp_Dnode_Name (C.Decl);
+ Disp_Gnode (C.Addr_Global);
Put (")");
when OC_Unchecked_Address =>
Disp_Tnode_Name (C.Ctype);
Put ("'unchecked_address (");
- Disp_Dnode_Name (C.Decl);
+ Disp_Gnode (C.Addr_Global);
Put (")");
when OC_Subprogram_Address =>
Disp_Tnode_Name (C.Ctype);
Put ("'subprg_addr (");
- Disp_Dnode_Name (C.Decl);
+ Disp_Dnode_Name (C.Addr_Decl);
Put (")");
end case;
end Disp_Cnode;
@@ -677,13 +678,21 @@ package body Ortho_Debug.Disp is
Disp_Lnode (Node.Rec_Base);
Put ('.');
Disp_Ident (Node.Rec_El.Ident);
--- when OL_Var_Ref
--- | OL_Const_Ref
--- | OL_Param_Ref =>
--- Disp_Dnode_Name (Node.Decl);
end case;
end Disp_Lnode;
+ procedure Disp_Gnode (Node : O_Gnode) is
+ begin
+ case Node.Kind is
+ when OG_Decl =>
+ Disp_Dnode_Name (Node.Decl);
+ when OG_Selected_Element =>
+ Disp_Gnode (Node.Rec_Base);
+ Put ('.');
+ Disp_Ident (Node.Rec_El.Ident);
+ end case;
+ end Disp_Gnode;
+
procedure Disp_Fnodes (First : O_Fnode)
is
El : O_Fnode;
diff --git a/src/ortho/debug/ortho_debug.adb b/src/ortho/debug/ortho_debug.adb
index 3645b89e8..bb32197a4 100644
--- a/src/ortho/debug/ortho_debug.adb
+++ b/src/ortho/debug/ortho_debug.adb
@@ -288,6 +288,14 @@ package body Ortho_Debug is
N.Ref := True;
end Check_Ref;
+ procedure Check_Ref (N : O_Gnode) is
+ begin
+ if N.Ref then
+ raise Syntax_Error;
+ end if;
+ N.Ref := True;
+ end Check_Ref;
+
procedure Check_Complete_Type (T : O_Tnode) is
begin
if not T.Complete then
@@ -928,7 +936,7 @@ package body Ortho_Debug is
| ON_Interface_Decl =>
null;
when others =>
- raise Program_Error;
+ raise Syntax_Error;
end case;
Check_Scope (Obj);
return new O_Lnode_Obj'(Kind => OL_Obj,
@@ -937,8 +945,28 @@ package body Ortho_Debug is
Obj => Obj);
end New_Obj;
+ function New_Global (Decl : O_Dnode) return O_Gnode
+ is
+ subtype O_Gnode_Decl is O_Gnode_Type (OG_Decl);
+ begin
+ case Decl.Kind is
+ when ON_Const_Decl
+ | ON_Var_Decl =>
+ null;
+ when others =>
+ raise Syntax_Error;
+ end case;
+ if Decl.Storage = O_Storage_Local then
+ raise Syntax_Error;
+ end if;
+ return new O_Gnode_Decl'(Kind => OG_Decl,
+ Rtype => Decl.Dtype,
+ Ref => False,
+ Decl => Decl);
+ end New_Global;
+
function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode)
- return O_Lnode
+ return O_Lnode
is
subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element);
Res : O_Lnode;
@@ -953,7 +981,7 @@ package body Ortho_Debug is
end New_Indexed_Element;
function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
- return O_Lnode
+ return O_Lnode
is
subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice);
Res : O_Lnode;
@@ -995,6 +1023,27 @@ package body Ortho_Debug is
Rec_El => El);
end New_Selected_Element;
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode
+ is
+ subtype O_Gnode_Selected_Element is O_Gnode_Type (OG_Selected_Element);
+ begin
+ if Rec.Rtype.Kind /= ON_Record_Type
+ and then Rec.Rtype.Kind /= ON_Union_Type
+ then
+ raise Type_Error;
+ end if;
+ if Rec.Rtype /= El.Parent then
+ raise Type_Error;
+ end if;
+ Check_Ref (Rec);
+ return new O_Gnode_Selected_Element'(Kind => OG_Selected_Element,
+ Rtype => El.Ftype,
+ Ref => False,
+ Rec_Base => Rec,
+ Rec_El => El);
+ end New_Global_Selected_Element;
+
function New_Access_Element (Acc : O_Enode) return O_Lnode
is
subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element);
@@ -1086,12 +1135,13 @@ package body Ortho_Debug is
Lvalue => Lvalue);
end New_Address;
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode
is
subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address);
begin
- Check_Scope (Decl);
+ -- FIXME: check Lvalue is a static object.
+ Check_Ref (Lvalue);
if Atype.Kind /= ON_Access_Type then
-- An address is of type access.
raise Type_Error;
@@ -1099,25 +1149,27 @@ package body Ortho_Debug is
return new O_Cnode_Address'(Kind => OC_Unchecked_Address,
Ctype => Atype,
Ref => False,
- Decl => Decl);
+ Addr_Global => Lvalue);
end New_Global_Unchecked_Address;
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode
is
subtype O_Cnode_Address is O_Cnode_Type (OC_Address);
begin
- Check_Scope (Decl);
+ -- FIXME: check Lvalue is a static object.
+ Check_Ref (Lvalue);
if Atype.Kind /= ON_Access_Type then
-- An address is of type access.
raise Type_Error;
end if;
- if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then
+ if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then
raise Type_Error;
end if;
return new O_Cnode_Address'(Kind => OC_Address,
Ctype => Atype,
Ref => False,
- Decl => Decl);
+ Addr_Global => Lvalue);
end New_Global_Address;
function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
@@ -1132,7 +1184,7 @@ package body Ortho_Debug is
return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address,
Ctype => Atype,
Ref => False,
- Decl => Subprg);
+ Addr_Decl => Subprg);
end New_Subprogram_Address;
-- Raise TYPE_ERROR is ATYPE is a composite type.
diff --git a/src/ortho/debug/ortho_debug.private.ads b/src/ortho/debug/ortho_debug.private.ads
index a1e711b62..b505ff434 100644
--- a/src/ortho/debug/ortho_debug.private.ads
+++ b/src/ortho/debug/ortho_debug.private.ads
@@ -179,9 +179,10 @@ private
Aggr_Value : O_Cnode;
Aggr_Next : O_Cnode;
when OC_Address
- | OC_Unchecked_Address
- | OC_Subprogram_Address =>
- Decl : O_Dnode;
+ | OC_Unchecked_Address =>
+ Addr_Global : O_Gnode;
+ when OC_Subprogram_Address =>
+ Addr_Decl : O_Dnode;
end case;
end record;
@@ -280,12 +281,6 @@ private
OL_Slice,
OL_Selected_Element,
OL_Access_Element
-
- -- Variable, constant, parameter reference.
- -- This allows to read/write a declaration.
- --OL_Var_Ref,
- --OL_Const_Ref,
- --OL_Param_Ref
);
type O_Lnode_Type (Kind : OL_Kind);
@@ -311,10 +306,30 @@ private
Rec_El : O_Fnode;
when OL_Access_Element =>
Acc_Base : O_Enode;
--- when OL_Var_Ref
--- | OL_Const_Ref
--- | OL_Param_Ref =>
--- Decl : O_Dnode;
+ end case;
+ end record;
+
+ type OG_Kind is
+ (
+ OG_Decl,
+ OG_Selected_Element
+ );
+
+ type O_Gnode_Type (Kind : OG_Kind);
+ type O_Gnode is access O_Gnode_Type;
+ O_Gnode_Null : constant O_Gnode := null;
+
+ type O_Gnode_Type (Kind : OG_Kind) is record
+ -- Type of the result.
+ Rtype : O_Tnode;
+ -- True if referenced.
+ Ref : Boolean;
+ case Kind is
+ when OG_Decl =>
+ Decl : O_Dnode;
+ when OG_Selected_Element =>
+ Rec_Base : O_Gnode;
+ Rec_El : O_Fnode;
end case;
end record;
diff --git a/src/ortho/gcc/ortho_gcc.adb b/src/ortho/gcc/ortho_gcc.adb
index ae7b4f53b..37f782dcd 100644
--- a/src/ortho/gcc/ortho_gcc.adb
+++ b/src/ortho/gcc/ortho_gcc.adb
@@ -30,6 +30,17 @@ package body Ortho_Gcc is
return O_Lnode (Obj);
end New_Obj;
+ function New_Global (Decl : O_Dnode) return O_Gnode is
+ begin
+ return O_Gnode (Decl);
+ end New_Global;
+
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode is
+ begin
+ return O_Gnode (New_Selected_Element (O_Lnode (Rec), El));
+ end New_Global_Selected_Element;
+
function New_Obj_Value (Obj : O_Dnode) return O_Enode is
begin
return O_Enode (Obj);
diff --git a/src/ortho/gcc/ortho_gcc.ads b/src/ortho/gcc/ortho_gcc.ads
index 7332ceb21..6273435dc 100644
--- a/src/ortho/gcc/ortho_gcc.ads
+++ b/src/ortho/gcc/ortho_gcc.ads
@@ -34,10 +34,12 @@ package Ortho_Gcc is
type O_Tnode is private;
type O_Snode is private;
type O_Dnode is private;
+ type O_Gnode is private;
type O_Fnode is private;
O_Cnode_Null : constant O_Cnode;
O_Dnode_Null : constant O_Dnode;
+ O_Gnode_Null : constant O_Gnode;
O_Enode_Null : constant O_Enode;
O_Fnode_Null : constant O_Fnode;
O_Lnode_Null : constant O_Lnode;
@@ -183,17 +185,17 @@ package Ortho_Gcc is
-- Get the address of a subprogram.
function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ return O_Cnode;
-- Get the address of LVALUE.
-- ATYPE must be a type access whose designated type is the type of LVALUE.
-- FIXME: what about arrays.
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode;
-- Same as New_Address but without any restriction.
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode;
-------------------
-- Expressions --
@@ -292,12 +294,15 @@ package Ortho_Gcc is
-- base type of ARR.
-- INDEX must be of the type of the array index.
function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
- return O_Lnode;
+ return O_Lnode;
-- Get an element of a record or a union.
-- Type of REC must be a record or a union type.
function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
- return O_Lnode;
+ return O_Lnode;
+
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode;
-- Reference an access.
-- Type of ACC must be an access type.
@@ -324,6 +329,9 @@ package Ortho_Gcc is
-- Get an lvalue from a declaration.
function New_Obj (Obj : O_Dnode) return O_Lnode;
+ -- Get a global lvalue from a declaration.
+ function New_Global (Decl : O_Dnode) return O_Gnode;
+
-- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
@@ -474,6 +482,7 @@ private
type O_Cnode is new Tree;
type O_Enode is new Tree;
type O_Lnode is new Tree;
+ type O_Gnode is new Tree;
type O_Tnode is new Tree;
type O_Fnode is new Tree;
type O_Dnode is new Tree;
@@ -486,6 +495,7 @@ private
O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE);
O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE);
O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE);
+ O_Gnode_Null : constant O_Gnode := O_Gnode (NULL_TREE);
O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE);
O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE);
O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE);
diff --git a/src/ortho/gcc/ortho_gcc.private.ads b/src/ortho/gcc/ortho_gcc.private.ads
index fcbc59129..3bae8526e 100644
--- a/src/ortho/gcc/ortho_gcc.private.ads
+++ b/src/ortho/gcc/ortho_gcc.private.ads
@@ -38,6 +38,7 @@ private
type O_Cnode is new Tree;
type O_Enode is new Tree;
type O_Lnode is new Tree;
+ type O_Gnode is new Tree;
type O_Tnode is new Tree;
type O_Fnode is new Tree;
type O_Dnode is new Tree;
@@ -50,6 +51,7 @@ private
O_Cnode_Null : constant O_Cnode := O_Cnode (NULL_TREE);
O_Enode_Null : constant O_Enode := O_Enode (NULL_TREE);
O_Lnode_Null : constant O_Lnode := O_Lnode (NULL_TREE);
+ O_Gnode_Null : constant O_Gnode := O_Gnode (NULL_TREE);
O_Tnode_Null : constant O_Tnode := O_Tnode (NULL_TREE);
O_Fnode_Null : constant O_Fnode := O_Fnode (NULL_TREE);
O_Snode_Null : constant O_Snode := (NULL_TREE, NULL_TREE);
diff --git a/src/ortho/llvm-nodebug/ortho_llvm.adb b/src/ortho/llvm-nodebug/ortho_llvm.adb
index 7eb7277c6..443b469aa 100644
--- a/src/ortho/llvm-nodebug/ortho_llvm.adb
+++ b/src/ortho/llvm-nodebug/ortho_llvm.adb
@@ -779,22 +779,21 @@ package body Ortho_LLVM is
-- New_Global_Address --
------------------------
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode is
begin
- return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
- Ctype => Atype);
+ return New_Global_Unchecked_Address (Lvalue, Atype);
end New_Global_Address;
----------------------------------
-- New_Global_Unchecked_Address --
----------------------------------
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode
- is
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode is
begin
- return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
+ return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM,
+ Get_LLVM_Type (Atype)),
Ctype => Atype);
end New_Global_Unchecked_Address;
@@ -808,6 +807,24 @@ package body Ortho_LLVM is
Etype => Lit.Ctype);
end New_Lit;
+ ----------------
+ -- New_Global --
+ ----------------
+
+ function New_Global (Decl : O_Dnode) return O_Gnode is
+ begin
+ -- Can be used to build global objects, even when Unreach is set.
+ -- As this doesn't generate code, this is ok.
+ case Decl.Kind is
+ when ON_Const_Decl
+ | ON_Var_Decl =>
+ return O_Gnode'(LLVM => Decl.LLVM,
+ Ltype => Decl.Dtype);
+ when others =>
+ raise Program_Error;
+ end case;
+ end New_Global;
+
-------------------
-- New_Dyadic_Op --
-------------------
@@ -1174,6 +1191,28 @@ package body Ortho_LLVM is
return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype);
end New_Selected_Element;
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode
+ is
+ Res : ValueRef;
+ begin
+ case El.Kind is
+ when OF_Record =>
+ declare
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0),
+ ConstInt (Int32Type, Unsigned_64 (El.Index), 0));
+ begin
+ Res := ConstGEP (Rec.LLVM, Idx, 2);
+ end;
+ when OF_Union =>
+ Res := ConstBitCast (Rec.LLVM, El.Ptr_Type);
+ when OF_None =>
+ raise Program_Error;
+ end case;
+ return O_Gnode'(LLVM => Res, Ltype => El.Ftype);
+ end New_Global_Selected_Element;
+
------------------------
-- New_Access_Element --
------------------------
@@ -1364,12 +1403,8 @@ package body Ortho_LLVM is
function New_Obj (Obj : O_Dnode) return O_Lnode is
begin
- if Unreach then
- return O_Lnode'(Direct => False,
- LLVM => Null_ValueRef,
- Ltype => Obj.Dtype);
- end if;
-
+ -- Can be used to build global objects, even when Unreach is set.
+ -- As this doesn't generate code, this is ok.
case Obj.Kind is
when ON_Const_Decl
| ON_Var_Decl
@@ -1718,7 +1753,8 @@ package body Ortho_LLVM is
Cur_Func := Func.LLVM;
Cur_Func_Decl := Func;
- Unreach := False;
+
+ pragma Assert (not Unreach);
Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring);
PositionBuilderAtEnd (Decl_Builder, Decl_BB);
@@ -1751,6 +1787,8 @@ package body Ortho_LLVM is
Destroy_Declare_Block;
Cur_Func := Null_ValueRef;
+
+ Unreach := False;
end Finish_Subprogram_Body;
-------------------------
diff --git a/src/ortho/llvm-nodebug/ortho_llvm.private.ads b/src/ortho/llvm-nodebug/ortho_llvm.private.ads
index e5527a734..723aa5c7a 100644
--- a/src/ortho/llvm-nodebug/ortho_llvm.private.ads
+++ b/src/ortho/llvm-nodebug/ortho_llvm.private.ads
@@ -178,6 +178,13 @@ private
O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
+ type O_Gnode is record
+ LLVM : ValueRef;
+ Ltype : O_Tnode;
+ end record;
+
+ O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null);
+
type O_Snode is record
-- First BB in the loop body.
Bb_Entry : BasicBlockRef;
diff --git a/src/ortho/llvm/ortho_llvm.adb b/src/ortho/llvm/ortho_llvm.adb
index d5e172532..250870224 100644
--- a/src/ortho/llvm/ortho_llvm.adb
+++ b/src/ortho/llvm/ortho_llvm.adb
@@ -1115,22 +1115,21 @@ package body Ortho_LLVM is
-- New_Global_Address --
------------------------
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode is
begin
- return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
- Ctype => Atype);
+ return New_Global_Unchecked_Address (Lvalue, Atype);
end New_Global_Address;
----------------------------------
-- New_Global_Unchecked_Address --
----------------------------------
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode
- is
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode is
begin
- return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
+ return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM,
+ Get_LLVM_Type (Atype)),
Ctype => Atype);
end New_Global_Unchecked_Address;
@@ -1144,6 +1143,24 @@ package body Ortho_LLVM is
Etype => Lit.Ctype);
end New_Lit;
+ ----------------
+ -- New_Global --
+ ----------------
+
+ function New_Global (Decl : O_Dnode) return O_Gnode is
+ begin
+ -- Can be used to build global objects, even when Unreach is set.
+ -- As this doesn't generate code, this is ok.
+ case Decl.Kind is
+ when ON_Const_Decl
+ | ON_Var_Decl =>
+ return O_Gnode'(LLVM => Decl.LLVM,
+ Ltype => Decl.Dtype);
+ when others =>
+ raise Program_Error;
+ end case;
+ end New_Global;
+
-------------------
-- New_Dyadic_Op --
-------------------
@@ -1517,6 +1534,28 @@ package body Ortho_LLVM is
return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype);
end New_Selected_Element;
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode
+ is
+ Res : ValueRef;
+ begin
+ case El.Kind is
+ when OF_Record =>
+ declare
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0),
+ ConstInt (Int32Type, Unsigned_64 (El.Index), 0));
+ begin
+ Res := ConstGEP (Rec.LLVM, Idx, 2);
+ end;
+ when OF_Union =>
+ Res := ConstBitCast (Rec.LLVM, El.Ptr_Type);
+ when OF_None =>
+ raise Program_Error;
+ end case;
+ return O_Gnode'(LLVM => Res, Ltype => El.Ftype);
+ end New_Global_Selected_Element;
+
------------------------
-- New_Access_Element --
------------------------
@@ -1708,12 +1747,8 @@ package body Ortho_LLVM is
function New_Obj (Obj : O_Dnode) return O_Lnode is
begin
- if Unreach then
- return O_Lnode'(Direct => False,
- LLVM => Null_ValueRef,
- Ltype => Obj.Dtype);
- end if;
-
+ -- Can be used to build global objects, even when Unreach is set.
+ -- As this doesn't generate code, this is ok.
case Obj.Kind is
when ON_Const_Decl
| ON_Var_Decl
@@ -2257,7 +2292,8 @@ package body Ortho_LLVM is
Cur_Func := Func.LLVM;
Cur_Func_Decl := Func;
- Unreach := False;
+
+ pragma Assert (not Unreach);
Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring);
PositionBuilderAtEnd (Decl_Builder, Decl_BB);
@@ -2399,6 +2435,9 @@ package body Ortho_LLVM is
Destroy_Declare_Block;
Cur_Func := Null_ValueRef;
+
+ Unreach := False;
+
Dbg_Current_Scope := Null_ValueRef;
Dbg_Insn_MD := Null_ValueRef;
end Finish_Subprogram_Body;
diff --git a/src/ortho/llvm/ortho_llvm.ads b/src/ortho/llvm/ortho_llvm.ads
index 1dca66f4e..2779d0233 100644
--- a/src/ortho/llvm/ortho_llvm.ads
+++ b/src/ortho/llvm/ortho_llvm.ads
@@ -57,10 +57,12 @@ package Ortho_LLVM is
type O_Tnode is private;
type O_Snode is private;
type O_Dnode is private;
+ type O_Gnode is private;
type O_Fnode is private;
O_Cnode_Null : constant O_Cnode;
O_Dnode_Null : constant O_Dnode;
+ O_Gnode_Null : constant O_Gnode;
O_Enode_Null : constant O_Enode;
O_Fnode_Null : constant O_Fnode;
O_Lnode_Null : constant O_Lnode;
@@ -206,17 +208,17 @@ package Ortho_LLVM is
-- Get the address of a subprogram.
function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ return O_Cnode;
-- Get the address of LVALUE.
-- ATYPE must be a type access whose designated type is the type of LVALUE.
-- FIXME: what about arrays.
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode;
-- Same as New_Address but without any restriction.
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode;
-------------------
-- Expressions --
@@ -315,12 +317,15 @@ package Ortho_LLVM is
-- base type of ARR.
-- INDEX must be of the type of the array index.
function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
- return O_Lnode;
+ return O_Lnode;
-- Get an element of a record or a union.
-- Type of REC must be a record or a union type.
function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
- return O_Lnode;
+ return O_Lnode;
+
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode;
-- Reference an access.
-- Type of ACC must be an access type.
@@ -347,6 +352,9 @@ package Ortho_LLVM is
-- Get an lvalue from a declaration.
function New_Obj (Obj : O_Dnode) return O_Lnode;
+ -- Get a global lvalue from a declaration.
+ function New_Global (Decl : O_Dnode) return O_Gnode;
+
-- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
@@ -621,6 +629,13 @@ private
O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
+ type O_Gnode is record
+ LLVM : ValueRef;
+ Ltype : O_Tnode;
+ end record;
+
+ O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null);
+
type O_Snode is record
-- First BB in the loop body.
Bb_Entry : BasicBlockRef;
diff --git a/src/ortho/llvm/ortho_llvm.private.ads b/src/ortho/llvm/ortho_llvm.private.ads
index a4041cb44..ce0685a90 100644
--- a/src/ortho/llvm/ortho_llvm.private.ads
+++ b/src/ortho/llvm/ortho_llvm.private.ads
@@ -185,6 +185,13 @@ private
O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
+ type O_Gnode is record
+ LLVM : ValueRef;
+ Ltype : O_Tnode;
+ end record;
+
+ O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null);
+
type O_Snode is record
-- First BB in the loop body.
Bb_Entry : BasicBlockRef;
diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.adb b/src/ortho/llvm4-nodebug/ortho_llvm.adb
index 4e02a908a..2f0edca3c 100644
--- a/src/ortho/llvm4-nodebug/ortho_llvm.adb
+++ b/src/ortho/llvm4-nodebug/ortho_llvm.adb
@@ -782,22 +782,21 @@ package body Ortho_LLVM is
-- New_Global_Address --
------------------------
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode is
begin
- return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
- Ctype => Atype);
+ return New_Global_Unchecked_Address (Lvalue, Atype);
end New_Global_Address;
----------------------------------
-- New_Global_Unchecked_Address --
----------------------------------
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode
- is
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode is
begin
- return O_Cnode'(LLVM => ConstBitCast (Decl.LLVM, Get_LLVM_Type (Atype)),
+ return O_Cnode'(LLVM => ConstBitCast (Lvalue.LLVM,
+ Get_LLVM_Type (Atype)),
Ctype => Atype);
end New_Global_Unchecked_Address;
@@ -811,6 +810,24 @@ package body Ortho_LLVM is
Etype => Lit.Ctype);
end New_Lit;
+ ----------------
+ -- New_Global --
+ ----------------
+
+ function New_Global (Decl : O_Dnode) return O_Gnode is
+ begin
+ -- Can be used to build global objects, even when Unreach is set.
+ -- As this doesn't generate code, this is ok.
+ case Decl.Kind is
+ when ON_Const_Decl
+ | ON_Var_Decl =>
+ return O_Gnode'(LLVM => Decl.LLVM,
+ Ltype => Decl.Dtype);
+ when others =>
+ raise Program_Error;
+ end case;
+ end New_Global;
+
-------------------
-- New_Dyadic_Op --
-------------------
@@ -1177,6 +1194,28 @@ package body Ortho_LLVM is
return O_Lnode'(Direct => False, LLVM => Res, Ltype => El.Ftype);
end New_Selected_Element;
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode
+ is
+ Res : ValueRef;
+ begin
+ case El.Kind is
+ when OF_Record =>
+ declare
+ Idx : constant ValueRefArray (1 .. 2) :=
+ (ConstInt (Int32Type, 0, 0),
+ ConstInt (Int32Type, Unsigned_64 (El.Index), 0));
+ begin
+ Res := ConstGEP (Rec.LLVM, Idx, 2);
+ end;
+ when OF_Union =>
+ Res := ConstBitCast (Rec.LLVM, El.Ptr_Type);
+ when OF_None =>
+ raise Program_Error;
+ end case;
+ return O_Gnode'(LLVM => Res, Ltype => El.Ftype);
+ end New_Global_Selected_Element;
+
------------------------
-- New_Access_Element --
------------------------
@@ -1367,12 +1406,8 @@ package body Ortho_LLVM is
function New_Obj (Obj : O_Dnode) return O_Lnode is
begin
- if Unreach then
- return O_Lnode'(Direct => False,
- LLVM => Null_ValueRef,
- Ltype => Obj.Dtype);
- end if;
-
+ -- Can be used to build global objects, even when Unreach is set.
+ -- As this doesn't generate code, this is ok.
case Obj.Kind is
when ON_Const_Decl
| ON_Var_Decl
@@ -1725,7 +1760,8 @@ package body Ortho_LLVM is
Cur_Func := Func.LLVM;
Cur_Func_Decl := Func;
- Unreach := False;
+
+ pragma Assert (not Unreach);
Decl_BB := AppendBasicBlock (Cur_Func, Empty_Cstring);
PositionBuilderAtEnd (Decl_Builder, Decl_BB);
@@ -1758,6 +1794,8 @@ package body Ortho_LLVM is
Destroy_Declare_Block;
Cur_Func := Null_ValueRef;
+
+ Unreach := False;
end Finish_Subprogram_Body;
-------------------------
diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.ads b/src/ortho/llvm4-nodebug/ortho_llvm.ads
index 772a91894..837f4846e 100644
--- a/src/ortho/llvm4-nodebug/ortho_llvm.ads
+++ b/src/ortho/llvm4-nodebug/ortho_llvm.ads
@@ -50,10 +50,12 @@ package Ortho_LLVM is
type O_Tnode is private;
type O_Snode is private;
type O_Dnode is private;
+ type O_Gnode is private;
type O_Fnode is private;
O_Cnode_Null : constant O_Cnode;
O_Dnode_Null : constant O_Dnode;
+ O_Gnode_Null : constant O_Gnode;
O_Enode_Null : constant O_Enode;
O_Fnode_Null : constant O_Fnode;
O_Lnode_Null : constant O_Lnode;
@@ -199,17 +201,17 @@ package Ortho_LLVM is
-- Get the address of a subprogram.
function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ return O_Cnode;
-- Get the address of LVALUE.
-- ATYPE must be a type access whose designated type is the type of LVALUE.
-- FIXME: what about arrays.
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode;
-- Same as New_Address but without any restriction.
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode;
-------------------
-- Expressions --
@@ -308,12 +310,15 @@ package Ortho_LLVM is
-- base type of ARR.
-- INDEX must be of the type of the array index.
function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
- return O_Lnode;
+ return O_Lnode;
-- Get an element of a record or a union.
-- Type of REC must be a record or a union type.
function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
- return O_Lnode;
+ return O_Lnode;
+
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode;
-- Reference an access.
-- Type of ACC must be an access type.
@@ -340,6 +345,9 @@ package Ortho_LLVM is
-- Get an lvalue from a declaration.
function New_Obj (Obj : O_Dnode) return O_Lnode;
+ -- Get a global lvalue from a declaration.
+ function New_Global (Decl : O_Dnode) return O_Gnode;
+
-- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
@@ -614,6 +622,13 @@ private
O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
+ type O_Gnode is record
+ LLVM : ValueRef;
+ Ltype : O_Tnode;
+ end record;
+
+ O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null);
+
type O_Snode is record
-- First BB in the loop body.
Bb_Entry : BasicBlockRef;
diff --git a/src/ortho/llvm4-nodebug/ortho_llvm.private.ads b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads
index e5527a734..723aa5c7a 100644
--- a/src/ortho/llvm4-nodebug/ortho_llvm.private.ads
+++ b/src/ortho/llvm4-nodebug/ortho_llvm.private.ads
@@ -178,6 +178,13 @@ private
O_Lnode_Null : constant O_Lnode := (False, Null_ValueRef, O_Tnode_Null);
+ type O_Gnode is record
+ LLVM : ValueRef;
+ Ltype : O_Tnode;
+ end record;
+
+ O_Gnode_Null : constant O_Gnode := (Null_ValueRef, O_Tnode_Null);
+
type O_Snode is record
-- First BB in the loop body.
Bb_Entry : BasicBlockRef;
diff --git a/src/ortho/mcode/ortho_code-consts.adb b/src/ortho/mcode/ortho_code-consts.adb
index 7cc554211..1b2146dc4 100644
--- a/src/ortho/mcode/ortho_code-consts.adb
+++ b/src/ortho/mcode/ortho_code-consts.adb
@@ -19,6 +19,7 @@ with Ada.Unchecked_Conversion;
with Tables;
with Ada.Text_IO;
with Ortho_Code.Types; use Ortho_Code.Types;
+with Ortho_Code.Decls;
with Ortho_Code.Debug;
package body Ortho_Code.Consts is
@@ -59,6 +60,12 @@ package body Ortho_Code.Consts is
end record;
for Cnode_Addr'Size use 64;
+ type Cnode_Global is record
+ Obj : O_Gnode;
+ Pad : Int32;
+ end record;
+ for Cnode_Global'Size use 64;
+
type Cnode_Aggr is record
Els : Int32;
Nbr : Int32;
@@ -83,11 +90,43 @@ package body Ortho_Code.Consts is
Table_Low_Bound => 2,
Table_Initial => 128);
+ type Gnode_Common is record
+ Kind : OG_Kind;
+ Ref : Int32;
+ end record;
+ for Gnode_Common use record
+ Kind at 0 range 0 .. 31;
+ Ref at 4 range 0 .. 31;
+ end record;
+ for Gnode_Common'Size use 64;
+
+ type Gnode_Record_Ref is record
+ Field : O_Fnode;
+ Off : Uns32;
+ end record;
+ for Gnode_Record_Ref'Size use 64;
+
+ function To_Gnode_Common is new Ada.Unchecked_Conversion
+ (Gnode_Record_Ref, Gnode_Common);
+ function To_Gnode_Record_Ref is new Ada.Unchecked_Conversion
+ (Gnode_Common, Gnode_Record_Ref);
+
+ package Gnodes is new Tables
+ (Table_Component_Type => Gnode_Common,
+ Table_Index_Type => O_Gnode,
+ Table_Low_Bound => 2,
+ Table_Initial => 64);
+
function Get_Const_Kind (Cst : O_Cnode) return OC_Kind is
begin
return Cnodes.Table (Cst).Kind;
end Get_Const_Kind;
+ function Get_Global_Kind (Cst : O_Gnode) return OG_Kind is
+ begin
+ return Gnodes.Table (Cst).Kind;
+ end Get_Global_Kind;
+
function Get_Const_Type (Cst : O_Cnode) return O_Tnode is
begin
return Cnodes.Table (Cst).Lit_Type;
@@ -227,12 +266,12 @@ package body Ortho_Code.Consts is
end New_Default_Value;
function To_Cnode_Common is new Ada.Unchecked_Conversion
- (Source => Cnode_Addr, Target => Cnode_Common);
+ (Source => Cnode_Global, Target => Cnode_Common);
- function To_Cnode_Addr is new Ada.Unchecked_Conversion
- (Source => Cnode_Common, Target => Cnode_Addr);
+ function To_Cnode_Global is new Ada.Unchecked_Conversion
+ (Source => Cnode_Common, Target => Cnode_Global);
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode
is
Res : O_Cnode;
@@ -240,12 +279,12 @@ package body Ortho_Code.Consts is
Cnodes.Append (Cnode_Common'(Kind => OC_Address,
Lit_Type => Atype));
Res := Cnodes.Last;
- Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl,
- Pad => 0)));
+ Cnodes.Append (To_Cnode_Common (Cnode_Global'(Obj => Lvalue,
+ Pad => 0)));
return Res;
end New_Global_Unchecked_Address;
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode
is
Res : O_Cnode;
@@ -253,11 +292,23 @@ package body Ortho_Code.Consts is
Cnodes.Append (Cnode_Common'(Kind => OC_Address,
Lit_Type => Atype));
Res := Cnodes.Last;
- Cnodes.Append (To_Cnode_Common (Cnode_Addr'(Decl => Decl,
- Pad => 0)));
+ Cnodes.Append (To_Cnode_Common (Cnode_Global'(Obj => Lvalue,
+ Pad => 0)));
return Res;
end New_Global_Address;
+ function Get_Const_Global (Cst : O_Cnode) return O_Gnode is
+ begin
+ pragma Assert (Get_Const_Kind (Cst) = OC_Address);
+ return To_Cnode_Global (Cnodes.Table (Cst + 1)).Obj;
+ end Get_Const_Global;
+
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Addr, Target => Cnode_Common);
+
+ function To_Cnode_Addr is new Ada.Unchecked_Conversion
+ (Source => Cnode_Common, Target => Cnode_Addr);
+
function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
return O_Cnode
is
@@ -273,6 +324,7 @@ package body Ortho_Code.Consts is
function Get_Const_Decl (Cst : O_Cnode) return O_Dnode is
begin
+ pragma Assert (Get_Const_Kind (Cst) = OC_Subprg_Address);
return To_Cnode_Addr (Cnodes.Table (Cst + 1)).Decl;
end Get_Const_Decl;
@@ -512,6 +564,74 @@ package body Ortho_Code.Consts is
(Rtype, Unsigned_64 (Get_Field_Offset (Field)));
end New_Offsetof;
+ function Get_Global_Decl (Global : O_Gnode) return O_Dnode is
+ begin
+ pragma Assert (Get_Global_Kind (Global) = OG_Decl);
+ return O_Dnode (Gnodes.Table (Global).Ref);
+ end Get_Global_Decl;
+
+ function Get_Global_Field (Global : O_Gnode) return O_Fnode is
+ begin
+ pragma Assert (Get_Global_Kind (Global) = OG_Record_Ref);
+ return To_Gnode_Record_Ref (Gnodes.Table (Global + 1)).Field;
+ end Get_Global_Field;
+
+ function Get_Global_Ref (Global : O_Gnode) return O_Gnode is
+ begin
+ pragma Assert (Get_Global_Kind (Global) = OG_Record_Ref);
+ return O_Gnode (Gnodes.Table (Global).Ref);
+ end Get_Global_Ref;
+
+ function Get_Global_Type (Global : O_Gnode) return O_Tnode is
+ begin
+ case Get_Global_Kind (Global) is
+ when OG_Decl =>
+ return Decls.Get_Decl_Type (Get_Global_Decl (Global));
+ when OG_Record_Ref =>
+ return Get_Field_Type (Get_Global_Field (Global));
+ end case;
+ end Get_Global_Type;
+
+ function New_Global (Decl : O_Dnode) return O_Gnode is
+ begin
+ Gnodes.Append (Gnode_Common'(Kind => OG_Decl,
+ Ref => Int32 (Decl)));
+ return Gnodes.Last;
+ end New_Global;
+
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode
+ is
+ Res : O_Gnode;
+ begin
+ -- TODO: Check Ref.
+
+ -- Check type.
+ pragma Assert
+ (Get_Type_Kind (Get_Global_Type (Rec)) in OT_Kinds_Record_Union);
+
+ Gnodes.Append (Gnode_Common'(Kind => OG_Record_Ref,
+ Ref => Int32 (Rec)));
+ Res := Gnodes.Last;
+ Gnodes.Append (To_Gnode_Common
+ (Gnode_Record_Ref'(Field => El,
+ Off => Get_Field_Offset (El))));
+ return Res;
+ end New_Global_Selected_Element;
+
+ procedure Get_Global_Decl_Offset (Global : O_Gnode;
+ Decl : out O_Dnode; Off : out Uns32) is
+ begin
+ case Get_Global_Kind (Global) is
+ when OG_Decl =>
+ Decl := Get_Global_Decl (Global);
+ Off := 0;
+ when OG_Record_Ref =>
+ Get_Global_Decl_Offset (Get_Global_Ref (Global), Decl, Off);
+ Off := Off + Get_Field_Offset (Get_Global_Field (Global));
+ end case;
+ end Get_Global_Decl_Offset;
+
procedure Get_Const_Bytes (Cst : O_Cnode; H, L : out Uns32) is
begin
case Get_Const_Kind (Cst) is
diff --git a/src/ortho/mcode/ortho_code-consts.ads b/src/ortho/mcode/ortho_code-consts.ads
index 0a4f347fc..dcb719f26 100644
--- a/src/ortho/mcode/ortho_code-consts.ads
+++ b/src/ortho/mcode/ortho_code-consts.ads
@@ -24,6 +24,8 @@ package Ortho_Code.Consts is
OC_Subprg_Address, OC_Address,
OC_Sizeof, OC_Alignof);
+ type OG_Kind is (OG_Decl, OG_Record_Ref);
+
function Get_Const_Kind (Cst : O_Cnode) return OC_Kind;
function Get_Const_Type (Cst : O_Cnode) return O_Tnode;
@@ -54,9 +56,12 @@ package Ortho_Code.Consts is
function Get_Const_Union_Field (Cst : O_Cnode) return O_Fnode;
function Get_Const_Union_Value (Cst : O_Cnode) return O_Cnode;
- -- Declaration for an address.
+ -- Declaration for a subprogram address.
function Get_Const_Decl (Cst : O_Cnode) return O_Dnode;
+ -- Object for a global object address.
+ function Get_Const_Global (Cst : O_Cnode) return O_Gnode;
+
-- Get the type from an OC_Sizeof node.
function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode;
@@ -77,14 +82,22 @@ package Ortho_Code.Consts is
-- Create a null access literal.
function New_Null_Access (Ltype : O_Tnode) return O_Cnode;
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
function New_Default_Value (Ltype : O_Tnode) return O_Cnode;
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode;
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode;
function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
return O_Cnode;
+ function New_Global (Decl : O_Dnode) return O_Gnode;
+
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode;
+
+ procedure Get_Global_Decl_Offset (Global : O_Gnode;
+ Decl : out O_Dnode; Off : out Uns32);
+
function New_Named_Literal
(Atype : O_Tnode; Id : O_Ident; Val : Uns32; Prev : O_Cnode)
return O_Cnode;
diff --git a/src/ortho/mcode/ortho_code-decls.ads b/src/ortho/mcode/ortho_code-decls.ads
index 70a0ba4df..bd84bf2eb 100644
--- a/src/ortho/mcode/ortho_code-decls.ads
+++ b/src/ortho/mcode/ortho_code-decls.ads
@@ -19,24 +19,27 @@ with Ortho_Code.Abi;
package Ortho_Code.Decls is
-- Kind of a declaration.
- type OD_Kind is (OD_Type,
- OD_Const,
+ type OD_Kind is
+ (
+ OD_Type,
+ OD_Const,
- -- Value of constant, initial value of variable.
- OD_Init_Val,
+ -- Value of constant, initial value of variable.
+ OD_Init_Val,
- -- Global and local variables.
- OD_Var, OD_Local,
+ -- Global and local variables.
+ OD_Var, OD_Local,
- -- Subprograms.
- OD_Function, OD_Procedure,
+ -- Subprograms.
+ OD_Function, OD_Procedure,
- -- Additional node for a subprogram. Internal use only.
- OD_Subprg_Ext,
+ -- Additional node for a subprogram. Internal use only.
+ OD_Subprg_Ext,
- OD_Interface,
- OD_Body,
- OD_Block);
+ OD_Interface,
+ OD_Body,
+ OD_Block
+ );
-- Return the kind of declaration DECL.
function Get_Decl_Kind (Decl : O_Dnode) return OD_Kind;
@@ -126,11 +129,10 @@ package Ortho_Code.Decls is
-- This simply gives a name to a constant value or aggregate.
-- A constant cannot be modified and its storage cannot be local.
-- ATYPE must be constrained.
- procedure New_Const_Decl
- (Res : out O_Dnode;
- Ident : O_Ident;
- Storage : O_Storage;
- Atype : O_Tnode);
+ procedure New_Const_Decl (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
-- Set the value to DECL.
procedure New_Init_Value (Decl : O_Dnode; Val : O_Cnode);
@@ -138,11 +140,10 @@ package Ortho_Code.Decls is
-- Create a variable declaration.
-- A variable can be local only inside a function.
-- ATYPE must be constrained.
- procedure New_Var_Decl
- (Res : out O_Dnode;
- Ident : O_Ident;
- Storage : O_Storage;
- Atype : O_Tnode);
+ procedure New_Var_Decl (Res : out O_Dnode;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Atype : O_Tnode);
type O_Inter_List is limited private;
@@ -151,23 +152,20 @@ package Ortho_Code.Decls is
-- be declared inside a subprograms. It is not allowed to declare
-- o_storage_external subprograms inside a subprograms.
-- Return type and interfaces cannot be a composite type.
- procedure Start_Function_Decl
- (Interfaces : out O_Inter_List;
- Ident : O_Ident;
- Storage : O_Storage;
- Rtype : O_Tnode);
+ procedure Start_Function_Decl (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage;
+ Rtype : O_Tnode);
-- For a subprogram without return value.
- procedure Start_Procedure_Decl
- (Interfaces : out O_Inter_List;
- Ident : O_Ident;
- Storage : O_Storage);
+ procedure Start_Procedure_Decl (Interfaces : out O_Inter_List;
+ Ident : O_Ident;
+ Storage : O_Storage);
-- Add an interface declaration to INTERFACES.
- procedure New_Interface_Decl
- (Interfaces : in out O_Inter_List;
- Res : out O_Dnode;
- Ident : O_Ident;
- Atype : O_Tnode);
+ procedure New_Interface_Decl (Interfaces : in out O_Inter_List;
+ Res : out O_Dnode;
+ Ident : O_Ident;
+ Atype : O_Tnode);
-- Finish the function declaration, get the node and a statement list.
procedure Finish_Subprogram_Decl
(Interfaces : in out O_Inter_List; Res : out O_Dnode);
diff --git a/src/ortho/mcode/ortho_code-disps.adb b/src/ortho/mcode/ortho_code-disps.adb
index d33fe403d..b0b9a353a 100644
--- a/src/ortho/mcode/ortho_code-disps.adb
+++ b/src/ortho/mcode/ortho_code-disps.adb
@@ -273,18 +273,18 @@ package body Ortho_Code.Disps is
begin
Op := Get_Expr_Operand (Expr);
case Get_Expr_Kind (Op) is
- when OE_Addrg
+ when OE_Addrd
| OE_Addrl =>
- Decls.Disp_Decl_Name (Get_Addr_Object (Op));
+ Decls.Disp_Decl_Name (Get_Addr_Decl (Op));
when others =>
--Put ("*");
Disp_Expr (Op);
end case;
end;
when OE_Addrl
- | OE_Addrg =>
+ | OE_Addrd =>
-- Put ('@');
- Decls.Disp_Decl_Name (Get_Addr_Object (Expr));
+ Decls.Disp_Decl_Name (Get_Addr_Decl (Expr));
when OE_Call =>
Disp_Call (Expr);
when OE_Alloca =>
diff --git a/src/ortho/mcode/ortho_code-exprs.adb b/src/ortho/mcode/ortho_code-exprs.adb
index 4e0d6bdc4..fd467e315 100644
--- a/src/ortho/mcode/ortho_code-exprs.adb
+++ b/src/ortho/mcode/ortho_code-exprs.adb
@@ -160,11 +160,16 @@ package body Ortho_Code.Exprs is
Enodes.Table (Enode).Arg2 := Label;
end Set_Jump_Label;
- function Get_Addr_Object (Enode : O_Enode) return O_Dnode is
+ function Get_Addr_Object (Enode : O_Enode) return O_Lnode is
begin
- return O_Dnode (Enodes.Table (Enode).Arg1);
+ return O_Lnode (Enodes.Table (Enode).Arg1);
end Get_Addr_Object;
+ function Get_Addr_Decl (Enode : O_Enode) return O_Dnode is
+ begin
+ return O_Dnode (Enodes.Table (Enode).Arg1);
+ end Get_Addr_Decl;
+
function Get_Addrl_Frame (Enode : O_Enode) return O_Enode is
begin
return Enodes.Table (Enode).Arg2;
@@ -492,7 +497,7 @@ package body Ortho_Code.Exprs is
Save_Var : O_Dnode;
begin
Save_Asgn := Get_Stmt_Link (Blk);
- Save_Var := Get_Addr_Object (Get_Assign_Target (Save_Asgn));
+ Save_Var := Get_Addr_Decl (Get_Assign_Target (Save_Asgn));
New_Enode_Stmt (OE_Set_Stack, New_Value (New_Obj (Save_Var)),
O_Enode_Null);
end New_Stack_Restore;
@@ -696,10 +701,8 @@ package body Ortho_Code.Exprs is
function New_Lit (Lit : O_Cnode) return O_Enode
is
- L_Type : O_Tnode;
- H, L : Uns32;
+ L_Type : constant O_Tnode := Get_Const_Type (Lit);
begin
- L_Type := Get_Const_Type (Lit);
if Flag_Debug_Hli then
return New_Enode (OE_Lit, L_Type, O_Enode (Lit), O_Enode_Null);
else
@@ -709,13 +712,18 @@ package body Ortho_Code.Exprs is
| OC_Float
| OC_Null
| OC_Lit =>
- Get_Const_Bytes (Lit, H, L);
- return New_Enode
- (OE_Const, L_Type,
- O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H)));
- when OC_Address
- | OC_Subprg_Address =>
- return New_Enode (OE_Addrg, L_Type,
+ declare
+ H, L : Uns32;
+ begin
+ Get_Const_Bytes (Lit, H, L);
+ return New_Enode
+ (OE_Const, L_Type,
+ O_Enode (To_Int32 (L)), O_Enode (To_Int32 (H)));
+ end;
+ when OC_Address =>
+ raise Syntax_Error;
+ when OC_Subprg_Address =>
+ return New_Enode (OE_Addrd, L_Type,
O_Enode (Get_Const_Decl (Lit)), O_Enode_Null);
when OC_Array
| OC_Record
@@ -783,7 +791,7 @@ package body Ortho_Code.Exprs is
end if;
when OD_Var
| OD_Const =>
- Kind := OE_Addrg;
+ Kind := OE_Addrd;
Chain := O_Enode_Null;
when others =>
raise Program_Error;
diff --git a/src/ortho/mcode/ortho_code-exprs.ads b/src/ortho/mcode/ortho_code-exprs.ads
index 31931702c..0bb5ec2bb 100644
--- a/src/ortho/mcode/ortho_code-exprs.ads
+++ b/src/ortho/mcode/ortho_code-exprs.ads
@@ -63,9 +63,9 @@ package Ortho_Code.Exprs is
-- ARG1 is object.
-- ARG2 is the frame pointer or O_Enode_Null for current frame pointer.
OE_Addrl,
- -- Address of a global variable.
- -- ARG1 is object.
- OE_Addrg,
+ -- Address of a declaration.
+ -- ARG1 is the declaration.
+ OE_Addrd,
-- Pointer dereference.
-- ARG1 is operand.
@@ -214,7 +214,6 @@ package Ortho_Code.Exprs is
subtype OE_Kind_Dyadic is OE_Kind range OE_Add_Ov .. OE_Xor;
subtype OE_Kind_Cmp is OE_Kind range OE_Eq .. OE_Gt;
-
-- BE representation of an instruction.
type O_Insn is mod 256;
@@ -329,8 +328,11 @@ package Ortho_Code.Exprs is
function Get_Jump_Label (Enode : O_Enode) return O_Enode;
procedure Set_Jump_Label (Enode : O_Enode; Label : O_Enode);
- -- Get the object of addrl,addrp,addrg
- function Get_Addr_Object (Enode : O_Enode) return O_Dnode;
+ -- Get the declaration of addrl,addrp,addrs
+ function Get_Addr_Decl (Enode : O_Enode) return O_Dnode;
+
+ -- Get the object of addrg
+ function Get_Addr_Object (Enode : O_Enode) return O_Lnode;
-- Get the computed frame for the object.
-- If O_Enode_Null, then use current frame.
diff --git a/src/ortho/mcode/ortho_code-types.ads b/src/ortho/mcode/ortho_code-types.ads
index da6549841..a9d15b60a 100644
--- a/src/ortho/mcode/ortho_code-types.ads
+++ b/src/ortho/mcode/ortho_code-types.ads
@@ -24,6 +24,8 @@ package Ortho_Code.Types is
-- Optionnal.
OT_Complete);
+ subtype OT_Kinds_Record_Union is OT_Kind range OT_Record .. OT_Union;
+
-- Kind of ATYPE.
function Get_Type_Kind (Atype : O_Tnode) return OT_Kind;
@@ -237,4 +239,3 @@ private
end record;
end Ortho_Code.Types;
-
diff --git a/src/ortho/mcode/ortho_code-x86-abi.adb b/src/ortho/mcode/ortho_code-x86-abi.adb
index d76563a3e..ba9b437d9 100644
--- a/src/ortho/mcode/ortho_code-x86-abi.adb
+++ b/src/ortho/mcode/ortho_code-x86-abi.adb
@@ -243,7 +243,7 @@ package body Ortho_Code.X86.Abi is
is
use Ada.Text_IO;
use Ortho_Code.Debug.Int32_IO;
- Obj : constant O_Dnode := Get_Addr_Object (Stmt);
+ Obj : constant O_Dnode := Get_Addr_Decl (Stmt);
Frame : constant O_Enode := Get_Addrl_Frame (Stmt);
begin
if Frame = O_Enode_Null then
@@ -315,9 +315,9 @@ package body Ortho_Code.X86.Abi is
case Kind is
when OE_Const =>
Disp_Const (Stmt);
- when OE_Addrg =>
+ when OE_Addrd =>
Put ("&");
- Disp_Decl_Name (Get_Addr_Object (Stmt));
+ Disp_Decl_Name (Get_Addr_Decl (Stmt));
when OE_Add =>
Disp_Irm_Code (Get_Expr_Left (Stmt));
Put ("+");
@@ -348,9 +348,9 @@ package body Ortho_Code.X86.Abi is
Disp_Irm_Code (Get_Expr_Left (Stmt));
Put (" + ");
Disp_Irm_Code (Get_Expr_Right (Stmt));
- when OE_Addrg =>
+ when OE_Addrd =>
Put ("&");
- Disp_Decl_Name (Get_Addr_Object (Stmt));
+ Disp_Decl_Name (Get_Addr_Decl (Stmt));
when others =>
raise Program_Error;
end case;
@@ -587,10 +587,10 @@ package body Ortho_Code.X86.Abi is
Disp_Local (Stmt);
Put (")");
New_Line;
- when OE_Addrg =>
- Disp_Reg_Op_Name ("lea{addrg}");
+ when OE_Addrd =>
+ Disp_Reg_Op_Name ("lea{addrd}");
Put ("&");
- Disp_Decl_Name (Get_Addr_Object (Stmt));
+ Disp_Decl_Name (Get_Addr_Decl (Stmt));
New_Line;
when OE_Add =>
Disp_Reg_Op_Name ("lea{add}");
diff --git a/src/ortho/mcode/ortho_code-x86-emits.adb b/src/ortho/mcode/ortho_code-x86-emits.adb
index d26a830f7..cc27a3a23 100644
--- a/src/ortho/mcode/ortho_code-x86-emits.adb
+++ b/src/ortho/mcode/ortho_code-x86-emits.adb
@@ -277,8 +277,8 @@ package body Ortho_Code.X86.Emits is
Off := Off + To_Int32 (Get_Expr_Low (C));
P := S;
end loop;
- pragma Assert (Get_Expr_Kind (P) = OE_Addrg);
- Sym := Get_Decl_Symbol (Get_Addr_Object (P));
+ pragma Assert (Get_Expr_Kind (P) = OE_Addrd);
+ Sym := Get_Decl_Symbol (Get_Addr_Decl (P));
Gen_Abs (Sym, Integer_32 (Off));
end Gen_Imm_Addr;
@@ -303,7 +303,7 @@ package body Ortho_Code.X86.Emits is
Gen_32 (Unsigned_32 (Get_Expr_Low (N)));
end case;
when OE_Add
- | OE_Addrg =>
+ | OE_Addrd =>
-- Only for 32-bit immediat.
pragma Assert (Sz = Sz_32);
Gen_Imm_Addr (N);
@@ -470,11 +470,11 @@ package body Ortho_Code.X86.Emits is
Rm_Base := Get_Expr_Reg (Frame);
end if;
end;
- Rm_Offset := Rm_Offset + Get_Local_Offset (Get_Addr_Object (N));
- when OE_Addrg =>
+ Rm_Offset := Rm_Offset + Get_Local_Offset (Get_Addr_Decl (N));
+ when OE_Addrd =>
-- Cannot add two symbols.
pragma Assert (Rm_Sym = Null_Symbol);
- Rm_Sym := Get_Decl_Symbol (Get_Addr_Object (N));
+ Rm_Sym := Get_Decl_Symbol (Get_Addr_Decl (N));
when OE_Add =>
Fill_Sib (Get_Expr_Left (N));
Fill_Sib (Get_Expr_Right (N));
@@ -2525,10 +2525,10 @@ package body Ortho_Code.X86.Emits is
-- Result is in eflags.
pragma Assert (Get_Expr_Reg (Stmt) in Regs_Cc);
end;
- when OE_Addrg =>
+ when OE_Addrd =>
pragma Assert (Mode = Abi.Mode_Ptr);
if Flags.M64
- and then not Insns.Is_External_Object (Get_Addr_Object (Stmt))
+ and then not Insns.Is_External_Object (Get_Addr_Decl (Stmt))
then
-- Use RIP relative to load an address.
Emit_Lea (Stmt);
@@ -3163,8 +3163,15 @@ package body Ortho_Code.X86.Emits is
when others =>
raise Program_Error;
end case;
- when OC_Address
- | OC_Subprg_Address =>
+ when OC_Address =>
+ declare
+ Decl : O_Dnode;
+ Off : Uns32;
+ begin
+ Get_Global_Decl_Offset (Get_Const_Global (Val), Decl, Off);
+ Gen_Abs (Get_Decl_Symbol (Decl), Integer_32 (To_Int32 (Off)));
+ end;
+ when OC_Subprg_Address =>
Gen_Abs (Get_Decl_Symbol (Get_Const_Decl (Val)), 0);
when OC_Array =>
for I in 0 .. Get_Const_Aggr_Length (Val) - 1 loop
diff --git a/src/ortho/mcode/ortho_code-x86-insns.adb b/src/ortho/mcode/ortho_code-x86-insns.adb
index acdcc7746..5429df016 100644
--- a/src/ortho/mcode/ortho_code-x86-insns.adb
+++ b/src/ortho/mcode/ortho_code-x86-insns.adb
@@ -848,7 +848,7 @@ package body Ortho_Code.X86.Insns is
Set_Addrl_Frame (Expr, Reload (Spill, R_Any32, Num));
end if;
return Expr;
- when OE_Addrg =>
+ when OE_Addrd =>
return Expr;
when others =>
Error_Reg ("reload: unhandle expr in b_off", Expr, Dest);
@@ -938,7 +938,7 @@ package body Ortho_Code.X86.Insns is
if Get_Addrl_Frame (Insn) /= O_Enode_Null then
Free_Insn_Regs (Get_Addrl_Frame (Insn));
end if;
- when OE_Addrg =>
+ when OE_Addrd =>
-- RIP-relative, no reg to free.
null;
when others =>
@@ -1358,11 +1358,11 @@ package body Ortho_Code.X86.Insns is
when others =>
Error_Gen_Insn (Stmt, Reg);
end case;
- when OE_Addrg =>
+ when OE_Addrd =>
if Flags.M64 then
-- Use RIP-Relative addressing.
if Reg = R_Sib
- and then not Is_External_Object (Get_Addr_Object (Stmt))
+ and then not Is_External_Object (Get_Addr_Decl (Stmt))
then
Set_Expr_Reg (Stmt, R_Sib);
else
diff --git a/src/ortho/mcode/ortho_code.ads b/src/ortho/mcode/ortho_code.ads
index 0657b07e6..489eeeccf 100644
--- a/src/ortho/mcode/ortho_code.ads
+++ b/src/ortho/mcode/ortho_code.ads
@@ -65,6 +65,10 @@ package Ortho_Code is
for O_Lnode'Size use 32;
O_Lnode_Null : constant O_Lnode := 0;
+ type O_Gnode is new Int32;
+ for O_Gnode'Size use 32;
+ O_Gnode_Null : constant O_Gnode := 0;
+
type O_Ident is new Int32;
O_Ident_Nul : constant O_Ident := 0;
diff --git a/src/ortho/mcode/ortho_mcode.adb b/src/ortho/mcode/ortho_mcode.adb
index fac45e438..16638300d 100644
--- a/src/ortho/mcode/ortho_mcode.adb
+++ b/src/ortho/mcode/ortho_mcode.adb
@@ -347,22 +347,36 @@ package body Ortho_Mcode is
(Ortho_Code.O_Dnode (Subprg), Ortho_Code.O_Tnode (Atype)));
end New_Subprogram_Address;
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode is
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode is
begin
return O_Cnode
(Ortho_Code.Consts.New_Global_Address
- (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype)));
+ (Ortho_Code.O_Gnode (Lvalue), Ortho_Code.O_Tnode (Atype)));
end New_Global_Address;
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode is
begin
return O_Cnode
(Ortho_Code.Consts.New_Global_Unchecked_Address
- (Ortho_Code.O_Dnode (Decl), Ortho_Code.O_Tnode (Atype)));
+ (Ortho_Code.O_Gnode (Lvalue), Ortho_Code.O_Tnode (Atype)));
end New_Global_Unchecked_Address;
+ function New_Global (Decl : O_Dnode) return O_Gnode is
+ begin
+ return O_Gnode
+ (Ortho_Code.Consts.New_Global (Ortho_Code.O_Dnode (Decl)));
+ end New_Global;
+
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode is
+ begin
+ return O_Gnode
+ (Ortho_Code.Consts.New_Global_Selected_Element
+ (Ortho_Code.O_Gnode (Rec), Ortho_Code.O_Fnode (El)));
+ end New_Global_Selected_Element;
+
function New_Lit (Lit : O_Cnode) return O_Enode is
begin
return O_Enode (Ortho_Code.Exprs.New_Lit (Ortho_Code.O_Cnode (Lit)));
diff --git a/src/ortho/mcode/ortho_mcode.ads b/src/ortho/mcode/ortho_mcode.ads
index dda220f1c..515242561 100644
--- a/src/ortho/mcode/ortho_mcode.ads
+++ b/src/ortho/mcode/ortho_mcode.ads
@@ -41,10 +41,12 @@ package Ortho_Mcode is
type O_Tnode is private;
type O_Snode is private;
type O_Dnode is private;
+ type O_Gnode is private;
type O_Fnode is private;
O_Cnode_Null : constant O_Cnode;
O_Dnode_Null : constant O_Dnode;
+ O_Gnode_Null : constant O_Gnode;
O_Enode_Null : constant O_Enode;
O_Fnode_Null : constant O_Fnode;
O_Lnode_Null : constant O_Lnode;
@@ -190,17 +192,17 @@ package Ortho_Mcode is
-- Get the address of a subprogram.
function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ return O_Cnode;
-- Get the address of LVALUE.
-- ATYPE must be a type access whose designated type is the type of LVALUE.
-- FIXME: what about arrays.
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode;
-- Same as New_Address but without any restriction.
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode;
-------------------
-- Expressions --
@@ -299,12 +301,15 @@ package Ortho_Mcode is
-- base type of ARR.
-- INDEX must be of the type of the array index.
function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
- return O_Lnode;
+ return O_Lnode;
-- Get an element of a record or a union.
-- Type of REC must be a record or a union type.
function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
- return O_Lnode;
+ return O_Lnode;
+
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode;
-- Reference an access.
-- Type of ACC must be an access type.
@@ -331,6 +336,9 @@ package Ortho_Mcode is
-- Get an lvalue from a declaration.
function New_Obj (Obj : O_Dnode) return O_Lnode;
+ -- Get a global lvalue from a declaration.
+ function New_Global (Decl : O_Dnode) return O_Gnode;
+
-- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
@@ -476,9 +484,11 @@ private
type O_Enode is new Ortho_Code.O_Enode;
type O_Fnode is new Ortho_Code.O_Fnode;
type O_Lnode is new Ortho_Code.O_Lnode;
+ type O_Gnode is new Ortho_Code.O_Gnode;
type O_Snode is new Ortho_Code.Exprs.O_Snode;
O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null);
+ O_Gnode_Null : constant O_Gnode := O_Gnode (Ortho_Code.O_Gnode_Null);
O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null);
O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null);
O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null);
diff --git a/src/ortho/mcode/ortho_mcode.private.ads b/src/ortho/mcode/ortho_mcode.private.ads
index 5374ae978..a78a1a170 100644
--- a/src/ortho/mcode/ortho_mcode.private.ads
+++ b/src/ortho/mcode/ortho_mcode.private.ads
@@ -40,9 +40,11 @@ private
type O_Enode is new Ortho_Code.O_Enode;
type O_Fnode is new Ortho_Code.O_Fnode;
type O_Lnode is new Ortho_Code.O_Lnode;
+ type O_Gnode is new Ortho_Code.O_Gnode;
type O_Snode is new Ortho_Code.Exprs.O_Snode;
O_Lnode_Null : constant O_Lnode := O_Lnode (Ortho_Code.O_Lnode_Null);
+ O_Gnode_Null : constant O_Gnode := O_Gnode (Ortho_Code.O_Gnode_Null);
O_Cnode_Null : constant O_Cnode := O_Cnode (Ortho_Code.O_Cnode_Null);
O_Dnode_Null : constant O_Dnode := O_Dnode (Ortho_Code.O_Dnode_Null);
O_Enode_Null : constant O_Enode := O_Enode (Ortho_Code.O_Enode_Null);
diff --git a/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb
index 13fdc77ae..b3d9d3a08 100644
--- a/src/ortho/oread/ortho_front.adb
+++ b/src/ortho/oread/ortho_front.adb
@@ -1842,9 +1842,15 @@ package body Ortho_Front is
end case;
end Parse_Expression;
+ procedure Check_Selected_Prefix (N_Type : Node_Acc) is
+ begin
+ if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union then
+ Parse_Error ("type of prefix is neither a record nor an union");
+ end if;
+ end Check_Selected_Prefix;
+
-- Expect and leave: next token
- procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc)
- is
+ procedure Parse_Lvalue (N : in out O_Lnode; N_Type : in out Node_Acc) is
begin
loop
case Tok is
@@ -1858,11 +1864,7 @@ package body Ortho_Front is
N_Type := N_Type.Access_Dtype;
Next_Token;
elsif Tok = Tok_Ident then
- if N_Type.Kind /= Type_Record and N_Type.Kind /= Type_Union
- then
- Parse_Error
- ("type of prefix is neither a record nor an union");
- end if;
+ Check_Selected_Prefix (N_Type);
declare
Field : Node_Acc;
begin
@@ -2501,12 +2503,50 @@ package body Ortho_Front is
return Res;
end Parse_Address;
+ procedure Parse_Global_Name (Prefix : Node_Acc;
+ Name : out O_Gnode; N_Type : out Node_Acc)
+ is
+ begin
+ case Prefix.Kind is
+ when Node_Object =>
+ Name := New_Global (Prefix.Obj_Node);
+ N_Type := Prefix.Decl_Dtype;
+ when others =>
+ Parse_Error ("invalid name");
+ end case;
+
+ loop
+ case Tok is
+ when Tok_Dot =>
+ Next_Token;
+ if Tok = Tok_Ident then
+ Check_Selected_Prefix (N_Type);
+ declare
+ Field : Node_Acc;
+ begin
+ Field := Find_Field_By_Name (N_Type);
+ Name := New_Global_Selected_Element (Name,
+ Field.Field_Fnode);
+ N_Type := Field.Field_Type;
+ Next_Token;
+ end;
+ else
+ Parse_Error ("'.' must be followed by a field name");
+ end if;
+ when others =>
+ return;
+ end case;
+ end loop;
+ end Parse_Global_Name;
+
function Parse_Constant_Address (Prefix : Node_Acc) return O_Cnode
is
Pfx : Node_Acc;
Res : O_Cnode;
Attr : Syment_Acc;
T : O_Tnode;
+ N : O_Gnode;
+ N_Type : Node_Acc;
begin
Attr := Token_Sym;
Next_Expect (Tok_Left_Paren);
@@ -2523,10 +2563,11 @@ package body Ortho_Front is
Next_Token;
else
Next_Token;
+ Parse_Global_Name (Pfx, N, N_Type);
if Attr = Id_Address then
- Res := New_Global_Address (Pfx.Obj_Node, T);
+ Res := New_Global_Address (N, T);
elsif Attr = Id_Unchecked_Address then
- Res := New_Global_Unchecked_Address (Pfx.Obj_Node, T);
+ Res := New_Global_Unchecked_Address (N, T);
else
Parse_Error ("address attribute expected");
end if;
diff --git a/src/ortho/ortho_nodes.common.ads b/src/ortho/ortho_nodes.common.ads
index d0f22b720..30e44d6fd 100644
--- a/src/ortho/ortho_nodes.common.ads
+++ b/src/ortho/ortho_nodes.common.ads
@@ -28,10 +28,12 @@ package ORTHO_NODES is
type O_Tnode is private;
type O_Snode is private;
type O_Dnode is private;
+ type O_Gnode is private;
type O_Fnode is private;
O_Cnode_Null : constant O_Cnode;
O_Dnode_Null : constant O_Dnode;
+ O_Gnode_Null : constant O_Gnode;
O_Enode_Null : constant O_Enode;
O_Fnode_Null : constant O_Fnode;
O_Lnode_Null : constant O_Lnode;
@@ -177,17 +179,17 @@ package ORTHO_NODES is
-- Get the address of a subprogram.
function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ return O_Cnode;
-- Get the address of LVALUE.
-- ATYPE must be a type access whose designated type is the type of LVALUE.
-- FIXME: what about arrays.
- function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode)
+ function New_Global_Address (Lvalue : O_Gnode; Atype : O_Tnode)
return O_Cnode;
-- Same as New_Address but without any restriction.
- function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode)
- return O_Cnode;
+ function New_Global_Unchecked_Address (Lvalue : O_Gnode; Atype : O_Tnode)
+ return O_Cnode;
-------------------
-- Expressions --
@@ -286,12 +288,15 @@ package ORTHO_NODES is
-- base type of ARR.
-- INDEX must be of the type of the array index.
function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode)
- return O_Lnode;
+ return O_Lnode;
-- Get an element of a record or a union.
-- Type of REC must be a record or a union type.
function New_Selected_Element (Rec : O_Lnode; El : O_Fnode)
- return O_Lnode;
+ return O_Lnode;
+
+ function New_Global_Selected_Element (Rec : O_Gnode; El : O_Fnode)
+ return O_Gnode;
-- Reference an access.
-- Type of ACC must be an access type.
@@ -318,6 +323,9 @@ package ORTHO_NODES is
-- Get an lvalue from a declaration.
function New_Obj (Obj : O_Dnode) return O_Lnode;
+ -- Get a global lvalue from a declaration.
+ function New_Global (Decl : O_Dnode) return O_Gnode;
+
-- Return a pointer of type RTPE to SIZE bytes allocated on the stack.
function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode;
diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads
index fdc34ebcd..b88b35217 100644
--- a/src/vhdl/iirs.ads
+++ b/src/vhdl/iirs.ads
@@ -1798,7 +1798,7 @@ package Iirs is
--
-- Get/Set_Type (Field1)
--
- -- Corresponding element_declaration. FIXME: remove as supersided by
+ -- Corresponding element_declaration. FIXME: remove as superseeded by
-- element_position.
-- Get/Set_Element_Declaration (Field5)
--
diff --git a/src/vhdl/sem_assocs.adb b/src/vhdl/sem_assocs.adb
index 8cc5fbf74..971962288 100644
--- a/src/vhdl/sem_assocs.adb
+++ b/src/vhdl/sem_assocs.adb
@@ -1012,6 +1012,8 @@ package body Sem_Assocs is
if Get_Constraint_State (Atype) /= Fully_Constrained then
-- Some (sub-)elements are unbounded, create a bounded subtype.
declare
+ Inter : constant Iir :=
+ Get_Interface_Of_Formal (Get_Formal (Assoc));
Ntype : Iir;
Nel_List : Iir_Flist;
Nrec_El : Iir;
@@ -1025,6 +1027,12 @@ package body Sem_Assocs is
Set_Resolution_Indication
(Ntype, Get_Resolution_Indication (Atype));
end if;
+ if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration
+ then
+ -- The subtype is used for signals.
+ Set_Has_Signal_Flag (Ntype, True);
+ end if;
+
Nel_List := Create_Iir_Flist (Nbr_El);
Set_Elements_Declaration_List (Ntype, Nel_List);
@@ -1096,7 +1104,7 @@ package body Sem_Assocs is
-- individual association ASSOC: compute bounds, detect missing elements.
procedure Finish_Individual_Association (Assoc : Iir)
is
- Formal : Iir;
+ Inter : Iir;
Atype : Iir;
begin
-- Guard.
@@ -1104,8 +1112,8 @@ package body Sem_Assocs is
return;
end if;
- Formal := Get_Interface_Of_Formal (Get_Formal (Assoc));
- Atype := Get_Type (Formal);
+ Inter := Get_Interface_Of_Formal (Get_Formal (Assoc));
+ Atype := Get_Type (Inter);
Set_Whole_Association_Flag (Assoc, True);
case Get_Kind (Atype) is
@@ -1118,6 +1126,11 @@ package body Sem_Assocs is
Atype := Create_Array_Subtype (Atype, Get_Location (Assoc));
Set_Index_Constraint_Flag (Atype, True);
Set_Constraint_State (Atype, Fully_Constrained);
+ if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration
+ then
+ -- The subtype is used for signals.
+ Set_Has_Signal_Flag (Atype, True);
+ end if;
Set_Actual_Type (Assoc, Atype);
Set_Actual_Type_Definition (Assoc, Atype);
Finish_Individual_Assoc_Array (Assoc, Assoc, 1);
diff --git a/src/vhdl/sem_types.adb b/src/vhdl/sem_types.adb
index 843f549e4..47432e140 100644
--- a/src/vhdl/sem_types.adb
+++ b/src/vhdl/sem_types.adb
@@ -1394,6 +1394,31 @@ package body Sem_Types is
(Def : Iir; Type_Mark : Iir; Resolution : Iir)
return Iir;
+ function Copy_Record_Element_Declaration (El : Iir; Parent : Iir) return Iir
+ is
+ New_El : Iir;
+ begin
+ case Get_Kind (El) is
+ when Iir_Kind_Element_Declaration =>
+ New_El := Create_Iir (Iir_Kind_Element_Declaration);
+ -- As this is a copy, it has no subtype indication.
+ Set_Subtype_Indication (New_El, Null_Iir);
+ when Iir_Kind_Record_Element_Constraint =>
+ New_El := Create_Iir (Iir_Kind_Record_Element_Constraint);
+ Set_Element_Declaration (New_El, Get_Element_Declaration (El));
+ when others =>
+ Error_Kind ("copy_record_element_declaration", El);
+ end case;
+ Location_Copy (New_El, El);
+ Set_Parent (New_El, Parent);
+ Set_Identifier (New_El, Get_Identifier (El));
+ Set_Type (New_El, Get_Type (El));
+ Set_Base_Element_Declaration
+ (New_El, Get_Base_Element_Declaration (El));
+ Set_Element_Position (New_El, Get_Element_Position (El));
+ return New_El;
+ end Copy_Record_Element_Declaration;
+
-- Create a copy of elements_declaration_list of SRC and set it to DST.
procedure Copy_Record_Elements_Declaration_List (Dst : Iir; Src : Iir)
is
@@ -1405,14 +1430,7 @@ package body Sem_Types is
Set_Elements_Declaration_List (Dst, New_El_List);
for I in Flist_First .. Flist_Last (El_List) loop
El := Get_Nth_Element (El_List, I);
- New_El := Create_Iir (Iir_Kind_Element_Declaration);
- Location_Copy (New_El, El);
- Set_Parent (New_El, Dst);
- Set_Identifier (New_El, Get_Identifier (El));
- Set_Type (New_El, Get_Type (El));
- Set_Base_Element_Declaration (New_El,
- Get_Base_Element_Declaration (El));
- Set_Element_Position (New_El, Get_Element_Position (El));
+ New_El := Copy_Record_Element_Declaration (El, Dst);
Set_Nth_Element (New_El_List, I, New_El);
end loop;
end Copy_Record_Elements_Declaration_List;
@@ -2030,7 +2048,7 @@ package body Sem_Types is
if Els (I) = Null_Iir and Res_Els (I) = Null_Iir then
-- No new record element constraints. Copy the element from
-- the type mark.
- El := Tm_El;
+ El := Copy_Record_Element_Declaration (Tm_El, Res);
El_Type := Get_Type (El);
else
if Els (I) = Null_Iir then
diff --git a/src/vhdl/translate/trans-chap12.adb b/src/vhdl/translate/trans-chap12.adb
index cad732752..dfd50856c 100644
--- a/src/vhdl/translate/trans-chap12.adb
+++ b/src/vhdl/translate/trans-chap12.adb
@@ -85,11 +85,9 @@ package body Trans.Chap12 is
(Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type,
Unsigned_64 (Elab_Nbr_Pkgs))));
New_Association
- (Assoc, New_Lit (New_Global_Address
- (Pkgs_Arr, Rtis.Ghdl_Rti_Arr_Acc)));
+ (Assoc, New_Address (New_Obj (Pkgs_Arr), Rtis.Ghdl_Rti_Arr_Acc));
New_Association
- (Assoc,
- New_Lit (Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const)));
+ (Assoc, Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const));
New_Association
(Assoc, New_Convert_Ov (Arch_Instance, Ghdl_Ptr_Type));
New_Procedure_Call (Assoc);
@@ -98,8 +96,7 @@ package body Trans.Chap12 is
Start_Association (Assoc, Ghdl_Rti_Add_Package);
New_Association
(Assoc,
- New_Lit (Rtis.New_Rti_Address
- (Get_Info (Standard_Package).Package_Rti_Const)));
+ Rtis.New_Rti_Address (Get_Info (Standard_Package).Package_Rti_Const));
New_Procedure_Call (Assoc);
end Call_Elab_Decls;
diff --git a/src/vhdl/translate/trans-chap14.adb b/src/vhdl/translate/trans-chap14.adb
index 2e554d556..b35cc9f81 100644
--- a/src/vhdl/translate/trans-chap14.adb
+++ b/src/vhdl/translate/trans-chap14.adb
@@ -809,8 +809,7 @@ package body Trans.Chap14 is
| Type_Mode_E32
| Type_Mode_P32
| Type_Mode_P64 =>
- New_Association
- (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti)));
+ New_Association (Assoc, Rtis.New_Rti_Address (Pinfo.Type_Rti));
when Type_Mode_I32
| Type_Mode_I64
| Type_Mode_F64 =>
@@ -857,8 +856,7 @@ package body Trans.Chap14 is
| Type_Mode_E32
| Type_Mode_P32
| Type_Mode_P64 =>
- New_Association
- (Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti)));
+ New_Association (Assoc, Rtis.New_Rti_Address (Pinfo.Type_Rti));
when Type_Mode_I32
| Type_Mode_I64
| Type_Mode_F64 =>
diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb
index 60040ea2e..374879857 100644
--- a/src/vhdl/translate/trans-chap2.adb
+++ b/src/vhdl/translate/trans-chap2.adb
@@ -1024,8 +1024,7 @@ package body Trans.Chap2 is
-- instantiated due to generate statements).
Start_Association (Constr, Ghdl_Rti_Add_Package);
New_Association
- (Constr,
- New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const)));
+ (Constr, Rtis.New_Rti_Address (Info.Package_Rti_Const));
New_Procedure_Call (Constr);
end if;
@@ -1160,7 +1159,12 @@ package body Trans.Chap2 is
null;
when Kind_Type_Array
| Kind_Type_Record =>
- null;
+ B.Builder (Mode_Value).Builder_Instance :=
+ Instantiate_Subprg_Instance
+ (Orig.Builder (Mode_Value).Builder_Instance);
+ B.Builder (Mode_Signal).Builder_Instance :=
+ Instantiate_Subprg_Instance
+ (Orig.Builder (Mode_Signal).Builder_Instance);
when Kind_Type_File =>
null;
when Kind_Type_Protected =>
@@ -1187,7 +1191,7 @@ package body Trans.Chap2 is
Res.Range_Var := Instantiate_Var (Src.Range_Var);
when Kind_Type_Array
| Kind_Type_Record =>
- Res.Composite_Bounds := Instantiate_Var (Src.Composite_Bounds);
+ Res.Composite_Layout := Instantiate_Var (Src.Composite_Layout);
when Kind_Type_File =>
null;
when Kind_Type_Protected =>
@@ -1206,45 +1210,13 @@ package body Trans.Chap2 is
Type_Incomplete => Src.Type_Incomplete,
Type_Locally_Constrained =>
Src.Type_Locally_Constrained,
- C => null,
Ortho_Type => Src.Ortho_Type,
Ortho_Ptr_Type => Src.Ortho_Ptr_Type,
B => Src.B,
S => Copy_Info_Subtype (Src.S),
Type_Rti => Src.Type_Rti);
Adjust_Info_Basetype (Dest.B'Unrestricted_Access,
- Src.B'Unrestricted_Access);
- if Src.C /= null then
- Dest.C := new Complex_Type_Arr_Info'
- (Mode_Value =>
- (Mark => False,
- Size_Var => Instantiate_Var
- (Src.C (Mode_Value).Size_Var),
- Builder_Need_Func =>
- Src.C (Mode_Value).Builder_Need_Func,
- Builder_Instance => Instantiate_Subprg_Instance
- (Src.C (Mode_Value).Builder_Instance),
- Builder_Base_Param =>
- Src.C (Mode_Value).Builder_Base_Param,
- Builder_Bound_Param =>
- Src.C (Mode_Value).Builder_Bound_Param,
- Builder_Func =>
- Src.C (Mode_Value).Builder_Func),
- Mode_Signal =>
- (Mark => False,
- Size_Var => Instantiate_Var
- (Src.C (Mode_Signal).Size_Var),
- Builder_Need_Func =>
- Src.C (Mode_Signal).Builder_Need_Func,
- Builder_Instance => Instantiate_Subprg_Instance
- (Src.C (Mode_Signal).Builder_Instance),
- Builder_Base_Param =>
- Src.C (Mode_Signal).Builder_Base_Param,
- Builder_Bound_Param =>
- Src.C (Mode_Signal).Builder_Bound_Param,
- Builder_Func =>
- Src.C (Mode_Signal).Builder_Func));
- end if;
+ Src.B'Unrestricted_Access);
when Kind_Object =>
Dest.all :=
(Kind => Kind_Object,
diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb
index ced7e1a94..624b95a25 100644
--- a/src/vhdl/translate/trans-chap3.adb
+++ b/src/vhdl/translate/trans-chap3.adb
@@ -32,8 +32,6 @@ with Translation;
package body Trans.Chap3 is
use Trans.Helpers;
- function Unbox_Record (Arr : Mnode) return Mnode;
-
function Create_Static_Type_Definition_Type_Range (Def : Iir)
return O_Cnode;
procedure Elab_Scalar_Type_Range (Def : Iir; Target : O_Lnode);
@@ -43,11 +41,114 @@ package body Trans.Chap3 is
Base : Iir;
Subtype_Info : Type_Info_Acc);
+ function Get_Composite_Type_Layout (Info : Type_Info_Acc) return Mnode
+ is
+ begin
+ case Info.Type_Mode is
+ when Type_Mode_Unbounded =>
+ raise Internal_Error;
+ when Type_Mode_Bounded_Arrays
+ | Type_Mode_Bounded_Records =>
+ return Varv2M (Info.S.Composite_Layout,
+ Info, Mode_Value,
+ Info.B.Layout_Type,
+ Info.B.Layout_Ptr_Type);
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Get_Composite_Type_Layout;
+
+ function Layout_To_Bounds (B : Mnode) return Mnode
+ is
+ Info : constant Type_Info_Acc := Get_Type_Info (B);
+ begin
+ case Info.Type_Mode is
+ when Type_Mode_Arrays =>
+ return Lv2M (New_Selected_Element (M2Lv (B), Info.B.Layout_Bounds),
+ Info, Mode_Value,
+ Info.B.Bounds_Type, Info.B.Bounds_Ptr_Type);
+ when Type_Mode_Records =>
+ return B;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Layout_To_Bounds;
+
+ function Layout_To_Sizes (B : Mnode) return O_Lnode
+ is
+ Info : constant Type_Info_Acc := Get_Type_Info (B);
+ begin
+ return New_Selected_Element (M2Lv (B), Info.B.Layout_Size);
+ end Layout_To_Sizes;
+
+ function Layout_To_Sizes (B : Mnode) return Mnode is
+ begin
+ return Lv2M (Layout_To_Sizes (B), Get_Type_Info (B), Mode_Value,
+ Ghdl_Sizes_Type, Ghdl_Sizes_Ptr);
+ end Layout_To_Sizes;
+
+ function Sizes_To_Size (Sizes : O_Lnode; Kind : Object_Kind_Type)
+ return O_Lnode
+ is
+ Field : O_Fnode;
+ begin
+ case Kind is
+ when Mode_Value =>
+ Field := Ghdl_Sizes_Val;
+ when Mode_Signal =>
+ Field := Ghdl_Sizes_Sig;
+ end case;
+ return New_Selected_Element (Sizes, Field);
+ end Sizes_To_Size;
+
+ function Layout_To_Size (Layout : Mnode; Kind : Object_Kind_Type)
+ return O_Lnode is
+ begin
+ return Sizes_To_Size (M2Lv (Layout_To_Sizes (Layout)), Kind);
+ end Layout_To_Size;
+
+ function Record_Layout_To_Element_Layout (B : Mnode; El : Iir) return Mnode
+ is
+ El_Type : constant Iir := Get_Type (El);
+ El_Info : constant Field_Info_Acc := Get_Info (El);
+ El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
+ begin
+ return Lv2M (New_Selected_Element (M2Lv (B),
+ El_Info.Field_Bound),
+ El_Tinfo, Mode_Value,
+ El_Tinfo.B.Layout_Type, El_Tinfo.B.Layout_Ptr_Type);
+ end Record_Layout_To_Element_Layout;
+
+ function Record_Layout_To_Element_Offset
+ (B : Mnode; El : Iir; Kind : Object_Kind_Type) return O_Lnode
+ is
+ El_Info : constant Field_Info_Acc := Get_Info (El);
+ begin
+ return New_Selected_Element (M2Lv (B), El_Info.Field_Node (Kind));
+ end Record_Layout_To_Element_Offset;
+
+ function Array_Bounds_To_Element_Layout (B : Mnode; Atype : Iir)
+ return Mnode
+ is
+ Arr_Tinfo : constant Type_Info_Acc := Get_Info (Atype);
+ El_Type : constant Iir := Get_Element_Subtype (Atype);
+ El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
+ begin
+ return Lv2M (New_Selected_Element (M2Lv (B), Arr_Tinfo.B.Bounds_El),
+ El_Tinfo, Mode_Value,
+ El_Tinfo.B.Layout_Type, El_Tinfo.B.Layout_Ptr_Type);
+ end Array_Bounds_To_Element_Layout;
+
+ function Array_Layout_To_Element_Layout (B : Mnode; Arr_Type : Iir)
+ return Mnode is
+ begin
+ return Array_Bounds_To_Element_Layout (Layout_To_Bounds (B), Arr_Type);
+ end Array_Layout_To_Element_Layout;
+
-- Finish a type definition: declare the type, define and declare a
-- pointer to the type.
procedure Finish_Type_Definition
- (Info : Type_Info_Acc; Completion : Boolean := False)
- is
+ (Info : Type_Info_Acc; Completion : Boolean := False) is
begin
-- Declare the type.
if not Completion then
@@ -83,31 +184,6 @@ package body Trans.Chap3 is
end if;
end Finish_Type_Definition;
- procedure Set_Complex_Type (Info : Type_Info_Acc; Need_Builder : Boolean) is
- begin
- pragma Assert (Info.C = null);
- Info.C := new Complex_Type_Arr_Info;
- -- No size variable for unconstrained array type.
- for Mode in Object_Kind_Type loop
- Info.C (Mode).Builder_Need_Func := Need_Builder;
- end loop;
- end Set_Complex_Type;
-
- procedure Copy_Complex_Type (Dest : Type_Info_Acc; Src : Type_Info_Acc) is
- begin
- Dest.C := new Complex_Type_Arr_Info'(Src.C.all);
- end Copy_Complex_Type;
-
- procedure Create_Size_Var (Def : Iir; Info : Type_Info_Acc) is
- begin
- Info.C (Mode_Value).Size_Var := Create_Var
- (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type);
- if Get_Has_Signal_Flag (Def) then
- Info.C (Mode_Signal).Size_Var := Create_Var
- (Create_Var_Identifier ("SIGSIZE"), Ghdl_Index_Type);
- end if;
- end Create_Size_Var;
-
-- A builder set internal fields of object pointed by BASE_PTR, using
-- memory from BASE_PTR and returns a pointer to the next memory byte
-- to be used.
@@ -117,7 +193,6 @@ package body Trans.Chap3 is
is
Interface_List : O_Inter_List;
Ident : O_Ident;
- Ptype : O_Tnode;
begin
case Kind is
when Mode_Value =>
@@ -126,63 +201,27 @@ package body Trans.Chap3 is
Ident := Create_Identifier (Name, "_SIGBUILDER");
end case;
-- FIXME: return the same type as its first parameter ???
- Start_Function_Decl
- (Interface_List, Ident, Global_Storage, Ghdl_Index_Type);
+ Start_Procedure_Decl (Interface_List, Ident, Global_Storage);
Subprgs.Add_Subprg_Instance_Interfaces
- (Interface_List, Info.C (Kind).Builder_Instance);
- case Info.Type_Mode is
- when Type_Mode_Unbounded =>
- Ptype := Info.B.Base_Ptr_Type (Kind);
- when Type_Mode_Complex_Record =>
- Ptype := Info.Ortho_Ptr_Type (Kind);
- when others =>
- raise Internal_Error;
- end case;
+ (Interface_List, Info.B.Builder (Kind).Builder_Instance);
New_Interface_Decl
- (Interface_List, Info.C (Kind).Builder_Base_Param,
- Get_Identifier ("base_ptr"), Ptype);
- -- Add parameter for array bounds.
- if Info.Type_Mode in Type_Mode_Unbounded then
- New_Interface_Decl
- (Interface_List, Info.C (Kind).Builder_Bound_Param,
- Get_Identifier ("bound"), Info.B.Bounds_Ptr_Type);
- end if;
- Finish_Subprogram_Decl (Interface_List, Info.C (Kind).Builder_Func);
+ (Interface_List, Info.B.Builder (Kind).Builder_Layout_Param,
+ Get_Identifier ("layout_ptr"), Info.B.Layout_Ptr_Type);
+ Finish_Subprogram_Decl
+ (Interface_List, Info.B.Builder (Kind).Builder_Proc);
end Create_Builder_Subprogram_Decl;
- function Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir) return O_Enode
+ procedure Gen_Call_Type_Builder
+ (Layout : Mnode; Var_Type : Iir; Kind : Object_Kind_Type)
is
- Kind : constant Object_Kind_Type := Get_Object_Kind (Var);
Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Var_Type));
Assoc : O_Assoc_List;
begin
- -- Build the field
- Start_Association (Assoc, Binfo.C (Kind).Builder_Func);
+ Start_Association (Assoc, Binfo.B.Builder (Kind).Builder_Proc);
Subprgs.Add_Subprg_Instance_Assoc
- (Assoc, Binfo.C (Kind).Builder_Instance);
-
- -- Note: a fat array can only be at the top of a complex type;
- -- the bounds must have been set.
- New_Association
- (Assoc, M2Addr (Chap3.Get_Composite_Base (Var)));
-
- if Binfo.Type_Mode in Type_Mode_Unbounded then
- New_Association (Assoc, M2Addr (Chap3.Get_Composite_Bounds (Var)));
- end if;
-
- return New_Function_Call (Assoc);
- end Gen_Call_Type_Builder;
-
- procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir)
- is
- Mem : O_Dnode;
- V : Mnode;
- begin
- Open_Temp;
- V := Stabilize (Var);
- Mem := Create_Temp (Ghdl_Index_Type);
- New_Assign_Stmt (New_Obj (Mem), Gen_Call_Type_Builder (V, Var_Type));
- Close_Temp;
+ (Assoc, Binfo.B.Builder (Kind).Builder_Instance);
+ New_Association (Assoc, M2Addr (Layout));
+ New_Procedure_Call (Assoc);
end Gen_Call_Type_Builder;
------------------
@@ -246,8 +285,10 @@ package body Trans.Chap3 is
Finish_Enum_Type (Constr, Info.Ortho_Type (Mode_Value));
if Nbr <= 256 then
Info.Type_Mode := Type_Mode_E8;
+ Info.B.Align := Align_8;
else
Info.Type_Mode := Type_Mode_E32;
+ Info.B.Align := Align_32;
end if;
-- Enumerations are always in their range.
Info.S.Nocheck_Low := True;
@@ -275,6 +316,7 @@ package body Trans.Chap3 is
Set_Ortho_Expr (True_Lit, True_Node);
Info.S.Nocheck_Low := True;
Info.S.Nocheck_Hi := True;
+ Info.B.Align := Align_8;
Finish_Type_Definition (Info);
end Translate_Bool_Type;
@@ -315,9 +357,11 @@ package body Trans.Chap3 is
when Precision_32 =>
Info.Ortho_Type (Mode_Value) := New_Signed_Type (32);
Info.Type_Mode := Type_Mode_I32;
+ Info.B.Align := Align_32;
when Precision_64 =>
Info.Ortho_Type (Mode_Value) := New_Signed_Type (64);
Info.Type_Mode := Type_Mode_I64;
+ Info.B.Align := Align_64;
end case;
-- Integers are always in their ranges.
Info.S.Nocheck_Low := True;
@@ -336,6 +380,7 @@ package body Trans.Chap3 is
begin
-- FIXME: should check precision
Info.Type_Mode := Type_Mode_F64;
+ Info.B.Align := Align_64;
Info.Ortho_Type (Mode_Value) := New_Float_Type;
-- Reals are always in their ranges.
Info.S.Nocheck_Low := True;
@@ -356,9 +401,11 @@ package body Trans.Chap3 is
when Precision_32 =>
Info.Ortho_Type (Mode_Value) := New_Signed_Type (32);
Info.Type_Mode := Type_Mode_P32;
+ Info.B.Align := Align_32;
when Precision_64 =>
Info.Ortho_Type (Mode_Value) := New_Signed_Type (64);
Info.Type_Mode := Type_Mode_P64;
+ Info.B.Align := Align_64;
end case;
-- Physical types are always in their ranges.
Info.S.Nocheck_Low := True;
@@ -394,6 +441,7 @@ package body Trans.Chap3 is
Info.Ortho_Type (Mode_Value) := Ghdl_File_Index_Type;
Info.Ortho_Ptr_Type (Mode_Value) := Ghdl_File_Index_Ptr_Type;
Info.Type_Mode := Type_Mode_File;
+ Info.B.Align := Align_32;
end Translate_File_Type;
function Get_File_Signature_Length (Def : Iir) return Natural is
@@ -503,6 +551,7 @@ package body Trans.Chap3 is
procedure Create_Unbounded_Type_Fat_Pointer (Info : Type_Info_Acc)
is
Constr : O_Element_List;
+ Bounds_Type : O_Tnode;
begin
for Kind in Object_Kind_Type loop
exit when Info.B.Base_Type (Kind) = O_Tnode_Null;
@@ -511,9 +560,17 @@ package body Trans.Chap3 is
New_Record_Field
(Constr, Info.B.Base_Field (Kind), Wki_Base,
Info.B.Base_Ptr_Type (Kind));
+ case Info.Type_Mode is
+ when Type_Mode_Unbounded_Array =>
+ Bounds_Type := Info.B.Bounds_Ptr_Type;
+ when Type_Mode_Unbounded_Record =>
+ Bounds_Type := Info.B.Layout_Ptr_Type;
+ when others =>
+ raise Internal_Error;
+ end case;
New_Record_Field
(Constr, Info.B.Bounds_Field (Kind), Wki_Bounds,
- Info.B.Bounds_Ptr_Type);
+ Bounds_Type);
Finish_Record_Type (Constr, Info.Ortho_Type (Kind));
end loop;
end Create_Unbounded_Type_Fat_Pointer;
@@ -550,89 +607,129 @@ package body Trans.Chap3 is
New_Type_Decl (Create_Identifier ("BOUNDP"), Info.B.Bounds_Ptr_Type);
end Finish_Unbounded_Type_Bounds;
- function Create_Static_Composite_Subtype_Bounds (Def : Iir) return O_Cnode
+ function Create_Static_Composite_Subtype_Sizes (Def : Iir) return O_Cnode
+ is
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ Sz_List : O_Record_Aggr_List;
+ Sz : O_Cnode;
+ Sz_Res : O_Cnode;
+ begin
+ Start_Record_Aggr (Sz_List, Ghdl_Sizes_Type);
+ New_Record_Aggr_El
+ (Sz_List, New_Sizeof (Info.Ortho_Type (Mode_Value), Ghdl_Index_Type));
+ if Get_Has_Signal_Flag (Def) then
+ Sz := New_Sizeof (Info.Ortho_Type (Mode_Signal), Ghdl_Index_Type);
+ else
+ Sz := Ghdl_Index_0;
+ end if;
+ New_Record_Aggr_El (Sz_List, Sz);
+ Finish_Record_Aggr (Sz_List, Sz_Res);
+ return Sz_Res;
+ end Create_Static_Composite_Subtype_Sizes;
+
+ function Create_Static_Array_Subtype_Bounds (Def : Iir) return O_Cnode
is
- Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Def));
+ Base_Type : constant Iir := Get_Base_Type (Def);
+ Binfo : constant Type_Info_Acc := Get_Info (Base_Type);
+ Indexes_List : constant Iir_Flist := Get_Index_Subtype_List (Def);
+ Index : Iir;
List : O_Record_Aggr_List;
Res : O_Cnode;
begin
Start_Record_Aggr (List, Binfo.B.Bounds_Type);
- case Get_Kind (Def) is
- when Iir_Kind_Array_Subtype_Definition =>
- declare
- Indexes_List : constant Iir_Flist :=
- Get_Index_Subtype_List (Def);
- Index : Iir;
- begin
- for I in Flist_First .. Flist_Last (Indexes_List) loop
- Index := Get_Index_Type (Indexes_List, I);
- New_Record_Aggr_El
- (List, Create_Static_Type_Definition_Type_Range (Index));
- end loop;
- end;
- if Binfo.B.El_Size /= O_Fnode_Null then
- -- For arrays of unbounded type.
- declare
- El_Type : constant Iir := Get_Element_Subtype (Def);
- El_Info : constant Type_Info_Acc := Get_Info (El_Type);
- Sz_List : O_Record_Aggr_List;
- Sz_Res : O_Cnode;
- begin
- New_Record_Aggr_El
- (List, Create_Static_Composite_Subtype_Bounds (El_Type));
-
- Start_Record_Aggr (Sz_List, Ghdl_Sizes_Type);
- New_Record_Aggr_El
- (Sz_List, New_Sizeof (El_Info.Ortho_Type (Mode_Value),
- Ghdl_Index_Type));
- New_Record_Aggr_El
- (Sz_List, New_Sizeof (El_Info.Ortho_Type (Mode_Signal),
- Ghdl_Index_Type));
- Finish_Record_Aggr (Sz_List, Sz_Res);
- New_Record_Aggr_El (List, Sz_Res);
- end;
- end if;
+ for I in Flist_First .. Flist_Last (Indexes_List) loop
+ Index := Get_Index_Type (Indexes_List, I);
+ New_Record_Aggr_El
+ (List, Create_Static_Type_Definition_Type_Range (Index));
+ end loop;
- when Iir_Kind_Record_Subtype_Definition =>
- declare
- El_List : constant Iir_Flist :=
- Get_Elements_Declaration_List (Def);
- El_Blist : constant Iir_Flist :=
- Get_Elements_Declaration_List (Get_Base_Type (Def));
- El : Iir;
- Bel : Iir;
- Bel_Info : Field_Info_Acc;
- begin
- for I in Flist_First .. Flist_Last (El_Blist) loop
- Bel := Get_Nth_Element (El_Blist, I);
- Bel_Info := Get_Info (Bel);
- if Bel_Info.Field_Bound /= O_Fnode_Null then
- El := Get_Nth_Element (El_List, I);
- New_Record_Aggr_El
- (List,
- Create_Static_Composite_Subtype_Bounds
- (Get_Type (El)));
- end if;
- end loop;
- end;
+ if Binfo.B.Bounds_El /= O_Fnode_Null then
+ -- For arrays of unbounded type.
+ New_Record_Aggr_El
+ (List, Create_Static_Composite_Subtype_Layout
+ (Get_Element_Subtype (Def)));
+ end if;
- when others =>
- Error_Kind ("create_static_composite_subtype_bounds", Def);
- end case;
+ Finish_Record_Aggr (List, Res);
+ return Res;
+ end Create_Static_Array_Subtype_Bounds;
+
+ function Create_Static_Record_Subtype_Bounds (Def : Iir) return O_Cnode
+ is
+ Base_Type : constant Iir := Get_Base_Type (Def);
+ Binfo : constant Type_Info_Acc := Get_Info (Base_Type);
+ El_List : constant Iir_Flist := Get_Elements_Declaration_List (Def);
+ El_Blist : constant Iir_Flist :=
+ Get_Elements_Declaration_List (Base_Type);
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ List : O_Record_Aggr_List;
+ Res : O_Cnode;
+ El : Iir;
+ Bel : Iir;
+ Bel_Info : Field_Info_Acc;
+ El_Info : Field_Info_Acc;
+ Off : O_Cnode;
+ begin
+ Start_Record_Aggr (List, Binfo.B.Bounds_Type);
+
+ New_Record_Aggr_El (List, Create_Static_Composite_Subtype_Sizes (Def));
+
+ for I in Flist_First .. Flist_Last (El_Blist) loop
+ Bel := Get_Nth_Element (El_Blist, I);
+ Bel_Info := Get_Info (Bel);
+ if Bel_Info.Field_Bound /= O_Fnode_Null then
+ El := Get_Nth_Element (El_List, I);
+ El_Info := Get_Info (El);
+ for Kind in Mode_Value .. Type_To_Last_Object_Kind (Base_Type)
+ loop
+ if Info.Ortho_Type (Kind) /= O_Tnode_Null then
+ Off := New_Offsetof (Info.Ortho_Type (Kind),
+ El_Info.Field_Node (Kind),
+ Ghdl_Index_Type);
+ else
+ Off := Ghdl_Index_0;
+ end if;
+ New_Record_Aggr_El (List, Off);
+ end loop;
+ New_Record_Aggr_El
+ (List, Create_Static_Composite_Subtype_Layout (Get_Type (El)));
+ end if;
+ end loop;
Finish_Record_Aggr (List, Res);
return Res;
- end Create_Static_Composite_Subtype_Bounds;
+ end Create_Static_Record_Subtype_Bounds;
- procedure Elab_Composite_Subtype_Bounds (Def : Iir; Target : O_Lnode)
+ function Create_Static_Composite_Subtype_Layout (Def : Iir) return O_Cnode
is
- Info : constant Type_Info_Acc := Get_Info (Def);
- Base_Type : constant Iir := Get_Base_Type (Def);
- Targ : Mnode;
+ Info : constant Type_Info_Acc := Get_Info (Def);
+ begin
+ case Info.Type_Mode is
+ when Type_Mode_Static_Record
+ | Type_Mode_Complex_Record =>
+ return Create_Static_Record_Subtype_Bounds (Def);
+ when Type_Mode_Static_Array
+ | Type_Mode_Complex_Array =>
+ declare
+ List : O_Record_Aggr_List;
+ Res : O_Cnode;
+ begin
+ Start_Record_Aggr (List, Info.B.Layout_Type);
+ New_Record_Aggr_El
+ (List, Create_Static_Composite_Subtype_Sizes (Def));
+ New_Record_Aggr_El
+ (List, Create_Static_Array_Subtype_Bounds (Def));
+ Finish_Record_Aggr (List, Res);
+ return Res;
+ end;
+ when others =>
+ raise Internal_Error;
+ end case;
+ end Create_Static_Composite_Subtype_Layout;
+
+ procedure Elab_Composite_Subtype_Layout (Def : Iir; Target : Mnode) is
begin
- Targ := Lv2M (Target, null, Mode_Value,
- Info.B.Bounds_Type, Info.B.Bounds_Ptr_Type);
Open_Temp;
case Get_Kind (Def) is
@@ -640,110 +737,101 @@ package body Trans.Chap3 is
declare
Indexes_List : constant Iir_Flist :=
Get_Index_Subtype_List (Def);
- Indexes_Def_List : constant Iir_Flist :=
- Get_Index_Subtype_Definition_List (Base_Type);
+ Targ : Mnode;
Index : Iir;
begin
+ Targ := Layout_To_Bounds (Target);
if Get_Nbr_Elements (Indexes_List) > 1 then
Targ := Stabilize (Targ);
end if;
for I in Flist_First .. Flist_Last (Indexes_List) loop
Index := Get_Index_Type (Indexes_List, I);
- declare
- Index_Type : constant Iir := Get_Base_Type (Index);
- Index_Info : constant Type_Info_Acc :=
- Get_Info (Index_Type);
- Base_Index_Info : constant Index_Info_Acc :=
- Get_Info (Get_Nth_Element (Indexes_Def_List, I));
- D : O_Dnode;
- begin
- Open_Temp;
- D := Create_Temp_Ptr
- (Index_Info.B.Range_Ptr_Type,
- New_Selected_Element (M2Lv (Targ),
- Base_Index_Info.Index_Field));
- Chap7.Translate_Discrete_Range
- (Dp2M (D, Index_Info, Mode_Value,
- Index_Info.B.Range_Type,
- Index_Info.B.Range_Ptr_Type),
- Index);
- Close_Temp;
- end;
+ Open_Temp;
+ Chap7.Translate_Discrete_Range
+ (Bounds_To_Range (Targ, Def, I + 1), Index);
+ Close_Temp;
end loop;
+ -- FIXME: element ?
end;
+ when Iir_Kind_Record_Type_Definition =>
+ null;
+
when Iir_Kind_Record_Subtype_Definition =>
declare
El_List : constant Iir_Flist :=
Get_Elements_Declaration_List (Def);
+ Targ : Mnode;
El : Iir;
- El_Info : Field_Info_Acc;
+ Base_El : Iir;
begin
- Targ := Stabilize (Targ);
+ Targ := Stabilize (Target);
for I in Flist_First .. Flist_Last (El_List) loop
El := Get_Nth_Element (El_List, I);
- El_Info := Get_Info (Get_Base_Element_Declaration (El));
- if El_Info.Field_Bound /= O_Fnode_Null then
- Elab_Composite_Subtype_Bounds
+ Base_El := Get_Base_Element_Declaration (El);
+ if Is_Unbounded_Type (Get_Info (Get_Type (Base_El))) then
+ Elab_Composite_Subtype_Layout
(Get_Type (El),
- New_Selected_Element (M2Lv (Targ),
- El_Info.Field_Bound));
+ Record_Layout_To_Element_Layout (Targ, El));
end if;
end loop;
end;
when others =>
- Error_Kind ("elab_composite_subtype_bounds", Def);
+ Error_Kind ("elab_composite_subtype_layout", Def);
end case;
Close_Temp;
- end Elab_Composite_Subtype_Bounds;
+ end Elab_Composite_Subtype_Layout;
- procedure Elab_Composite_Subtype_Bounds (Def : Iir)
+ procedure Elab_Composite_Subtype_Layout (Def : Iir)
is
Info : constant Type_Info_Acc := Get_Info (Def);
begin
- if not Info.S.Static_Bounds then
- Elab_Composite_Subtype_Bounds
- (Def, Get_Var (Info.S.Composite_Bounds));
+ if Is_Complex_Type (Info) then
+ Elab_Composite_Subtype_Layout (Def, Get_Composite_Type_Layout (Info));
+
+ Gen_Call_Type_Builder
+ (Get_Composite_Type_Layout (Info), Def, Mode_Value);
+ if Get_Has_Signal_Flag (Def) then
+ Gen_Call_Type_Builder
+ (Get_Composite_Type_Layout (Info), Def, Mode_Signal);
+ end if;
end if;
- end Elab_Composite_Subtype_Bounds;
+ end Elab_Composite_Subtype_Layout;
- -- Create a variable containing the bounds for array subtype DEF.
- procedure Create_Composite_Subtype_Bounds_Var
+ -- Create a variable containing the layout for composite subtype DEF.
+ procedure Create_Composite_Subtype_Layout_Var
(Def : Iir; Elab_Now : Boolean)
is
Info : constant Type_Info_Acc := Get_Info (Def);
- Base_Info : Type_Info_Acc;
Val : O_Cnode;
begin
- if Info.S.Composite_Bounds /= Null_Var then
+ if Info.S.Composite_Layout /= Null_Var then
+ -- Already created.
return;
end if;
- Base_Info := Get_Info (Get_Base_Type (Def));
if Are_Bounds_Locally_Static (Def) then
- Info.S.Static_Bounds := True;
if Global_Storage = O_Storage_External then
-- Do not create the value of the type desc, since it
-- is never dereferenced in a static type desc.
Val := O_Cnode_Null;
else
- Val := Create_Static_Composite_Subtype_Bounds (Def);
+ Val := Create_Static_Composite_Subtype_Layout (Def);
end if;
- Info.S.Composite_Bounds := Create_Global_Const
- (Create_Identifier ("STB"),
- Base_Info.B.Bounds_Type, Global_Storage, Val);
+ Info.S.Composite_Layout := Create_Global_Const
+ (Create_Identifier ("STL"),
+ Info.B.Layout_Type, Global_Storage, Val);
else
pragma Assert (Get_Type_Staticness (Def) /= Locally);
- Info.S.Static_Bounds := False;
- Info.S.Composite_Bounds := Create_Var
- (Create_Var_Identifier ("STB"), Base_Info.B.Bounds_Type);
+ Info.S.Composite_Layout := Create_Var
+ (Create_Var_Identifier ("STL"), Info.B.Layout_Type);
if Elab_Now then
- Elab_Composite_Subtype_Bounds (Def);
+ Elab_Composite_Subtype_Layout (Def);
end if;
end if;
- end Create_Composite_Subtype_Bounds_Var;
+ end Create_Composite_Subtype_Layout_Var;
-------------
-- Array --
@@ -793,25 +881,50 @@ package body Trans.Chap3 is
end loop;
if Is_Unbounded_Type (El_Info) then
- -- Bounds and size for element.
- New_Record_Field (Constr, Info.B.El_Bounds,
- Get_Identifier ("el_bound"), El_Info.B.Bounds_Type);
- New_Record_Field (Constr, Info.B.El_Size, Get_Identifier ("el_size"),
- Ghdl_Sizes_Type);
+ -- Add layout for the element.
+ New_Record_Field
+ (Constr, Info.B.Bounds_El,
+ Get_Identifier ("el_layout"), El_Info.B.Layout_Type);
end if;
Finish_Record_Type (Constr, Info.B.Bounds_Type);
Finish_Unbounded_Type_Bounds (Info);
end Translate_Array_Type_Bounds;
+ -- Create the layout type.
+ procedure Create_Array_Type_Layout_Type (Info : Type_Info_Acc)
+ is
+ Constr : O_Element_List;
+ begin
+ Start_Record_Type (Constr);
+ New_Record_Field (Constr, Info.B.Layout_Size,
+ Get_Identifier ("size"), Ghdl_Sizes_Type);
+ New_Record_Field (Constr, Info.B.Layout_Bounds,
+ Get_Identifier ("bounds"), Info.B.Bounds_Type);
+ Finish_Record_Type (Constr, Info.B.Layout_Type);
+
+ New_Type_Decl (Create_Identifier ("LAYOUT"), Info.B.Layout_Type);
+ Info.B.Layout_Ptr_Type := New_Access_Type (Info.B.Layout_Type);
+ New_Type_Decl (Create_Identifier ("LAYOUTP"), Info.B.Layout_Ptr_Type);
+ end Create_Array_Type_Layout_Type;
+
procedure Translate_Array_Type_Base
- (Def : Iir_Array_Type_Definition;
- Info : Type_Info_Acc)
+ (Def : Iir_Array_Type_Definition; Info : Type_Info_Acc)
is
El_Type : constant Iir := Get_Element_Subtype (Def);
El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
begin
- if Is_Complex_Type (El_Tinfo) or else Is_Unbounded_Type (El_Tinfo) then
+ Info.B.Align := El_Tinfo.B.Align;
+ if Is_Static_Type (El_Tinfo) then
+ -- Simple case: the array is really an array.
+ for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
+ Info.B.Base_Type (Kind) :=
+ New_Array_Type (El_Tinfo.Ortho_Type (Kind), Ghdl_Index_Type);
+ end loop;
+
+ -- Declare the types.
+ Finish_Unbounded_Type_Base (Info);
+ else
if El_Tinfo.Type_Mode in Type_Mode_Arrays then
Info.B.Base_Type := El_Tinfo.B.Base_Ptr_Type;
Info.B.Base_Ptr_Type := El_Tinfo.B.Base_Ptr_Type;
@@ -819,20 +932,13 @@ package body Trans.Chap3 is
Info.B.Base_Type := El_Tinfo.Ortho_Ptr_Type;
Info.B.Base_Ptr_Type := El_Tinfo.Ortho_Ptr_Type;
end if;
- else
- for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
- Info.B.Base_Type (Kind) :=
- New_Array_Type (El_Tinfo.Ortho_Type (Kind), Ghdl_Index_Type);
- end loop;
- Finish_Unbounded_Type_Base (Info);
+ pragma Assert (Info.B.Align /= Align_Undef);
end if;
end Translate_Array_Type_Base;
- procedure Translate_Array_Type_Definition
- (Def : Iir_Array_Type_Definition)
+ procedure Translate_Array_Type (Def : Iir_Array_Type_Definition)
is
Info : constant Type_Info_Acc := Get_Info (Def);
- El_Tinfo : Type_Info_Acc;
begin
Info.Type_Mode := Type_Mode_Fat_Array;
Info.B := Ortho_Info_Basetype_Array_Init;
@@ -843,14 +949,10 @@ package body Trans.Chap3 is
Create_Unbounded_Type_Fat_Pointer (Info);
Finish_Type_Definition (Info, False);
- El_Tinfo := Get_Info (Get_Element_Subtype (Def));
- if Is_Complex_Type (El_Tinfo) then
- -- This is a complex type.
- -- No size variable for unconstrained array type.
- Set_Complex_Type (Info, El_Tinfo.C (Mode_Value).Builder_Need_Func);
- end if;
+ Create_Array_Type_Layout_Type (Info);
+
Info.Type_Incomplete := False;
- end Translate_Array_Type_Definition;
+ end Translate_Array_Type;
-- Get the length of DEF, ie the number of elements.
-- If the length is not statically defined, returns -1.
@@ -942,7 +1044,7 @@ package body Trans.Chap3 is
Info.Type_Locally_Constrained := (Len >= 0);
Info.B := Pinfo.B;
Info.S := Pinfo.S;
- if Is_Complex_Type (Pinfo)
+ if Is_Complex_Type (Get_Info (Get_Element_Subtype (Parent_Type)))
or else not Info.Type_Locally_Constrained
then
-- This is a complex type as the size is not known at compile
@@ -950,18 +1052,6 @@ package body Trans.Chap3 is
Info.Type_Mode := Type_Mode_Complex_Array;
Info.Ortho_Type := Pinfo.B.Base_Ptr_Type;
Info.Ortho_Ptr_Type := Pinfo.B.Base_Ptr_Type;
-
- -- If the base type need a builder, so does the subtype.
- if Is_Complex_Type (Pinfo)
- and then Pinfo.C (Mode_Value).Builder_Need_Func
- then
- Copy_Complex_Type (Info, Pinfo);
- else
- Set_Complex_Type (Info, False);
- end if;
-
- -- Type is bounded, but not statically.
- Create_Size_Var (Def, Info);
else
-- Length is known. Create a constrained array.
El_Constrained := Get_Array_Element_Constraint (Def) /= Null_Iir;
@@ -1007,88 +1097,53 @@ package body Trans.Chap3 is
Info.Type_Mode := Type_Mode_Unbounded_Array;
Create_Array_For_Array_Subtype
(Def, Info.B.Base_Type, Info.B.Base_Ptr_Type);
-
- -- If the base type need a builder, so does the subtype.
- if Is_Complex_Type (Pinfo) then
- if Pinfo.C (Mode_Value).Builder_Need_Func then
- Copy_Complex_Type (Info, Pinfo);
- else
- Set_Complex_Type (Info, False);
- end if;
- end if;
end Translate_Array_Subtype_Definition_Constrained_Element;
procedure Create_Array_Type_Builder
(Def : Iir_Array_Type_Definition; Kind : Object_Kind_Type)
is
+ El_Type : constant Iir := Get_Element_Subtype (Def);
+ El_Info : constant Type_Info_Acc := Get_Info (El_Type);
Info : constant Type_Info_Acc := Get_Info (Def);
- Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param;
- Bound : constant O_Dnode := Info.C (Kind).Builder_Bound_Param;
- Var_Off : O_Dnode;
- Var_Mem : O_Dnode;
- Var_Length : O_Dnode;
- El_Type : Iir;
- El_Info : Type_Info_Acc;
- Label : O_Snode;
- begin
- Start_Subprogram_Body (Info.C (Kind).Builder_Func);
- Subprgs.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance);
-
- -- Compute length of the array.
- New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local,
- Ghdl_Index_Type);
- New_Var_Decl (Var_Mem, Get_Identifier ("mem"), O_Storage_Local,
- Info.B.Base_Ptr_Type (Kind));
- New_Var_Decl (Var_Off, Get_Identifier ("off"), O_Storage_Local,
- Ghdl_Index_Type);
+ Layout_Param : constant O_Dnode :=
+ Info.B.Builder (Kind).Builder_Layout_Param;
+ Layout : Mnode;
+ El_Size : O_Enode;
+ Size : O_Enode;
+ begin
+ Start_Subprogram_Body (Info.B.Builder (Kind).Builder_Proc);
+ Subprgs.Start_Subprg_Instance_Use
+ (Info.B.Builder (Kind).Builder_Instance);
+ Open_Local_Temp;
- El_Type := Get_Element_Subtype (Def);
- El_Info := Get_Info (El_Type);
+ Layout := Dp2M (Layout_Param, Info, Kind,
+ Info.B.Layout_Type, Info.B.Layout_Ptr_Type);
- New_Assign_Stmt
- (New_Obj (Var_Length),
- New_Dyadic_Op (ON_Mul_Ov,
- New_Value (Get_Var (El_Info.C (Kind).Size_Var)),
- Get_Bounds_Length (Dp2M (Bound, Info,
- Mode_Value,
- Info.B.Bounds_Type,
- Info.B.Bounds_Ptr_Type),
- Def)));
-
- -- Find the innermost non-array element.
- while El_Info.Type_Mode = Type_Mode_Complex_Array loop
- El_Type := Get_Element_Subtype (El_Type);
- El_Info := Get_Info (El_Type);
- end loop;
+ -- Call the builder to layout the element (only for unbounded elements)
+ if Is_Unbounded_Type (El_Info) then
+ Gen_Call_Type_Builder
+ (Array_Layout_To_Element_Layout (Layout, Def), El_Type, Kind);
- -- Set each index of the array.
- Init_Var (Var_Off);
- Start_Loop_Stmt (Label);
- Gen_Exit_When (Label, New_Compare_Op (ON_Eq,
- New_Obj_Value (Var_Off),
- New_Obj_Value (Var_Length),
- Ghdl_Bool_Type));
+ El_Size := New_Value
+ (Layout_To_Size (Array_Layout_To_Element_Layout (Layout, Def),
+ Kind));
+ else
+ El_Size := Get_Subtype_Size (El_Type, Mnode_Null, Kind);
+ end if;
- New_Assign_Stmt
- (New_Obj (Var_Mem),
- New_Unchecked_Address
- (New_Slice (New_Access_Element
- (New_Convert_Ov (New_Obj_Value (Base),
- Char_Ptr_Type)),
- Chararray_Type,
- New_Obj_Value (Var_Off)),
- Info.B.Base_Ptr_Type (Kind)));
+ -- Compute size.
+ Size := New_Dyadic_Op
+ (ON_Mul_Ov,
+ El_Size,
+ Get_Bounds_Length (Layout_To_Bounds (Layout), Def));
- New_Assign_Stmt
- (New_Obj (Var_Off),
- New_Dyadic_Op (ON_Add_Ov,
- New_Obj_Value (Var_Off),
- Gen_Call_Type_Builder (Dp2M (Var_Mem, El_Info, Kind), El_Type)));
- Finish_Loop_Stmt (Label);
+ -- Set size.
+ New_Assign_Stmt (Layout_To_Size (Layout, Kind), Size);
- New_Return_Stmt (New_Obj_Value (Var_Off));
+ Close_Local_Temp;
- Subprgs.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance);
+ Subprgs.Finish_Subprg_Instance_Use
+ (Info.B.Builder (Kind).Builder_Instance);
Finish_Subprogram_Body;
end Create_Array_Type_Builder;
@@ -1097,82 +1152,31 @@ package body Trans.Chap3 is
--------------
-- Get the alignment mask for *ortho* type ATYPE.
- function Get_Type_Alignmask (Atype : O_Tnode) return O_Enode is
+ function Get_Alignmask (Align : Alignment_Type) return O_Enode is
begin
- return New_Dyadic_Op
- (ON_Sub_Ov,
- New_Lit (New_Alignof (Atype, Ghdl_Index_Type)),
- New_Lit (Ghdl_Index_1));
- end Get_Type_Alignmask;
+ return New_Dyadic_Op (ON_Sub_Ov,
+ New_Lit (Align_Val (Align)),
+ New_Lit (Ghdl_Index_1));
+ end Get_Alignmask;
-- Align VALUE (of unsigned type) for type ATYPE.
-- The formulae is: (V + (A - 1)) and not (A - 1), where A is the
-- alignment for ATYPE in bytes.
- function Realign (Value : O_Enode; Atype : O_Tnode) return O_Enode is
+ function Realign (Value : O_Enode; Align : Alignment_Type) return O_Enode is
begin
return New_Dyadic_Op
(ON_And,
- New_Dyadic_Op (ON_Add_Ov, Value, Get_Type_Alignmask (Atype)),
- New_Monadic_Op (ON_Not, Get_Type_Alignmask (Atype)));
+ New_Dyadic_Op (ON_Add_Ov, Value, Get_Alignmask (Align)),
+ New_Monadic_Op (ON_Not, Get_Alignmask (Align)));
end Realign;
function Realign (Value : O_Enode; Atype : Iir) return O_Enode
is
Tinfo : constant Type_Info_Acc := Get_Info (Atype);
- Otype : O_Tnode;
- begin
- if Is_Unbounded_Type (Tinfo) then
- Otype := Tinfo.B.Base_Type (Mode_Value);
- else
- Otype := Tinfo.Ortho_Type (Mode_Value);
- end if;
- return Realign (Value, Otype);
- end Realign;
-
- function Realign (Value : O_Enode; Mask : O_Dnode) return O_Enode is
begin
- return New_Dyadic_Op
- (ON_And,
- New_Dyadic_Op (ON_Add_Ov, Value, New_Obj_Value (Mask)),
- New_Monadic_Op (ON_Not, New_Obj_Value (Mask)));
+ return Realign (Value, Tinfo.B.Align);
end Realign;
- -- Find the innermost non-array element.
- function Get_Innermost_Non_Array_Element (Atype : Iir) return Iir
- is
- Res : Iir := Atype;
- begin
- while Get_Kind (Res) in Iir_Kinds_Array_Type_Definition loop
- Res := Get_Element_Subtype (Res);
- end loop;
- return Res;
- end Get_Innermost_Non_Array_Element;
-
- -- Declare the bounds types for DEF.
- procedure Translate_Record_Type_Bounds
- (Def : Iir_Record_Type_Definition; Info : Type_Info_Acc)
- is
- List : constant Iir_Flist := Get_Elements_Declaration_List (Def);
- El : Iir;
- El_Tinfo : Type_Info_Acc;
- El_Info : Field_Info_Acc;
- Constr : O_Element_List;
- begin
- Start_Record_Type (Constr);
- for I in Flist_First .. Flist_Last (List) loop
- El := Get_Nth_Element (List, I);
- El_Tinfo := Get_Info (Get_Type (El));
- if Is_Unbounded_Type (El_Tinfo) then
- El_Info := Get_Info (El);
- New_Record_Field (Constr, El_Info.Field_Bound,
- Create_Identifier_Without_Prefix (El),
- El_Tinfo.B.Bounds_Type);
- end if;
- end loop;
- Finish_Record_Type (Constr, Info.B.Bounds_Type);
- Finish_Unbounded_Type_Bounds (Info);
- end Translate_Record_Type_Bounds;
-
procedure Translate_Record_Type (Def : Iir_Record_Type_Definition)
is
Info : constant Type_Info_Acc := Get_Info (Def);
@@ -1184,32 +1188,37 @@ package body Trans.Chap3 is
Field_Info : Ortho_Info_Acc;
El_Type : Iir;
El_Tinfo : Type_Info_Acc;
- El_Tnode : O_Tnode;
+ Align : Alignment_Type;
-- True if a size variable will be created since the size of
-- the record is not known at compile-time.
- Need_Size : Boolean;
+ Is_Complex : Boolean;
Mark : Id_Mark_Type;
begin
- Need_Size := False;
-
-- First, translate the anonymous type of the elements.
+ Align := Align_8;
for I in Flist_First .. Flist_Last (List) loop
El := Get_Nth_Element (List, I);
El_Type := Get_Type (El);
- if Get_Info (El_Type) = null then
+ El_Tinfo := Get_Info (El_Type);
+ if El_Tinfo = null then
Push_Identifier_Prefix (Mark, Get_Identifier (El));
Translate_Subtype_Indication (El_Type, True);
Pop_Identifier_Prefix (Mark);
+ El_Tinfo := Get_Info (El_Type);
end if;
- Need_Size := Need_Size or else Is_Complex_Type (Get_Info (El_Type));
Field_Info := Add_Info (El, Kind_Field);
+
+ pragma Assert (El_Tinfo.B.Align /= Align_Undef);
+ Align := Alignment_Type'Max (Align, El_Tinfo.B.Align);
end loop;
+ Info.B.Align := Align;
-- Then create the record type.
Info.S := Ortho_Info_Subtype_Record_Init;
Info.Ortho_Type (Mode_Signal) := O_Tnode_Null;
+ Is_Complex := False;
for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
Start_Record_Type (El_List);
for I in Flist_First .. Flist_Last (List) loop
@@ -1219,31 +1228,65 @@ package body Trans.Chap3 is
if Is_Complex_Type (El_Tinfo)
or else Is_Unbounded_Type (El_Tinfo)
then
- -- Always use an offset for a complex type.
- El_Tnode := Ghdl_Index_Type;
+ Is_Complex := True;
else
- El_Tnode := El_Tinfo.Ortho_Type (Kind);
+ New_Record_Field (El_List, Field_Info.Field_Node (Kind),
+ Create_Identifier_Without_Prefix (El),
+ El_Tinfo.Ortho_Type (Kind));
end if;
- New_Record_Field (El_List, Field_Info.Field_Node (Kind),
- Create_Identifier_Without_Prefix (El),
- El_Tnode);
end loop;
Finish_Record_Type (El_List, Info.B.Base_Type (Kind));
end loop;
+ -- Create the bounds type
+ Info.B.Bounds_Type := O_Tnode_Null;
+ Start_Record_Type (El_List);
+ New_Record_Field (El_List, Info.B.Layout_Size,
+ Get_Identifier ("size"), Ghdl_Sizes_Type);
+ for I in Flist_First .. Flist_Last (List) loop
+ declare
+ El : constant Iir := Get_Nth_Element (List, I);
+ Field_Info : constant Field_Info_Acc := Get_Info (El);
+ El_Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (El));
+ Unbounded_El : constant Boolean := Is_Unbounded_Type (El_Tinfo);
+ Complex_El : constant Boolean := Is_Complex_Type (El_Tinfo);
+ begin
+ if Unbounded_El or Complex_El then
+ -- Offset
+ New_Record_Field
+ (El_List, Field_Info.Field_Node (Mode_Value),
+ Create_Identifier_Without_Prefix (El, "_OFF"),
+ Ghdl_Index_Type);
+ if Get_Has_Signal_Flag (Def) then
+ New_Record_Field
+ (El_List, Field_Info.Field_Node (Mode_Signal),
+ Create_Identifier_Without_Prefix (El, "_SIGOFF"),
+ Ghdl_Index_Type);
+ end if;
+ end if;
+ if Unbounded_El then
+ New_Record_Field
+ (El_List, Field_Info.Field_Bound,
+ Create_Identifier_Without_Prefix (El, "_BND"),
+ El_Tinfo.B.Layout_Type);
+ end if;
+ end;
+ end loop;
+ Finish_Record_Type (El_List, Info.B.Bounds_Type);
+ Finish_Unbounded_Type_Bounds (Info);
+
+ -- For records: layout == bounds.
+ Info.B.Layout_Type := Info.B.Bounds_Type;
+ Info.B.Layout_Ptr_Type := Info.B.Bounds_Ptr_Type;
+
if Is_Unbounded then
Info.Type_Mode := Type_Mode_Unbounded_Record;
Finish_Unbounded_Type_Base (Info);
- Translate_Record_Type_Bounds (Def, Info);
Create_Unbounded_Type_Fat_Pointer (Info);
Finish_Type_Definition (Info);
-
- -- There are internal fields for unbounded records, so the objects
- -- must be built.
- Set_Complex_Type (Info, True);
else
- if Need_Size then
+ if Is_Complex then
Info.Type_Mode := Type_Mode_Complex_Record;
else
Info.Type_Mode := Type_Mode_Static_Record;
@@ -1252,10 +1295,7 @@ package body Trans.Chap3 is
Finish_Type_Definition (Info);
Info.B.Base_Ptr_Type := Info.Ortho_Ptr_Type;
- if Need_Size then
- Set_Complex_Type (Info, True);
- Create_Size_Var (Def, Info);
- end if;
+ Create_Composite_Subtype_Layout_Var (Def, False);
end if;
end Translate_Record_Type;
@@ -1296,23 +1336,23 @@ package body Trans.Chap3 is
for I in Flist_First .. Flist_Last (El_List) loop
El := Get_Nth_Element (El_List, I);
El_Type := Get_Type (El);
- if Is_Fully_Constrained_Type (El) then
- El_Btype := Get_Type (Get_Nth_Element (El_Tm_List, I));
- if not Is_Fully_Constrained_Type (El_Btype) then
- Has_New_Constraints := True;
- if Get_Type_Staticness (El_Type) = Locally then
- Has_Boxed_Elements := True;
- end if;
- Push_Identifier_Prefix (Mark, Get_Identifier (El));
- Translate_Subtype_Definition (El_Type, El_Btype, With_Vars);
- Pop_Identifier_Prefix (Mark);
+ El_Btype := Get_Type (Get_Nth_Element (El_Tm_List, I));
+ if Is_Fully_Constrained_Type (El_Type)
+ and then not Is_Fully_Constrained_Type (El_Btype)
+ then
+ Has_New_Constraints := True;
+ if Get_Type_Staticness (El_Type) = Locally then
+ Has_Boxed_Elements := True;
end if;
+ Push_Identifier_Prefix (Mark, Get_Identifier (El));
+ Translate_Subtype_Definition (El_Type, El_Btype, With_Vars);
+ Pop_Identifier_Prefix (Mark);
end if;
end loop;
-- By default, use the same representation as the base type.
Info.all := Base_Info.all;
- Info.S := Ortho_Info_Subtype_Record_Init;
+ -- Info.S := Ortho_Info_Subtype_Record_Init;
-- However, it is a different subtype which has its own rti.
Info.Type_Rti := O_Dnode_Null;
@@ -1323,6 +1363,15 @@ package body Trans.Chap3 is
-- create objects, so wait until it is completly constrained.
-- The subtype is simply an alias.
-- In both cases, use the same representation as its type mark.
+
+ for I in Flist_First .. Flist_Last (El_Blist) loop
+ B_El := Get_Nth_Element (El_Blist, I);
+ El := Get_Nth_Element (El_List, I);
+ if El /= B_El then
+ Set_Info (El, Get_Info (B_El));
+ end if;
+ end loop;
+
return;
end if;
@@ -1333,9 +1382,6 @@ package body Trans.Chap3 is
Info.Type_Mode := Type_Mode_Complex_Record;
end if;
- -- Base type is complex (unbounded record)
- Copy_Complex_Type (Info, Base_Info);
-
-- Then create the record type, containing the base record and the
-- fields.
if Has_Boxed_Elements then
@@ -1350,7 +1396,7 @@ package body Trans.Chap3 is
-- This element has been locally constrained.
if Is_Unbounded_Type (Get_Info (Get_Type (B_El)))
- and then Get_Type_Staticness (Get_Type(El)) = Locally
+ and then Get_Type_Staticness (Get_Type (El)) = Locally
then
if Kind = Mode_Value then
Field_Info := Add_Info (El, Kind_Field);
@@ -1363,6 +1409,11 @@ package body Trans.Chap3 is
New_Record_Field (Rec, Field_Info.Field_Node (Kind),
Create_Identifier_Without_Prefix (El),
El_Tnode);
+ Field_Info.Field_Bound := Get_Info (B_El).Field_Bound;
+ else
+ if Kind = Mode_Value and then El /= B_El then
+ Set_Info (El, Get_Info (B_El));
+ end if;
end if;
end loop;
Finish_Record_Type (Rec, Info.Ortho_Type (Kind));
@@ -1374,14 +1425,18 @@ package body Trans.Chap3 is
-- time.
Info.Ortho_Type := Base_Info.B.Base_Type;
Info.Ortho_Ptr_Type := Base_Info.B.Base_Ptr_Type;
- end if;
- if Get_Type_Staticness (Def) /= Locally then
- Create_Size_Var (Def, Info);
+ for I in Flist_First .. Flist_Last (El_Blist) loop
+ B_El := Get_Nth_Element (El_Blist, I);
+ El := Get_Nth_Element (El_List, I);
+ if El /= B_El then
+ Set_Info (El, Get_Info (B_El));
+ end if;
+ end loop;
end if;
if With_Vars then
- Create_Composite_Subtype_Bounds_Var (Def, False);
+ Create_Composite_Subtype_Layout_Var (Def, False);
end if;
end Translate_Record_Subtype;
@@ -1389,20 +1444,20 @@ package body Trans.Chap3 is
(Def : Iir_Record_Type_Definition; Kind : Object_Kind_Type)
is
Info : constant Type_Info_Acc := Get_Info (Def);
- Base : constant O_Dnode := Info.C (Kind).Builder_Base_Param;
+ Layout_Param : constant O_Dnode :=
+ Info.B.Builder (Kind).Builder_Layout_Param;
List : constant Iir_Flist := Get_Elements_Declaration_List (Def);
- El : Iir_Element_Declaration;
+ Layout : Mnode;
Off_Var : O_Dnode;
Off_Val : O_Enode;
- El_Off : O_Enode;
- Sub_Bound : Mnode;
- El_Type : Iir;
- Inner_Type : Iir;
- El_Tinfo : Type_Info_Acc;
begin
- Start_Subprogram_Body (Info.C (Kind).Builder_Func);
- Subprgs.Start_Subprg_Instance_Use (Info.C (Kind).Builder_Instance);
+ Start_Subprogram_Body (Info.B.Builder (Kind).Builder_Proc);
+ Subprgs.Start_Subprg_Instance_Use
+ (Info.B.Builder (Kind).Builder_Instance);
+
+ Layout := Dp2M (Layout_Param, Info, Kind,
+ Info.B.Layout_Type, Info.B.Layout_Ptr_Type);
-- Declare OFF, the offset variable
New_Var_Decl (Off_Var, Get_Identifier ("off"), O_Storage_Local,
@@ -1410,93 +1465,58 @@ package body Trans.Chap3 is
-- Reserve memory for the record, ie:
-- OFF = SIZEOF (record).
- -- Align for signals, as the base type may contain a single index.
Off_Val := New_Lit
(New_Sizeof (Info.B.Base_Type (Kind), Ghdl_Index_Type));
- if Kind = Mode_Signal then
- Off_Val := Realign (Off_Val, Ghdl_Signal_Ptr);
- end if;
New_Assign_Stmt (New_Obj (Off_Var), Off_Val);
-- Set memory for each complex element.
for I in Flist_First .. Flist_Last (List) loop
- El := Get_Nth_Element (List, I);
- El_Type := Get_Type (El);
- El_Tinfo := Get_Info (El_Type);
- if Is_Complex_Type (El_Tinfo)
- or else Is_Unbounded_Type (El_Tinfo)
- then
- -- Complex or unbounded type. Field is an offset.
-
- -- Align on the innermost array element (which should be
- -- a record) for Mode_Value. No need to align for signals,
- -- as all non-composite elements are accesses.
- Inner_Type := Get_Innermost_Non_Array_Element (El_Type);
- Off_Val := New_Obj_Value (Off_Var);
- if Kind = Mode_Value then
- Off_Val := Realign (Off_Val, Inner_Type);
+ declare
+ El : constant Iir := Get_Nth_Element (List, I);
+ El_Type : constant Iir := Get_Type (El);
+ El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
+ El_Complex : constant Boolean := Is_Complex_Type (El_Tinfo);
+ El_Unbounded : constant Boolean := Is_Unbounded_Type (El_Tinfo);
+ El_Layout : Mnode;
+ El_Size : O_Enode;
+ begin
+ if El_Unbounded then
+ -- Set layout
+ El_Layout := Record_Layout_To_Element_Layout (Layout, El);
+ Gen_Call_Type_Builder (El_Layout, El_Type, Kind);
end if;
- New_Assign_Stmt (New_Obj (Off_Var), Off_Val);
- -- Set the offset.
- New_Assign_Stmt
- (New_Selected_Element (New_Acc_Value (New_Obj (Base)),
- Get_Info (El).Field_Node (Kind)),
- New_Obj_Value (Off_Var));
+ if El_Unbounded or El_Complex then
+ -- Complex or unbounded type. Field is an offset.
- Open_Temp;
-
- if Is_Complex_Type (El_Tinfo)
- and then El_Tinfo.C (Kind).Builder_Need_Func
- then
- -- This type needs a builder, call it.
- declare
- Base2 : Mnode;
- Ptr_Var : O_Dnode;
- begin
- if Is_Unbounded_Type (Info) then
- Base2 := Create_Temp (Info, Kind);
- New_Assign_Stmt
- (M2Lp (Get_Composite_Bounds (Base2)),
- New_Obj_Value (Info.C (Kind).Builder_Bound_Param));
- New_Assign_Stmt
- (M2Lp (Get_Composite_Base (Base2)),
- New_Obj_Value (Info.C (Kind).Builder_Base_Param));
- else
- Base2 := Dp2M (Base, Info, Kind);
- end if;
-
- Ptr_Var := Create_Temp (El_Tinfo.Ortho_Ptr_Type (Kind));
+ -- Align on the innermost array element (which should be
+ -- a record) for Mode_Value. No need to align for signals,
+ -- as all non-composite elements are accesses.
+ Off_Val := New_Obj_Value (Off_Var);
+ if Kind = Mode_Value then
+ Off_Val := Realign (Off_Val, El_Type);
+ end if;
+ New_Assign_Stmt (New_Obj (Off_Var), Off_Val);
- New_Assign_Stmt
- (New_Obj (Ptr_Var),
- M2E (Chap6.Translate_Selected_Element (Base2, El)));
+ -- Set the offset.
+ New_Assign_Stmt
+ (Record_Layout_To_Element_Offset (Layout, El, Kind),
+ New_Obj_Value (Off_Var));
- El_Off := Gen_Call_Type_Builder
- (Dp2M (Ptr_Var, El_Tinfo, Kind), El_Type);
- end;
- else
- if Is_Unbounded_Type (El_Tinfo) then
- Sub_Bound := Bounds_To_Element_Bounds
- (Dp2M (Info.C (Kind).Builder_Bound_Param,
- Info, Mode_Value,
- Info.B.Bounds_Type, Info.B.Bounds_Ptr_Type),
- El);
+ if El_Unbounded then
+ El_Layout := Record_Layout_To_Element_Layout (Layout, El);
+ El_Size := New_Value
+ (Sizes_To_Size (Layout_To_Sizes (El_Layout), Kind));
else
- Sub_Bound := Mnode_Null;
+ El_Size := Get_Subtype_Size (El_Type, El_Layout, Kind);
end if;
- -- Allocate memory.
- El_Off := Get_Subtype_Size (El_Type, Sub_Bound, Kind);
+ New_Assign_Stmt (New_Obj (Off_Var),
+ New_Dyadic_Op (ON_Add_Ov,
+ New_Obj_Value (Off_Var),
+ El_Size));
end if;
-
- New_Assign_Stmt
- (New_Obj (Off_Var),
- New_Dyadic_Op (ON_Add_Ov,
- New_Obj_Value (Off_Var), El_Off));
-
- Close_Temp;
- end if;
+ end;
end loop;
-- Align the size to the object alignment.
@@ -1505,9 +1525,11 @@ package body Trans.Chap3 is
Off_Val := Realign (Off_Val, Def);
end if;
- New_Return_Stmt (Off_Val);
+ -- Set size.
+ New_Assign_Stmt (Layout_To_Size (Layout, Kind), Off_Val);
- Subprgs.Finish_Subprg_Instance_Use (Info.C (Kind).Builder_Instance);
+ Subprgs.Finish_Subprg_Instance_Use
+ (Info.B.Builder (Kind).Builder_Instance);
Finish_Subprogram_Body;
end Create_Record_Type_Builder;
@@ -1555,6 +1577,7 @@ package body Trans.Chap3 is
-- Otherwise, it is a thin pointer.
Def_Info.Type_Mode := Type_Mode_Acc;
end if;
+ Def_Info.B.Align := Align_Ptr;
if D_Info.Kind = Kind_Incomplete_Type then
-- Incomplete access.
@@ -1634,11 +1657,6 @@ package body Trans.Chap3 is
Info.Type_Mode := Type_Mode_Protected;
- -- A protected type is a complex type, as its size is not known
- -- at definition point (will be known at body declaration).
- Info.C := new Complex_Type_Arr_Info;
- Info.C (Mode_Value).Builder_Need_Func := False;
-
-- This is just use to set overload number on subprograms, and to
-- translate interfaces.
Push_Identifier_Prefix
@@ -1904,7 +1922,7 @@ package body Trans.Chap3 is
return Create_Static_Scalar_Type_Range (Def);
when Iir_Kind_Array_Subtype_Definition =>
- return Create_Static_Composite_Subtype_Bounds (Def);
+ return Create_Static_Array_Subtype_Bounds (Def);
when Iir_Kind_Array_Type_Definition =>
return O_Cnode_Null;
@@ -1930,7 +1948,7 @@ package body Trans.Chap3 is
when Iir_Kind_Array_Subtype_Definition =>
if Get_Constraint_State (Def) = Fully_Constrained then
- Elab_Composite_Subtype_Bounds (Def);
+ Elab_Composite_Subtype_Layout (Def);
end if;
when Iir_Kind_Array_Type_Definition =>
@@ -1948,16 +1966,16 @@ package body Trans.Chap3 is
end;
return;
- when Iir_Kind_Record_Subtype_Definition =>
+ when Iir_Kind_Record_Subtype_Definition
+ | Iir_Kind_Record_Type_Definition =>
Info := Get_Info (Def);
- if Info.S.Composite_Bounds /= Null_Var then
- Elab_Composite_Subtype_Bounds (Def);
+ if Info.S.Composite_Layout /= Null_Var then
+ Elab_Composite_Subtype_Layout (Def);
end if;
when Iir_Kind_Access_Type_Definition
| Iir_Kind_Access_Subtype_Definition
| Iir_Kind_File_Type_Definition
- | Iir_Kind_Record_Type_Definition
| Iir_Kind_Protected_Type_Declaration =>
return;
@@ -2111,118 +2129,6 @@ package body Trans.Chap3 is
end if;
end Create_Subtype_Info_From_Type;
- procedure Elab_Type_Definition_Size_Var (Def : Iir);
-
- procedure Elab_Record_Size_Var (Def : Iir; Kind : Object_Kind_Type)
- is
- Info : constant Type_Info_Acc := Get_Info (Def);
- List : constant Iir_Flist := Get_Elements_Declaration_List (Def);
- El : Iir_Element_Declaration;
- El_Type : Iir;
- El_Tinfo : Type_Info_Acc;
- Inner_Type : Iir;
- Res : O_Enode;
- Align_Var : O_Dnode;
- begin
- Open_Temp;
-
- -- Start with the size of the 'base' record, that
- -- contains all non-complex types and an offset for
- -- each complex types.
- Res := New_Lit (New_Sizeof (Info.Ortho_Type (Kind), Ghdl_Index_Type));
-
- -- Start with alignment of the record.
- -- ALIGN = ALIGNOF (record)
- case Kind is
- when Mode_Value =>
- Align_Var := Create_Temp (Ghdl_Index_Type);
- New_Assign_Stmt
- (New_Obj (Align_Var),
- Get_Type_Alignmask (Info.Ortho_Type (Kind)));
- when Mode_Signal =>
- Res := Realign (Res, Ghdl_Signal_Ptr);
- end case;
-
- for I in Flist_First .. Flist_Last (List) loop
- El := Get_Nth_Element (List, I);
- El_Type := Get_Type (El);
- El_Tinfo := Get_Info (El_Type);
- if Get_Type_Staticness (El_Type) /= Locally
- and then
- (Is_Complex_Type (El_Tinfo)
- or else Get_Kind (El) = Iir_Kind_Record_Element_Constraint)
- then
- Inner_Type := Get_Innermost_Non_Array_Element (El_Type);
-
- -- Align (only for Mode_Value) the size,
- -- and add the size of the element.
- if Kind = Mode_Value then
- -- Largest alignment.
- New_Assign_Stmt
- (New_Obj (Align_Var),
- New_Dyadic_Op
- (ON_Or,
- New_Obj_Value (Align_Var),
- Get_Type_Alignmask
- (Get_Ortho_Type (Inner_Type, Mode_Value))));
- Res := Realign (Res, Inner_Type);
- end if;
-
- Res := New_Dyadic_Op
- (ON_Add_Ov,
- Res, New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)));
- end if;
- end loop;
- if Kind = Mode_Value then
- Res := Realign (Res, Align_Var);
- end if;
- New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res);
- Close_Temp;
- end Elab_Record_Size_Var;
-
- procedure Elab_Array_Size_Var (Def : Iir; Kind : Object_Kind_Type)
- is
- Info : constant Type_Info_Acc := Get_Info (Def);
- El_Type : constant Iir := Get_Element_Subtype (Def);
- Res : O_Enode;
- begin
- Res := New_Dyadic_Op
- (ON_Mul_Ov,
- Get_Array_Type_Length (Def),
- Chap3.Get_Object_Size (T2M (El_Type, Kind), El_Type));
- New_Assign_Stmt (Get_Var (Info.C (Kind).Size_Var), Res);
- end Elab_Array_Size_Var;
-
- procedure Elab_Type_Definition_Size_Var (Def : Iir)
- is
- Info : constant Type_Info_Acc := Get_Info (Def);
- begin
- if not Is_Complex_Type (Info) then
- return;
- end if;
-
- for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
- if Info.C (Kind).Size_Var /= Null_Var then
- case Info.Type_Mode is
- when Type_Mode_Non_Composite
- | Type_Mode_Unbounded_Array
- | Type_Mode_Unbounded_Record
- | Type_Mode_Unknown
- | Type_Mode_Protected =>
- raise Internal_Error;
- when Type_Mode_Static_Record
- | Type_Mode_Static_Array =>
- -- No need to create a size var, the size is known.
- raise Internal_Error;
- when Type_Mode_Complex_Record =>
- Elab_Record_Size_Var (Def, Kind);
- when Type_Mode_Complex_Array =>
- Elab_Array_Size_Var (Def, Kind);
- end case;
- end if;
- end loop;
- end Elab_Type_Definition_Size_Var;
-
procedure Create_Type_Range_Var (Def : Iir)
is
Info : constant Type_Info_Acc := Get_Info (Def);
@@ -2388,7 +2294,7 @@ package body Trans.Chap3 is
when Iir_Kind_Array_Type_Definition =>
Translate_Array_Element_Definition (Def);
- Translate_Array_Type_Definition (Def);
+ Translate_Array_Type (Def);
when Iir_Kind_Record_Type_Definition =>
Info.B := Ortho_Info_Basetype_Record_Init;
@@ -2480,13 +2386,13 @@ package body Trans.Chap3 is
end if;
when Iir_Kind_Array_Subtype_Definition =>
- -- Handle element subtype.
declare
El_Type : constant Iir := Get_Element_Subtype (Def);
Parent_El_Type : constant Iir :=
Get_Element_Subtype (Parent_Type);
Mark : Id_Mark_Type;
begin
+ -- Handle element subtype.
if El_Type /= Parent_El_Type then
Push_Identifier_Prefix (Mark, "ET");
Translate_Subtype_Definition
@@ -2497,7 +2403,7 @@ package body Trans.Chap3 is
if Get_Constraint_State (Def) = Fully_Constrained then
Translate_Array_Subtype_Definition (Def, Parent_Type);
if With_Vars then
- Create_Composite_Subtype_Bounds_Var (Def, False);
+ Create_Composite_Subtype_Layout_Var (Def, False);
end if;
elsif Is_Fully_Constrained_Type (El_Type)
and then not Is_Fully_Constrained_Type (Parent_El_Type)
@@ -2563,20 +2469,26 @@ package body Trans.Chap3 is
raise Internal_Error;
end case;
+ -- Create builder for arrays and non-static records
Tinfo := Get_Info (Def);
- if not Is_Complex_Type (Tinfo)
- or else Tinfo.C (Mode_Value).Builder_Need_Func = False
- then
- return;
- end if;
+ case Tinfo.Type_Mode is
+ when Type_Mode_Fat_Array
+ | Type_Mode_Unbounded_Record
+ | Type_Mode_Complex_Record =>
+ null;
+ when Type_Mode_Static_Record =>
+ return;
+ when others =>
+ -- Must have been filtered out above.
+ raise Internal_Error;
+ end case;
if Kind in Subprg_Translate_Spec then
-- Declare subprograms.
Id := Get_Identifier (Decl);
- Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Value);
- if Get_Has_Signal_Flag (Def) then
- Create_Builder_Subprogram_Decl (Tinfo, Id, Mode_Signal);
- end if;
+ for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
+ Create_Builder_Subprogram_Decl (Tinfo, Id, Kind);
+ end loop;
end if;
if Kind in Subprg_Translate_Body then
@@ -2587,15 +2499,13 @@ package body Trans.Chap3 is
-- Define subprograms.
case Get_Kind (Def) is
when Iir_Kind_Array_Type_Definition =>
- Create_Array_Type_Builder (Def, Mode_Value);
- if Get_Has_Signal_Flag (Def) then
- Create_Array_Type_Builder (Def, Mode_Signal);
- end if;
+ for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
+ Create_Array_Type_Builder (Def, Kind);
+ end loop;
when Iir_Kind_Record_Type_Definition =>
- Create_Record_Type_Builder (Def, Mode_Value);
- if Get_Has_Signal_Flag (Def) then
- Create_Record_Type_Builder (Def, Mode_Signal);
- end if;
+ for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop
+ Create_Record_Type_Builder (Def, Kind);
+ end loop;
when others =>
Error_Kind ("translate_type_subprograms", Def);
end case;
@@ -2636,7 +2546,6 @@ package body Trans.Chap3 is
Elab_Type_Definition_Depend (Def);
Elab_Type_Definition_Type_Range (Def);
- Elab_Type_Definition_Size_Var (Def);
end Elab_Type_Definition;
procedure Translate_Subtype_Indication (Def : Iir; With_Vars : Boolean)
@@ -2753,48 +2662,23 @@ package body Trans.Chap3 is
Iinfo.B.Range_Type, Iinfo.B.Range_Ptr_Type);
end Bounds_To_Range;
- function Bounds_To_Element_Bounds (B : Mnode; El : Iir) return Mnode
- is
- El_Type : constant Iir := Get_Type (El);
- El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
- Base_El : constant Iir := Get_Base_Element_Declaration (El);
+ function Record_Bounds_To_Element_Bounds (B : Mnode; El : Iir)
+ return Mnode is
begin
- return Lv2M
- (New_Selected_Element (M2Lv (B),
- Get_Info (Base_El).Field_Bound),
- El_Tinfo, Mode_Value,
- El_Tinfo.B.Bounds_Type, El_Tinfo.B.Bounds_Ptr_Type);
- end Bounds_To_Element_Bounds;
+ return Layout_To_Bounds (Record_Layout_To_Element_Layout (B, El));
+ end Record_Bounds_To_Element_Bounds;
function Array_Bounds_To_Element_Bounds (B : Mnode; Atype : Iir)
- return Mnode
- is
- Arr_Tinfo : constant Type_Info_Acc := Get_Info (Atype);
- El_Type : constant Iir := Get_Element_Subtype (Atype);
- El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
+ return Mnode is
begin
- return Lv2M
- (New_Selected_Element (M2Lv (B), Arr_Tinfo.B.El_Bounds),
- El_Tinfo, Mode_Value,
- El_Tinfo.B.Bounds_Type, El_Tinfo.B.Bounds_Ptr_Type);
+ return Layout_To_Bounds (Array_Bounds_To_Element_Layout (B, Atype));
end Array_Bounds_To_Element_Bounds;
function Array_Bounds_To_Element_Size (B : Mnode; Atype : Iir)
- return O_Lnode
- is
- Arr_Tinfo : constant Type_Info_Acc := Get_Info (Atype);
- Sizes : O_Lnode;
- Field : O_Fnode;
+ return O_Lnode is
begin
- Sizes := New_Selected_Element (M2Lv (B), Arr_Tinfo.B.El_Size);
- case Get_Object_Kind (B) is
- when Mode_Value =>
- Field := Ghdl_Sizes_Val;
- when Mode_Signal =>
- Field := Ghdl_Sizes_Sig;
- end case;
- Sizes := New_Selected_Element (Sizes, Field);
- return Sizes;
+ return Layout_To_Size
+ (Array_Bounds_To_Element_Layout (B, Atype), Get_Object_Kind (B));
end Array_Bounds_To_Element_Size;
function Type_To_Range (Atype : Iir) return Mnode
@@ -2847,51 +2731,35 @@ package body Trans.Chap3 is
Mode_Value);
end Range_To_Right;
- function Get_Array_Type_Bounds (Info : Type_Info_Acc) return Mnode
- is
+ function Get_Composite_Type_Bounds (Atype : Iir) return Mnode is
begin
- case Info.Type_Mode is
- when Type_Mode_Unbounded =>
- raise Internal_Error;
- when Type_Mode_Bounded_Arrays
- | Type_Mode_Bounded_Records =>
- return Varv2M (Info.S.Composite_Bounds,
- Info, Mode_Value,
- Info.B.Bounds_Type,
- Info.B.Bounds_Ptr_Type);
- when others =>
- raise Internal_Error;
- end case;
- end Get_Array_Type_Bounds;
+ return Layout_To_Bounds (Get_Composite_Type_Layout (Get_Info (Atype)));
+ end Get_Composite_Type_Bounds;
- function Get_Array_Type_Bounds (Atype : Iir) return Mnode is
- begin
- return Get_Array_Type_Bounds (Get_Info (Atype));
- end Get_Array_Type_Bounds;
-
- function Get_Composite_Bounds (Arr : Mnode) return Mnode
+ function Get_Composite_Bounds (Obj : Mnode) return Mnode
is
- Info : constant Type_Info_Acc := Get_Type_Info (Arr);
+ Info : constant Type_Info_Acc := Get_Type_Info (Obj);
begin
case Info.Type_Mode is
when Type_Mode_Unbounded_Array
| Type_Mode_Unbounded_Record =>
declare
- Kind : constant Object_Kind_Type := Get_Object_Kind (Arr);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Obj);
begin
return Lp2M
- (New_Selected_Element (M2Lv (Arr),
+ (New_Selected_Element (M2Lv (Obj),
Info.B.Bounds_Field (Kind)),
Info,
Mode_Value,
Info.B.Bounds_Type,
Info.B.Bounds_Ptr_Type);
end;
- when Type_Mode_Bounded_Arrays
- | Type_Mode_Bounded_Records =>
- return Get_Array_Type_Bounds (Info);
+ when Type_Mode_Bounded_Arrays =>
+ return Layout_To_Bounds (Get_Composite_Type_Layout (Info));
+ when Type_Mode_Bounded_Records =>
+ return Get_Composite_Type_Layout (Info);
when Type_Mode_Bounds_Acc =>
- return Lp2M (M2Lv (Arr), Info, Mode_Value);
+ return Lp2M (M2Lv (Obj), Info, Mode_Value);
when others =>
raise Internal_Error;
end case;
@@ -2942,7 +2810,7 @@ package body Trans.Chap3 is
if Type_Info.Type_Locally_Constrained then
return New_Lit (Get_Thin_Array_Length (Atype));
else
- return Get_Bounds_Length (Get_Array_Type_Bounds (Atype), Atype);
+ return Get_Bounds_Length (Get_Composite_Type_Bounds (Atype), Atype);
end if;
end Get_Array_Type_Length;
@@ -2957,59 +2825,71 @@ package body Trans.Chap3 is
end if;
end Get_Array_Length;
- function Get_Composite_Base (Arr : Mnode) return Mnode
+ -- Get the base part of a dope vector.
+ function Get_Unbounded_Base (Arr : Mnode) return Mnode
is
Info : constant Type_Info_Acc := Get_Type_Info (Arr);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Arr);
+ begin
+ pragma Assert (Info.Type_Mode in Type_Mode_Unbounded);
+ return Lp2M
+ (New_Selected_Element (M2Lv (Arr), Info.B.Base_Field (Kind)),
+ Info, Kind,
+ Info.B.Base_Type (Kind), Info.B.Base_Ptr_Type (Kind));
+ end Get_Unbounded_Base;
+
+ function Get_Composite_Base (Obj : Mnode) return Mnode
+ is
+ Info : constant Type_Info_Acc := Get_Type_Info (Obj);
begin
case Info.Type_Mode is
when Type_Mode_Unbounded_Array
| Type_Mode_Unbounded_Record =>
- declare
- Kind : constant Object_Kind_Type := Get_Object_Kind (Arr);
- begin
- return Lp2M
- (New_Selected_Element (M2Lv (Arr),
- Info.B.Base_Field (Kind)),
- Info, Kind,
- Info.B.Base_Type (Kind), Info.B.Base_Ptr_Type (Kind));
- end;
- when Type_Mode_Bounded_Arrays =>
- return Arr;
- when Type_Mode_Bounded_Records =>
- return Unbox_Record (Arr);
+ return Get_Unbounded_Base (Obj);
+ when Type_Mode_Bounded_Arrays
+ | Type_Mode_Bounded_Records =>
+ return Obj;
when others =>
raise Internal_Error;
end case;
end Get_Composite_Base;
- function Unbox_Record (Arr : Mnode) return Mnode
+ function Unbox_Record (Obj : Mnode) return Mnode
is
- Info : constant Type_Info_Acc := Get_Type_Info (Arr);
+ Info : constant Type_Info_Acc := Get_Type_Info (Obj);
+ pragma Assert (Info.Type_Mode in Type_Mode_Bounded_Records);
+ Kind : constant Object_Kind_Type := Get_Object_Kind (Obj);
+ Box_Field : constant O_Fnode := Info.S.Box_Field (Kind);
+ begin
+ if Box_Field /= O_Fnode_Null then
+ -- Unbox the record.
+ return Lv2M (New_Selected_Element (M2Lv (Obj), Box_Field),
+ Info, Kind,
+ Info.B.Base_Type (Kind),
+ Info.B.Base_Ptr_Type (Kind));
+ else
+ return Obj;
+ end if;
+ end Unbox_Record;
+
+ function Get_Composite_Unbounded_Base (Obj : Mnode) return Mnode
+ is
+ Info : constant Type_Info_Acc := Get_Type_Info (Obj);
begin
case Info.Type_Mode is
- when Type_Mode_Arrays =>
- return Arr;
- when Type_Mode_Unbounded_Record =>
- return Arr;
+ when Type_Mode_Unbounded_Array
+ | Type_Mode_Unbounded_Record =>
+ return Get_Unbounded_Base (Obj);
+ when Type_Mode_Bounded_Arrays =>
+ -- This works in ortho as an access to unconstrained array is
+ -- also an access to a constrained array.
+ return Obj;
when Type_Mode_Bounded_Records =>
- declare
- Kind : constant Object_Kind_Type := Get_Object_Kind (Arr);
- Box_Field : constant O_Fnode := Info.S.Box_Field (Kind);
- begin
- if Box_Field /= O_Fnode_Null then
- -- Unbox the record.
- return Lv2M (New_Selected_Element (M2Lv (Arr), Box_Field),
- Info, Kind,
- Info.B.Base_Type (Kind),
- Info.B.Base_Ptr_Type (Kind));
- else
- return Arr;
- end if;
- end;
+ return Unbox_Record (Obj);
when others =>
raise Internal_Error;
end case;
- end Unbox_Record;
+ end Get_Composite_Unbounded_Base;
function Create_Maybe_Fat_Array_Element (Arr : Mnode; Arr_Type : Iir)
return Mnode
@@ -3072,13 +2952,12 @@ package body Trans.Chap3 is
return Mnode
is
El_Type : constant Iir := Get_Element_Subtype (Atype);
- El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
Kind : constant Object_Kind_Type := Get_Object_Kind (Base);
begin
return E2M (Reindex_Array
(Base, Atype,
Index,
- New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var))),
+ Get_Subtype_Size (El_Type, Mnode_Null, Kind)),
Res_Info, Kind);
end Reindex_Complex_Array;
@@ -3151,22 +3030,6 @@ package body Trans.Chap3 is
end if;
end Slice_Base;
- procedure Maybe_Call_Type_Builder (Obj : Mnode; Obj_Type : Iir)
- is
- Dinfo : constant Type_Info_Acc :=
- Get_Info (Get_Base_Type (Obj_Type));
- Kind : constant Object_Kind_Type := Get_Object_Kind (Obj);
- begin
- if Is_Complex_Type (Dinfo)
- and then Dinfo.C (Kind).Builder_Need_Func
- then
- Open_Temp;
- -- Build the type.
- Chap3.Gen_Call_Type_Builder (Obj, Obj_Type);
- Close_Temp;
- end if;
- end Maybe_Call_Type_Builder;
-
procedure Allocate_Unbounded_Composite_Base (Alloc_Kind : Allocation_Kind;
Res : Mnode;
Arr_Type : Iir)
@@ -3182,8 +3045,6 @@ package body Trans.Chap3 is
New_Assign_Stmt
(M2Lp (Chap3.Get_Composite_Base (Res)),
Gen_Alloc (Alloc_Kind, Length, Dinfo.B.Base_Ptr_Type (Kind)));
-
- Maybe_Call_Type_Builder (Res, Arr_Type);
end Allocate_Unbounded_Composite_Base;
procedure Allocate_Unbounded_Composite_Bounds
@@ -3207,12 +3068,12 @@ package body Trans.Chap3 is
begin
Chap3.Translate_Subtype_Definition
(Arr_Type, Get_Base_Type (Arr_Type), False);
- Chap3.Create_Composite_Subtype_Bounds_Var (Arr_Type, False);
+ Chap3.Create_Composite_Subtype_Layout_Var (Arr_Type, False);
end Translate_Array_Subtype;
procedure Elab_Array_Subtype (Arr_Type : Iir) is
begin
- Chap3.Elab_Composite_Subtype_Bounds (Arr_Type);
+ Chap3.Elab_Composite_Subtype_Layout (Arr_Type);
end Elab_Array_Subtype;
procedure Create_Array_Subtype (Sub_Type : Iir)
@@ -3226,8 +3087,7 @@ package body Trans.Chap3 is
(Sub_Type, Get_Base_Type (Sub_Type), False);
end if;
-- Force creation of variables.
- Chap3.Create_Composite_Subtype_Bounds_Var (Sub_Type, True);
- Chap3.Elab_Type_Definition_Size_Var (Sub_Type);
+ Chap3.Create_Composite_Subtype_Layout_Var (Sub_Type, True);
Pop_Identifier_Prefix (Mark);
end Create_Array_Subtype;
@@ -3271,66 +3131,30 @@ package body Trans.Chap3 is
Type_Info : constant Type_Info_Acc := Get_Info (Atype);
begin
case Type_Info.Type_Mode is
- when Type_Mode_Complex_Array
- | Type_Mode_Complex_Record =>
- -- The length is pre-computed for a complex bounded type.
- if Type_Info.C (Kind).Size_Var /= Null_Var then
- return New_Value (Get_Var (Type_Info.C (Kind).Size_Var));
- else
- raise Internal_Error;
- end if;
when Type_Mode_Non_Composite
| Type_Mode_Static_Array
| Type_Mode_Static_Record =>
return New_Lit (New_Sizeof (Type_Info.Ortho_Type (Kind),
Ghdl_Index_Type));
+ when Type_Mode_Complex_Array
+ | Type_Mode_Complex_Record =>
+ -- The length is pre-computed for a complex bounded type.
+ return New_Value
+ (Sizes_To_Size
+ (Layout_To_Sizes
+ (Get_Composite_Type_Layout (Type_Info)), Kind));
when Type_Mode_Unbounded_Array =>
declare
El_Type : constant Iir := Get_Element_Subtype (Atype);
El_Sz : O_Enode;
begin
- -- See create_array_size_var.
+ -- FIXME: unbounded elements ?
El_Sz := Get_Subtype_Size (El_Type, Mnode_Null, Kind);
return New_Dyadic_Op
(ON_Mul_Ov, Chap3.Get_Bounds_Length (Bounds, Atype), El_Sz);
end;
when Type_Mode_Unbounded_Record =>
- declare
- El_List : constant Iir_Flist :=
- Get_Elements_Declaration_List (Atype);
- El : Iir;
- El_Type : Iir;
- El_Type_Info : Type_Info_Acc;
- El_Bounds : Mnode;
- Stable_Bounds : Mnode;
- Res : O_Enode;
- begin
- Stable_Bounds := Stabilize (Bounds);
-
- -- Size of base type
- Res := New_Lit (New_Sizeof (Type_Info.B.Base_Type (Kind),
- Ghdl_Index_Type));
- for I in Flist_First .. Flist_Last (El_List) loop
- El := Get_Nth_Element (El_List, I);
- El_Type := Get_Type (El);
- El_Type_Info := Get_Info (El_Type);
- if El_Type_Info.Type_Mode in Type_Mode_Unbounded then
- -- Recurse
- Res := Realign (Res, El_Type);
- El_Bounds := Bounds_To_Element_Bounds (Stable_Bounds, El);
- Res := New_Dyadic_Op
- (ON_Add_Ov,
- Res, Get_Subtype_Size (El_Type, El_Bounds, Kind));
- elsif Is_Complex_Type (El_Type_Info) then
- -- Add supplement
- Res := Realign (Res, El_Type);
- Res := New_Dyadic_Op
- (ON_Add_Ov,
- Res, Get_Subtype_Size (El_Type, Mnode_Null, Kind));
- end if;
- end loop;
- return Res;
- end;
+ return New_Value (Sizes_To_Size (Layout_To_Sizes (Bounds), Kind));
when others =>
raise Internal_Error;
end case;
@@ -3385,8 +3209,6 @@ package body Trans.Chap3 is
Gen_Alloc (Alloc_Kind,
Chap3.Get_Object_Size (T2M (Obj_Type, Kind), Obj_Type),
Tinfo.Ortho_Ptr_Type (Kind)));
-
- Maybe_Call_Type_Builder (Res, Obj_Type);
end if;
end Translate_Object_Allocation;
diff --git a/src/vhdl/translate/trans-chap3.ads b/src/vhdl/translate/trans-chap3.ads
index 9900f48a9..2b9f37e6b 100644
--- a/src/vhdl/translate/trans-chap3.ads
+++ b/src/vhdl/translate/trans-chap3.ads
@@ -43,7 +43,7 @@ package Trans.Chap3 is
procedure Translate_Type_Subprograms
(Decl : Iir; Kind : Subprg_Translate_Kind);
- function Create_Static_Composite_Subtype_Bounds (Def : Iir) return O_Cnode;
+ function Create_Static_Composite_Subtype_Layout (Def : Iir) return O_Cnode;
-- Same as Translate_type_definition only for std.standard.boolean and
-- std.standard.bit.
@@ -116,9 +116,6 @@ package Trans.Chap3 is
-- For a second or third order complex type, INFO.C.BUILDER_NEED_FUNC
-- is set to TRUE.
- -- Call builder for variable pointed VAR of type VAR_TYPE.
- procedure Gen_Call_Type_Builder (Var : Mnode; Var_Type : Iir);
-
-- Functions for fat array.
-- Fat array are array whose size is not known at compilation time.
-- This corresponds to an unconstrained array or a non locally static
@@ -166,11 +163,17 @@ package Trans.Chap3 is
-- Get the number of elements in array ATYPE.
function Get_Array_Type_Length (Atype : Iir) return O_Enode;
- -- Get the base of array or record ARR.
- function Get_Composite_Base (Arr : Mnode) return Mnode;
+ -- Get the base of array or record OBJ. If OBJ is already constrained,
+ -- return it.
+ function Get_Composite_Base (Obj : Mnode) return Mnode;
+
+ -- Get the base of array or record OBJ; but if OBJ is already constrained,
+ -- convert it to the base of an unbounded object (so this unboxes the
+ -- records).
+ function Get_Composite_Unbounded_Base (Obj : Mnode) return Mnode;
-- Get the bounds of composite ARR (an array or an unbounded record).
- function Get_Composite_Bounds (Arr : Mnode) return Mnode;
+ function Get_Composite_Bounds (Obj : Mnode) return Mnode;
-- Get the range ot ATYPE.
function Type_To_Range (Atype : Iir) return Mnode;
@@ -194,16 +197,27 @@ package Trans.Chap3 is
function Get_Array_Range (Arr : Mnode; Atype : Iir; Dim : Positive)
return Mnode;
- -- Get array bounds for type ATYPE.
- function Get_Array_Type_Bounds (Atype : Iir) return Mnode;
+ -- Get array/record bounds for type ATYPE.
+ function Get_Composite_Type_Bounds (Atype : Iir) return Mnode;
-- Return a pointer to the base from bounds_acc ACC.
function Get_Bounds_Acc_Base
(Acc : O_Enode; D_Type : Iir) return O_Enode;
+ -- Return bounds from layout B.
+ function Layout_To_Bounds (B : Mnode) return Mnode;
+
+ -- From a record layout B, return the layout of element EL. EL must be
+ -- an unbounded element.
+ function Record_Layout_To_Element_Layout (B : Mnode; El : Iir) return Mnode;
+
-- From an unbounded record bounds B, get the bounds for (unbounded)
-- element EL.
- function Bounds_To_Element_Bounds (B : Mnode; El : Iir) return Mnode;
+ function Record_Bounds_To_Element_Bounds (B : Mnode; El : Iir) return Mnode;
+
+ -- Return the offset for field EL in record B.
+ function Record_Layout_To_Element_Offset
+ (B : Mnode; El : Iir; Kind : Object_Kind_Type) return O_Lnode;
-- From an unbounded array bounds B, get the bounds for the (unbounded)
-- element.
@@ -246,9 +260,6 @@ package Trans.Chap3 is
-- it may be the result of T2M.
function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode;
- -- If needed call the procedure to build OBJ.
- procedure Maybe_Call_Type_Builder (Obj : Mnode; Obj_Type : Iir);
-
-- Allocate the base of an unbounded composite, whose length is
-- determined from the bounds (already set).
-- RES_PTR is a pointer to the fat pointer (must be a stable variable: it
diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb
index 47b9f5674..69577161e 100644
--- a/src/vhdl/translate/trans-chap4.adb
+++ b/src/vhdl/translate/trans-chap4.adb
@@ -301,8 +301,6 @@ package body Trans.Chap4 is
is
Type_Info : constant Type_Info_Acc := Get_Type_Info (Var);
Kind : constant Object_Kind_Type := Get_Object_Kind (Var);
- Targ : Mnode;
- Has_Ref : Boolean;
begin
-- Cannot allocate unconstrained object (since size is unknown).
pragma Assert (Type_Info.Type_Mode not in Type_Mode_Unbounded);
@@ -312,34 +310,12 @@ package body Trans.Chap4 is
return;
end if;
- Has_Ref := False;
- Targ := Var;
-
- if not Is_Static_Type (Type_Info) then
- if Type_Info.C (Kind).Builder_Need_Func
- and then not Is_Stable (Var)
- then
- -- Need a stable reference...
- Targ := Create_Temp (Type_Info, Kind);
- Has_Ref := True;
- end if;
-
- -- Allocate variable.
- New_Assign_Stmt (M2Lp (Targ),
- Gen_Alloc (Alloc_Kind,
- Chap3.Get_Object_Size (Var, Obj_Type),
- Type_Info.Ortho_Ptr_Type (Kind)));
- end if;
-
- if Type_Info.C (Kind).Builder_Need_Func then
- -- Build the type.
- Chap3.Gen_Call_Type_Builder (Targ, Obj_Type);
- end if;
-
- if Has_Ref then
- New_Assign_Stmt (M2Lp (Var), M2Addr (Targ));
- Var := Targ;
- end if;
+ -- Allocate variable.
+ New_Assign_Stmt
+ (M2Lp (Var),
+ Gen_Alloc (Alloc_Kind,
+ Chap3.Get_Subtype_Size (Obj_Type, Mnode_Null, Kind),
+ Type_Info.Ortho_Ptr_Type (Kind)));
end Allocate_Complex_Object;
-- Note : OBJ can be a tree.
@@ -535,13 +511,13 @@ package body Trans.Chap4 is
-- Short-cut: don't allocate bounds.
New_Assign_Stmt
(M2Lp (Chap3.Get_Composite_Bounds (Name_Node)),
- M2Addr (Chap3.Get_Array_Type_Bounds (Aggr_Type)));
+ M2Addr (Chap3.Get_Composite_Type_Bounds (Aggr_Type)));
Chap3.Allocate_Unbounded_Composite_Base
(Alloc_Kind, Name_Node, Get_Base_Type (Aggr_Type));
else
Chap3.Translate_Object_Allocation
(Name_Node, Alloc_Kind, Get_Base_Type (Aggr_Type),
- Chap3.Get_Array_Type_Bounds (Aggr_Type));
+ Chap3.Get_Composite_Type_Bounds (Aggr_Type));
end if;
end;
else
@@ -642,23 +618,35 @@ package body Trans.Chap4 is
Obj_Type : constant Iir := Get_Type (Obj);
Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type);
begin
- if Type_Info.Type_Mode in Type_Mode_Unbounded then
- declare
- V : Mnode;
- begin
- Open_Temp;
- V := Chap6.Translate_Name (Obj, Mode_Value);
- Stabilize (V);
- Chap3.Gen_Deallocate
- (New_Value (M2Lp (Chap3.Get_Composite_Bounds (V))));
+ case Type_Mode_Valid (Type_Info.Type_Mode) is
+ when Type_Mode_Unbounded =>
+ declare
+ V : Mnode;
+ begin
+ Open_Temp;
+ V := Chap6.Translate_Name (Obj, Mode_Value);
+ Stabilize (V);
+ Chap3.Gen_Deallocate
+ (New_Value (M2Lp (Chap3.Get_Composite_Bounds (V))));
+ Chap3.Gen_Deallocate
+ (New_Value (M2Lp (Chap3.Get_Composite_Base (V))));
+ Close_Temp;
+ end;
+ when Type_Mode_Complex_Array
+ | Type_Mode_Complex_Record
+ | Type_Mode_Protected =>
Chap3.Gen_Deallocate
- (New_Value (M2Lp (Chap3.Get_Composite_Base (V))));
- Close_Temp;
- end;
- elsif Is_Complex_Type (Type_Info) then
- Chap3.Gen_Deallocate
- (New_Value (M2Lp (Chap6.Translate_Name (Obj, Mode_Value))));
- end if;
+ (New_Value (M2Lp (Chap6.Translate_Name (Obj, Mode_Value))));
+ when Type_Mode_Scalar
+ | Type_Mode_Static_Record
+ | Type_Mode_Static_Array
+ | Type_Mode_Acc
+ | Type_Mode_Bounds_Acc =>
+ null;
+ when Type_Mode_File =>
+ -- FIXME: free file ?
+ null;
+ end case;
end Fini_Object;
function Get_Nbr_Signals (Sig : Mnode; Sig_Type : Iir) return O_Enode
@@ -1152,9 +1140,9 @@ package body Trans.Chap4 is
begin
Start_Association (Assoc, Ghdl_Signal_Name_Rti);
New_Association
- (Assoc, New_Lit (New_Global_Unchecked_Address
- (Get_Info (Base_Decl).Signal_Rti,
- Rtis.Ghdl_Rti_Access)));
+ (Assoc,
+ New_Unchecked_Address (New_Obj (Get_Info (Base_Decl).Signal_Rti),
+ Rtis.Ghdl_Rti_Access));
Rtis.Associate_Rti_Context (Assoc, Parent);
New_Procedure_Call (Assoc);
end;
@@ -3184,7 +3172,8 @@ package body Trans.Chap4 is
Start_Init_Value (C);
Start_Record_Aggr (Constr, Ghdl_Location_Type_Node);
New_Record_Aggr_El
- (Constr, New_Global_Address (Current_Filename_Node, Char_Ptr_Type));
+ (Constr, New_Global_Address (New_Global (Current_Filename_Node),
+ Char_Ptr_Type));
New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type,
Integer_64 (Line)));
New_Record_Aggr_El (Constr, New_Signed_Literal (Ghdl_I32_Type,
diff --git a/src/vhdl/translate/trans-chap5.adb b/src/vhdl/translate/trans-chap5.adb
index 5f8375760..4c3f0ce20 100644
--- a/src/vhdl/translate/trans-chap5.adb
+++ b/src/vhdl/translate/trans-chap5.adb
@@ -424,7 +424,7 @@ package body Trans.Chap5 is
if Get_Info (Formal_Type).Type_Mode in Type_Mode_Composite then
New_Assign_Stmt
(M2Lp (Chap3.Get_Composite_Base (Formal_Val)),
- M2Addr (Chap3.Get_Composite_Base (Actual_Val)));
+ M2Addr (Chap3.Get_Composite_Unbounded_Base (Actual_Val)));
else
New_Assign_Stmt (M2Lp (Formal_Val), M2Addr (Actual_Val));
end if;
@@ -537,11 +537,11 @@ package body Trans.Chap5 is
begin
if Is_Fully_Constrained_Type (Actual_Type) then
Chap3.Create_Array_Subtype (Actual_Type);
- Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type);
+ Bounds := Chap3.Get_Composite_Type_Bounds (Actual_Type);
Tinfo := Get_Info (Actual_Type);
if Save
and then
- Get_Alloc_Kind_For_Var (Tinfo.S.Composite_Bounds) = Alloc_Stack
+ Get_Alloc_Kind_For_Var (Tinfo.S.Composite_Layout) = Alloc_Stack
then
-- We need a copy.
Bounds_Copy := Alloc_Bounds (Actual_Type, Alloc_System);
@@ -575,7 +575,7 @@ package body Trans.Chap5 is
In_Conv_Type := Get_Type (In_Conv);
if Is_Fully_Constrained_Type (In_Conv_Type) then
-- The 'in' conversion gives the type.
- return Chap3.Get_Array_Type_Bounds (In_Conv_Type);
+ return Chap3.Get_Composite_Type_Bounds (In_Conv_Type);
elsif Get_Kind (In_Conv) = Iir_Kind_Type_Conversion then
-- Convert bounds of the actual.
Can_Convert := True;
@@ -590,7 +590,7 @@ package body Trans.Chap5 is
Param_Type := Get_Type (Get_Interface_Declaration_Chain
(Get_Implementation (Out_Conv)));
if Is_Fully_Constrained_Type (Param_Type) then
- return Chap3.Get_Array_Type_Bounds (Param_Type);
+ return Chap3.Get_Composite_Type_Bounds (Param_Type);
else
pragma Assert (Can_Convert);
null;
@@ -629,35 +629,33 @@ package body Trans.Chap5 is
Get_Type (Get_Default_Value (Port));
begin
Chap3.Create_Array_Subtype (Actual_Type);
- Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type);
+ Bounds := Chap3.Get_Composite_Type_Bounds (Actual_Type);
end;
when Iir_Kind_Association_Element_By_Individual =>
declare
Actual_Type : constant Iir := Get_Actual_Type (Assoc);
begin
Chap3.Create_Array_Subtype (Actual_Type);
- Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type);
+ Bounds := Chap3.Get_Composite_Type_Bounds (Actual_Type);
end;
end case;
Stabilize (Bounds);
for K in Object_Kind_Type loop
Act_Node := Chap6.Translate_Name (Port, K);
- New_Assign_Stmt
- (-- Note: this works only because it is not stabilized, and
- -- therefore the bounds field is returned and not a pointer to
- -- the bounds.
- M2Lp (Chap3.Get_Composite_Bounds (Act_Node)),
- M2Addr (Bounds));
+ -- Note: this works only because it is not stabilized, and
+ -- therefore the bounds field is returned and not a pointer to
+ -- the bounds.
+ New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Act_Node)),
+ M2Addr (Bounds));
end loop;
-- Set bounds of init value (if present)
Info := Get_Info (Port);
if Info.Signal_Val /= Null_Var then
- New_Assign_Stmt
- (M2Lp (Chap3.Get_Composite_Bounds
- (Chap6.Get_Port_Init_Value (Port))),
- M2Addr (Bounds));
+ New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds
+ (Chap6.Get_Port_Init_Value (Port))),
+ M2Addr (Bounds));
end if;
Close_Temp;
end Elab_Unconstrained_Port_Bounds;
@@ -824,7 +822,7 @@ package body Trans.Chap5 is
(Formal_Type, Alloc_System, Formal_Node);
else
Chap3.Create_Array_Subtype (Obj_Type);
- Bounds := Chap3.Get_Array_Type_Bounds (Obj_Type);
+ Bounds := Chap3.Get_Composite_Type_Bounds (Obj_Type);
Chap3.Translate_Object_Allocation
(Formal_Node, Alloc_System, Formal_Type, Bounds);
end if;
diff --git a/src/vhdl/translate/trans-chap6.adb b/src/vhdl/translate/trans-chap6.adb
index 08f7de26e..7eb74820a 100644
--- a/src/vhdl/translate/trans-chap6.adb
+++ b/src/vhdl/translate/trans-chap6.adb
@@ -412,7 +412,7 @@ package body Trans.Chap6 is
-- Manually extract range since there is no infos for
-- index subtype.
Range_Ptr := Chap3.Bounds_To_Range
- (Chap3.Get_Array_Type_Bounds (Prefix_Type),
+ (Chap3.Get_Composite_Type_Bounds (Prefix_Type),
Prefix_Type, Dim);
Stabilize (Range_Ptr);
R := Translate_Index_To_Offset
@@ -596,7 +596,7 @@ package body Trans.Chap6 is
-- Save slice bounds.
Slice_Range := Stabilize
- (Chap3.Bounds_To_Range (Chap3.Get_Array_Type_Bounds (Slice_Type),
+ (Chap3.Bounds_To_Range (Chap3.Get_Composite_Type_Bounds (Slice_Type),
Slice_Type, 1));
-- TRUE if the direction of the slice is known.
@@ -834,7 +834,10 @@ package body Trans.Chap6 is
Kind : constant Object_Kind_Type := Get_Object_Kind (Prefix);
El_Info : Field_Info_Acc;
Base_Tinfo : Type_Info_Acc;
- Stable_Prefix, Base, Res, Fat_Res : Mnode;
+ Stable_Prefix : Mnode;
+ Base, Res, Fat_Res : Mnode;
+ Rec_Layout : Mnode;
+ El_Descr : Mnode;
Box_Field : O_Fnode;
B : O_Lnode;
begin
@@ -856,26 +859,26 @@ package body Trans.Chap6 is
Stable_Prefix := Stabilize (Prefix);
-- Result is a fat pointer, create it and set bounds.
+ -- FIXME: layout for record, bounds for array!
Fat_Res := Create_Temp (El_Tinfo, Kind);
- New_Assign_Stmt
- (M2Lp (Chap3.Get_Composite_Bounds (Fat_Res)),
- New_Address
- (New_Selected_Element
- (M2Lv (Chap3.Get_Composite_Bounds (Stable_Prefix)),
- El_Info.Field_Bound),
- El_Tinfo.B.Bounds_Ptr_Type));
+ El_Descr := Chap3.Record_Layout_To_Element_Layout
+ (Chap3.Get_Composite_Bounds (Stable_Prefix), El);
+ case El_Tinfo.Type_Mode is
+ when Type_Mode_Unbounded_Record =>
+ null;
+ when Type_Mode_Unbounded_Array =>
+ El_Descr := Chap3.Layout_To_Bounds (El_Descr);
+ when others =>
+ raise Internal_Error;
+ end case;
+ New_Assign_Stmt (M2Lp (Chap3.Get_Composite_Bounds (Fat_Res)),
+ M2Addr (El_Descr));
else
Stable_Prefix := Prefix;
end if;
- if Get_Type_Info (Stable_Prefix).Type_Mode = Type_Mode_Unbounded_Record
- then
- -- Get the base.
- Base := Chap3.Get_Composite_Base (Stable_Prefix);
- else
- -- Might be a boxed subtype; keep the box to optimize the access.
- Base := Stable_Prefix;
- end if;
+ -- Get the base.
+ Base := Chap3.Get_Composite_Base (Stable_Prefix);
Base_Tinfo := Get_Type_Info (Base);
Box_Field := Base_Tinfo.S.Box_Field (Kind);
@@ -895,6 +898,7 @@ package body Trans.Chap6 is
end if;
-- The element is complex: it's an offset.
+ Rec_Layout := Chap3.Get_Composite_Bounds (Stable_Prefix);
Res := E2M
(New_Unchecked_Address
(New_Slice
@@ -902,8 +906,8 @@ package body Trans.Chap6 is
(New_Unchecked_Address (M2Lv (Base), Char_Ptr_Type)),
Chararray_Type,
New_Value
- (New_Selected_Element (B,
- El_Info.Field_Node (Kind)))),
+ (Chap3.Record_Layout_To_Element_Offset
+ (Rec_Layout, El, Kind))),
El_Tinfo.B.Base_Ptr_Type (Kind)),
El_Tinfo, Kind);
else
diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb
index 614f993f3..e93dce632 100644
--- a/src/vhdl/translate/trans-chap7.adb
+++ b/src/vhdl/translate/trans-chap7.adb
@@ -65,7 +65,7 @@ package body Trans.Chap7 is
Val : Var_Type;
Res : O_Cnode;
List : O_Record_Aggr_List;
- Bound : Var_Type;
+ Layout : Var_Type;
begin
if Res_Type = Expr_Type then
return Expr;
@@ -96,22 +96,24 @@ package body Trans.Chap7 is
Val := Create_Global_Const
(Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value),
O_Storage_Private, Expr);
- Bound := Expr_Info.S.Composite_Bounds;
- if Bound = Null_Var then
- Bound := Create_Global_Const
- (Create_Uniq_Identifier, Expr_Info.B.Bounds_Type,
+ Layout := Expr_Info.S.Composite_Layout;
+ if Layout = Null_Var then
+ Layout := Create_Global_Const
+ (Create_Uniq_Identifier, Expr_Info.B.Layout_Type,
O_Storage_Private,
- Chap3.Create_Static_Composite_Subtype_Bounds (Expr_Type));
- Expr_Info.S.Composite_Bounds := Bound;
+ Chap3.Create_Static_Composite_Subtype_Layout (Expr_Type));
+ Expr_Info.S.Composite_Layout := Layout;
end if;
Start_Record_Aggr (List, Res_Info.Ortho_Type (Mode_Value));
New_Record_Aggr_El
- (List, New_Global_Address (Get_Var_Label (Val),
- Res_Info.B.Base_Ptr_Type (Mode_Value)));
+ (List, New_Global_Address (New_Global (Get_Var_Label (Val)),
+ Res_Info.B.Base_Ptr_Type (Mode_Value)));
New_Record_Aggr_El
- (List, New_Global_Address (Get_Var_Label (Bound),
- Expr_Info.B.Bounds_Ptr_Type));
+ (List, New_Global_Address (New_Global_Selected_Element
+ (New_Global (Get_Var_Label (Layout)),
+ Expr_Info.B.Layout_Bounds),
+ Expr_Info.B.Bounds_Ptr_Type));
Finish_Record_Aggr (List, Res);
return Res;
@@ -375,12 +377,12 @@ package body Trans.Chap7 is
Start_Record_Aggr (Res_Aggr, Type_Info.Ortho_Type (Mode_Value));
New_Record_Aggr_El
(Res_Aggr,
- New_Global_Address (Get_Var_Label (Val),
- Type_Info.B.Base_Ptr_Type (Mode_Value)));
+ New_Global_Address (New_Global (Get_Var_Label (Val)),
+ Type_Info.B.Base_Ptr_Type (Mode_Value)));
New_Record_Aggr_El
(Res_Aggr,
- New_Global_Address (Get_Var_Label (Bound),
- Type_Info.B.Bounds_Ptr_Type));
+ New_Global_Address (New_Global (Get_Var_Label (Bound)),
+ Type_Info.B.Bounds_Ptr_Type));
Finish_Record_Aggr (Res_Aggr, Res);
Val := Create_Global_Const
@@ -818,7 +820,7 @@ package body Trans.Chap7 is
Atype_El_Type := Get_Type (Atype_El);
if Expr_El_Type /= Atype_El_Type then
Convert_To_Constrained_Check
- (Chap3.Bounds_To_Element_Bounds
+ (Chap3.Record_Bounds_To_Element_Bounds
(Stable_Bounds, Expr_El),
Expr_El_Type, Atype_El_Type, Failure_Label);
end if;
@@ -2626,8 +2628,7 @@ package body Trans.Chap7 is
return Translate_To_String
(Subprg, Res_Type, Expr,
New_Convert_Ov (Left_Tree, Conv),
- New_Lit (Rtis.New_Rti_Address
- (Get_Info (Left_Type).Type_Rti)));
+ Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti));
end;
when Iir_Predefined_Floating_To_String =>
return Translate_To_String
@@ -2661,15 +2662,13 @@ package body Trans.Chap7 is
return Translate_To_String
(Subprg, Res_Type, Expr,
New_Convert_Ov (Left_Tree, Conv),
- New_Lit (Rtis.New_Rti_Address
- (Get_Info (Left_Type).Type_Rti)));
+ Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti));
end;
when Iir_Predefined_Time_To_String_Unit =>
return Translate_To_String
(Ghdl_Time_To_String_Unit, Res_Type, Expr,
Left_Tree, Right_Tree,
- New_Lit (Rtis.New_Rti_Address
- (Get_Info (Left_Type).Type_Rti)));
+ Rtis.New_Rti_Address (Get_Info (Left_Type).Type_Rti));
when Iir_Predefined_Bit_Vector_To_Ostring =>
return Translate_Bv_To_String
(Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Expr);
@@ -2699,8 +2698,7 @@ package body Trans.Chap7 is
New_Convert_Ov (M2E (Chap3.Get_Composite_Base (Arg)),
Ghdl_Ptr_Type),
Chap3.Get_Array_Length (Arg, Left_Type),
- New_Lit (Rtis.New_Rti_Address
- (Get_Info (El_Type).Type_Rti)));
+ Rtis.New_Rti_Address (Get_Info (El_Type).Type_Rti));
end;
when others =>
@@ -3551,7 +3549,7 @@ package body Trans.Chap7 is
Val_Size := Create_Temp_Init
(Ghdl_Index_Type,
Chap3.Get_Subtype_Size
- (D_Type, Chap3.Get_Array_Type_Bounds (Sub_Type),
+ (D_Type, Chap3.Get_Composite_Type_Bounds (Sub_Type),
Mode_Value));
-- Size of the bounds.
@@ -3569,14 +3567,12 @@ package body Trans.Chap7 is
A_Info.Ortho_Type (Mode_Value)));
-- Copy bounds.
- Gen_Memcpy
- (New_Obj_Value (Ptr),
- M2Addr (Chap3.Get_Array_Type_Bounds (Sub_Type)),
- New_Lit (Bounds_Size));
+ Gen_Memcpy (New_Obj_Value (Ptr),
+ M2Addr (Chap3.Get_Composite_Type_Bounds (Sub_Type)),
+ New_Lit (Bounds_Size));
-- Create a fat pointer to initialize the object.
Res := Bounds_Acc_To_Fat_Pointer (Ptr, A_Type);
- Chap3.Maybe_Call_Type_Builder (Res, D_Type);
Chap4.Init_Object (Res, D_Type);
return New_Obj_Value (Ptr);
diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb
index 8fc959ab5..318d0142f 100644
--- a/src/vhdl/translate/trans-chap8.adb
+++ b/src/vhdl/translate/trans-chap8.adb
@@ -2713,7 +2713,8 @@ package body Trans.Chap8 is
if Mode = Mode_Value then
if Get_Type_Staticness (Actual_Type) >= Globally then
Chap3.Create_Array_Subtype (Actual_Type);
- Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type);
+ Bounds :=
+ Chap3.Get_Composite_Type_Bounds (Actual_Type);
Chap3.Translate_Object_Allocation
(Param, Alloc, Formal_Type, Bounds);
else
@@ -2877,7 +2878,7 @@ package body Trans.Chap8 is
Stabilize (Saved_Val (Pos));
Chap3.Copy_Bounds
- (Chap3.Bounds_To_Element_Bounds
+ (Chap3.Record_Bounds_To_Element_Bounds
(Chap3.Get_Composite_Bounds
(Params (Last_Individual)),
Get_Selected_Element (Formal)),
diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb
index 10bd3233f..669f86ee4 100644
--- a/src/vhdl/translate/trans-chap9.adb
+++ b/src/vhdl/translate/trans-chap9.adb
@@ -925,7 +925,7 @@ package body Trans.Chap9 is
(New_Selected_Element (Get_Instance_Ref (Ref_Scope),
Comp_Field),
Rtis.Ghdl_Component_Link_Stmt),
- New_Lit (Rtis.Get_Context_Rti (Stmt)));
+ Rtis.Get_Context_Rti (Stmt));
end Set_Component_Link;
Info : constant Block_Info_Acc := Get_Info (Stmt);
@@ -2523,9 +2523,8 @@ package body Trans.Chap9 is
New_Association
(Assoc, New_Convert_Ov (New_Value (M2Lv (Targ)), Ghdl_Signal_Ptr));
New_Association
- (Assoc,
- New_Lit (New_Global_Unchecked_Address
- (Get_Info (Sig).Signal_Rti, Rtis.Ghdl_Rti_Access)));
+ (Assoc, New_Unchecked_Address (New_Obj (Get_Info (Sig).Signal_Rti),
+ Rtis.Ghdl_Rti_Access));
New_Procedure_Call (Assoc);
end Merge_Signals_Rti_Non_Composite;
diff --git a/src/vhdl/translate/trans-helpers2.adb b/src/vhdl/translate/trans-helpers2.adb
index b0cc37d58..1886ccab5 100644
--- a/src/vhdl/translate/trans-helpers2.adb
+++ b/src/vhdl/translate/trans-helpers2.adb
@@ -108,8 +108,8 @@ package body Trans.Helpers2 is
Unsigned_64 (Str'Length));
Start_Record_Aggr (List, Ghdl_Str_Len_Type_Node);
New_Record_Aggr_El (List, Str_Len);
- New_Record_Aggr_El (List, New_Global_Address (Str_Cst,
- Char_Ptr_Type));
+ New_Record_Aggr_El (List, New_Global_Address (New_Global (Str_Cst),
+ Char_Ptr_Type));
Finish_Record_Aggr (List, Res);
return Res;
end Create_String_Len;
@@ -283,10 +283,11 @@ package body Trans.Helpers2 is
procedure Assoc_Filename_Line (Assoc : in out O_Assoc_List;
Line : Natural) is
begin
- New_Association (Assoc,
- New_Lit (New_Global_Address (Current_Filename_Node,
- Char_Ptr_Type)));
- New_Association (Assoc, New_Lit (New_Signed_Literal
- (Ghdl_I32_Type, Integer_64 (Line))));
+ New_Association
+ (Assoc, New_Address (New_Obj (Current_Filename_Node),
+ Char_Ptr_Type));
+ New_Association
+ (Assoc, New_Lit (New_Signed_Literal (Ghdl_I32_Type,
+ Integer_64 (Line))));
end Assoc_Filename_Line;
end Trans.Helpers2;
diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb
index 268c4fb9d..0ab7a1bf9 100644
--- a/src/vhdl/translate/trans-rtis.adb
+++ b/src/vhdl/translate/trans-rtis.adb
@@ -110,9 +110,7 @@ package body Trans.Rtis is
Ghdl_Rtin_Subtype_Composite_Common : O_Fnode;
Ghdl_Rtin_Subtype_Composite_Name : O_Fnode;
Ghdl_Rtin_Subtype_Composite_Basetype : O_Fnode;
- Ghdl_Rtin_Subtype_Composite_Bounds : O_Fnode;
- Ghdl_Rtin_Subtype_Composite_Valsize : O_Fnode;
- Ghdl_Rtin_Subtype_Composite_Sigsize : O_Fnode;
+ Ghdl_Rtin_Subtype_Composite_Layout : O_Fnode;
-- Node for a record element.
Ghdl_Rtin_Element : O_Tnode;
@@ -121,6 +119,7 @@ package body Trans.Rtis is
Ghdl_Rtin_Element_Type : O_Fnode;
Ghdl_Rtin_Element_Valoff : O_Fnode;
Ghdl_Rtin_Element_Sigoff : O_Fnode;
+ Ghdl_Rtin_Element_Layout : O_Fnode;
-- Node for a record type.
Ghdl_Rtin_Type_Record : O_Tnode;
@@ -128,8 +127,7 @@ package body Trans.Rtis is
Ghdl_Rtin_Type_Record_Name : O_Fnode;
Ghdl_Rtin_Type_Record_Nbrel : O_Fnode;
Ghdl_Rtin_Type_Record_Elements : O_Fnode;
- --Ghdl_Rtin_Type_Record_Valsize : O_Fnode;
- --Ghdl_Rtin_Type_Record_Sigsize : O_Fnode;
+ Ghdl_Rtin_Type_Record_Layout : O_Fnode;
-- Node for an object.
Ghdl_Rtin_Object : O_Tnode;
@@ -155,6 +153,10 @@ package body Trans.Rtis is
Ghdl_Rtin_Component_Nbr_Child : O_Fnode;
Ghdl_Rtin_Component_Children : O_Fnode;
+ Null_Loc : O_Cnode;
+
+ function Get_Context_Rti (Node : Iir) return O_Dnode;
+
-- Create all the declarations for RTIs.
procedure Rti_Initialize is
begin
@@ -613,12 +615,8 @@ package body Trans.Rtis is
Get_Identifier ("name"), Char_Ptr_Type);
New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Basetype,
Get_Identifier ("basetype"), Ghdl_Rti_Access);
- New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Bounds,
- Get_Identifier ("bounds"), Ghdl_Ptr_Type);
- New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Valsize,
- Get_Identifier ("val_size"), Ghdl_Ptr_Type);
- New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Sigsize,
- Get_Identifier ("sig_size"), Ghdl_Ptr_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Subtype_Composite_Layout,
+ Get_Identifier ("layout"), Ghdl_Ptr_Type);
Finish_Record_Type (Constr, Ghdl_Rtin_Subtype_Composite);
New_Type_Decl (Get_Identifier ("__ghdl_rtin_subtype_composite"),
Ghdl_Rtin_Subtype_Composite);
@@ -637,6 +635,8 @@ package body Trans.Rtis is
Get_Identifier ("nbrel"), Ghdl_Index_Type);
New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Elements,
Get_Identifier ("elements"), Ghdl_Rti_Arr_Acc);
+ New_Record_Field (Constr, Ghdl_Rtin_Type_Record_Layout,
+ Get_Identifier ("layout"), Ghdl_Ptr_Type);
Finish_Record_Type (Constr, Ghdl_Rtin_Type_Record);
New_Type_Decl (Get_Identifier ("__ghdl_rtin_type_record"),
Ghdl_Rtin_Type_Record);
@@ -657,6 +657,8 @@ package body Trans.Rtis is
Get_Identifier ("val_off"), Ghdl_Index_Type);
New_Record_Field (Constr, Ghdl_Rtin_Element_Sigoff,
Get_Identifier ("sig_off"), Ghdl_Index_Type);
+ New_Record_Field (Constr, Ghdl_Rtin_Element_Layout,
+ Get_Identifier ("layout_off"), Ghdl_Index_Type);
Finish_Record_Type (Constr, Ghdl_Rtin_Element);
New_Type_Decl (Get_Identifier ("__ghdl_rtin_element"),
Ghdl_Rtin_Element);
@@ -722,6 +724,7 @@ package body Trans.Rtis is
Ghdl_Rtin_Component);
end;
+ Null_Loc := New_Null_Access (Ghdl_Ptr_Type);
end Rti_Initialize;
package Rti_Builders is
@@ -891,8 +894,8 @@ package body Trans.Rtis is
for I in Cur_Block.List.Rtis'Range loop
exit when I > Nbr;
New_Array_Aggr_El
- (List, New_Global_Unchecked_Address (Cur_Block.List.Rtis (I),
- Ghdl_Rti_Access));
+ (List, New_Global_Unchecked_Address
+ (New_Global (Cur_Block.List.Rtis (I)), Ghdl_Rti_Access));
end loop;
-- Next chunks.
@@ -902,7 +905,7 @@ package body Trans.Rtis is
for I in L.Rtis'Range loop
exit when I > Nbr;
New_Array_Aggr_El
- (List, New_Global_Unchecked_Address (L.Rtis (I),
+ (List, New_Global_Unchecked_Address (New_Global (L.Rtis (I)),
Ghdl_Rti_Access));
end loop;
L := L.Next;
@@ -997,22 +1000,25 @@ package body Trans.Rtis is
end if;
end Generate_Name;
- function Get_Null_Loc return O_Cnode is
- begin
- return New_Null_Access (Ghdl_Ptr_Type);
- end Get_Null_Loc;
-
- function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode
- is
+ function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode is
begin
if Is_Var_Field (Var) then
return Get_Var_Offset (Var, Ghdl_Ptr_Type);
else
- return New_Global_Unchecked_Address (Get_Var_Label (Var),
+ return New_Global_Unchecked_Address (New_Global (Get_Var_Label (Var)),
Ghdl_Ptr_Type);
end if;
end Var_Acc_To_Loc;
+ function Var_Acc_To_Loc_Maybe (Var : Var_Type) return O_Cnode is
+ begin
+ if Var = Null_Var then
+ return Null_Loc;
+ else
+ return Var_Acc_To_Loc (Var);
+ end if;
+ end Var_Acc_To_Loc_Maybe;
+
-- Generate a name constant for the name of type definition DEF.
-- If DEF is an anonymous subtype, returns O_LNODE_NULL.
-- Use function NEW_NAME_ADDRESS (defined below) to convert the
@@ -1038,13 +1044,19 @@ package body Trans.Rtis is
if Name = O_Dnode_Null then
return New_Null_Access (Char_Ptr_Type);
else
- return New_Global_Unchecked_Address (Name, Char_Ptr_Type);
+ return New_Global_Unchecked_Address (New_Global (Name),
+ Char_Ptr_Type);
end if;
end New_Name_Address;
function New_Rti_Address (Rti : O_Dnode) return O_Cnode is
begin
- return New_Global_Unchecked_Address (Rti, Ghdl_Rti_Access);
+ return New_Global_Unchecked_Address (New_Global (Rti), Ghdl_Rti_Access);
+ end New_Rti_Address;
+
+ function New_Rti_Address (Rti : O_Dnode) return O_Enode is
+ begin
+ return New_Unchecked_Address (New_Obj (Rti), Ghdl_Rti_Access);
end New_Rti_Address;
-- Declare the RTI constant for type definition attached to INFO.
@@ -1109,8 +1121,7 @@ package body Trans.Rtis is
Start_Init_Value (Name_Arr);
Start_Array_Aggr (Arr_Aggr, Name_Arr_Type);
for I in Name_Lits'Range loop
- New_Array_Aggr_El
- (Arr_Aggr, New_Global_Address (Name_Lits (I), Char_Ptr_Type));
+ New_Array_Aggr_El (Arr_Aggr, New_Name_Address (Name_Lits (I)));
end loop;
Finish_Array_Aggr (Arr_Aggr, Val);
Finish_Init_Value (Name_Arr, Val);
@@ -1131,12 +1142,10 @@ package body Trans.Rtis is
Start_Record_Aggr (Rec_Aggr, Ghdl_Rtin_Type_Enum);
New_Record_Aggr_El (Rec_Aggr, Generate_Common_Type (Kind, 0, 0));
New_Record_Aggr_El (Rec_Aggr, New_Name_Address (Name));
+ New_Record_Aggr_El (Rec_Aggr, New_Index_Lit (Unsigned_64 (Nbr_Lit)));
New_Record_Aggr_El
- (Rec_Aggr, New_Unsigned_Literal (Ghdl_Index_Type,
- Unsigned_64 (Nbr_Lit)));
- New_Record_Aggr_El
- (Rec_Aggr,
- New_Global_Address (Name_Arr, Char_Ptr_Array_Ptr_Type));
+ (Rec_Aggr, New_Global_Address (New_Global (Name_Arr),
+ Char_Ptr_Array_Ptr_Type));
Finish_Record_Aggr (Rec_Aggr, Val);
Finish_Init_Value (Info.Type_Rti, Val);
end;
@@ -1210,7 +1219,7 @@ package body Trans.Rtis is
-- Handle non-static units. The only possibility is a unit of
-- std.standard.time.
Val := New_Global_Unchecked_Address
- (Get_Var_Label (Info.Object_Var), Ghdl_Ptr_Type);
+ (New_Global (Get_Var_Label (Info.Object_Var)), Ghdl_Ptr_Type);
else
Val := Chap7.Translate_Numeric_Literal (Unit, Ghdl_I64_Type);
end if;
@@ -1263,12 +1272,9 @@ package body Trans.Rtis is
end case;
New_Record_Aggr_El (List, Generate_Common_Type (Rti_Kind, 0, 0, 0));
New_Record_Aggr_El (List, New_Name_Address (Name));
- New_Record_Aggr_El
- (List,
- New_Unsigned_Literal (Ghdl_Index_Type,
- Unsigned_64 (Nbr_Units)));
- New_Record_Aggr_El
- (List, New_Global_Address (Unit_Arr, Ghdl_Rti_Arr_Acc));
+ New_Record_Aggr_El (List, New_Index_Lit (Unsigned_64 (Nbr_Units)));
+ New_Record_Aggr_El (List, New_Global_Address (New_Global (Unit_Arr),
+ Ghdl_Rti_Arr_Acc));
Finish_Record_Aggr (List, Val);
Finish_Init_Value (Info.Type_Rti, Val);
end Generate_Physical_Type_Definition;
@@ -1499,10 +1505,9 @@ package body Trans.Rtis is
New_Record_Aggr_El (Aggr, New_Name_Address (Name));
New_Record_Aggr_El (Aggr, New_Rti_Address (El_Info.Type_Rti));
New_Record_Aggr_El
- (Aggr,
- New_Unsigned_Literal (Ghdl_Index_Type,
- Unsigned_64 (Get_Nbr_Elements (List))));
- New_Record_Aggr_El (Aggr, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc));
+ (Aggr, New_Index_Lit (Unsigned_64 (Get_Nbr_Elements (List))));
+ New_Record_Aggr_El (Aggr, New_Global_Address (New_Global (Arr),
+ Ghdl_Rti_Arr_Acc));
Finish_Record_Aggr (Aggr, Val);
Finish_Init_Value (Info.Type_Rti, Val);
end Generate_Array_Type_Definition;
@@ -1521,7 +1526,7 @@ package body Trans.Rtis is
Kind : O_Cnode;
Depth : Rti_Depth_Type;
begin
- Bounds := Info.S.Composite_Bounds;
+ Bounds := Info.S.Composite_Layout;
Depth := Get_Depth_From_Var (Bounds);
Info.B.Rti_Max_Depth :=
Rti_Depth_Type'Max (Depth, Base_Info.B.Rti_Max_Depth);
@@ -1555,39 +1560,7 @@ package body Trans.Rtis is
(Kind, Depth, Info.B.Rti_Max_Depth, Type_To_Mode (Atype)));
New_Record_Aggr_El (Aggr, New_Name_Address (Name));
New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti));
- if Bounds = Null_Var then
- Val := Get_Null_Loc;
- else
- Val := Var_Acc_To_Loc (Bounds);
- end if;
- New_Record_Aggr_El (Aggr, Val);
- for I in Mode_Value .. Mode_Signal loop
- case Info.Type_Mode is
- when Type_Mode_Static_Array
- | Type_Mode_Static_Record =>
- if Info.Ortho_Type (I) /= O_Tnode_Null then
- Val := New_Sizeof (Info.Ortho_Type (I), Ghdl_Ptr_Type);
- else
- Val := Get_Null_Loc;
- end if;
- when Type_Mode_Complex_Array
- | Type_Mode_Complex_Record =>
- if Info.Ortho_Type (I) /= O_Tnode_Null
- and then Info.C (I).Size_Var /= Null_Var
- then
- Val := Var_Acc_To_Loc (Info.C (I).Size_Var);
- else
- Val := Get_Null_Loc;
- end if;
- when Type_Mode_Unbounded_Array
- | Type_Mode_Unbounded_Record =>
- Val := Get_Null_Loc;
- when others =>
- Error_Kind ("generate_composite_subtype_definition", Atype);
- end case;
- New_Record_Aggr_El (Aggr, Val);
- end loop;
-
+ New_Record_Aggr_El (Aggr, Var_Acc_To_Loc_Maybe (Bounds));
Finish_Record_Aggr (Aggr, Val);
Finish_Init_Value (Info.Type_Rti, Val);
end Generate_Composite_Subtype_Definition;
@@ -1640,12 +1613,14 @@ package body Trans.Rtis is
El := Get_Nth_Element (El_List, I);
declare
El_Type : constant Iir := Get_Type (El);
+ El_Tinfo : constant Type_Info_Acc := Get_Info (El_Type);
Field_Info : constant Field_Info_Acc := Get_Info (El);
Type_Rti : O_Dnode;
El_Name : O_Dnode;
Aggr : O_Record_Aggr_List;
Val : O_Cnode;
El_Const : O_Dnode;
+ Mode : Natural;
Mark : Id_Mark_Type;
begin
Push_Identifier_Prefix (Mark, Get_Identifier (El));
@@ -1655,25 +1630,51 @@ package body Trans.Rtis is
Rti_Depth_Type'Max (Max_Depth,
Get_Info (El_Type).B.Rti_Max_Depth);
+ case El_Tinfo.Type_Mode is
+ when Type_Mode_Unbounded_Array
+ | Type_Mode_Unbounded_Record =>
+ Mode := 2;
+ when Type_Mode_Complex_Record
+ | Type_Mode_Complex_Array =>
+ Mode := 1;
+ when others =>
+ Mode := 0;
+ end case;
El_Name := Generate_Name (El);
New_Const_Decl (El_Const, Create_Identifier ("RTIEL"),
Global_Storage, Ghdl_Rtin_Element);
Start_Init_Value (El_Const);
Start_Record_Aggr (Aggr, Ghdl_Rtin_Element);
- New_Record_Aggr_El (Aggr,
- Generate_Common (Ghdl_Rtik_Element));
+ New_Record_Aggr_El
+ (Aggr, Generate_Common (Ghdl_Rtik_Element, Mode => Mode));
New_Record_Aggr_El (Aggr, New_Name_Address (El_Name));
New_Record_Aggr_El (Aggr, New_Rti_Address (Type_Rti));
for I in Object_Kind_Type loop
if Field_Info.Field_Node (I) /= O_Fnode_Null then
- Val := New_Offsetof (Info.B.Base_Type (I),
- Field_Info.Field_Node (I),
- Ghdl_Index_Type);
+ if Is_Static_Type (El_Tinfo) then
+ Val := New_Offsetof (Info.B.Base_Type (I),
+ Field_Info.Field_Node (I),
+ Ghdl_Index_Type);
+ else
+ Val := New_Offsetof (Info.B.Bounds_Type,
+ Field_Info.Field_Node (I),
+ Ghdl_Index_Type);
+ end if;
else
Val := Ghdl_Index_0;
end if;
New_Record_Aggr_El (Aggr, Val);
end loop;
+
+ if Is_Unbounded_Type (El_Tinfo) then
+ Val := New_Offsetof (Info.B.Bounds_Type,
+ Field_Info.Field_Bound,
+ Ghdl_Index_Type);
+ else
+ Val := Ghdl_Index_0;
+ end if;
+ New_Record_Aggr_El (Aggr, Val);
+
Finish_Record_Aggr (Aggr, Val);
Finish_Init_Value (El_Const, Val);
Add_Rti_Node (El_Const);
@@ -1690,25 +1691,33 @@ package body Trans.Rtis is
Aggr : O_Record_Aggr_List;
Name : O_Dnode;
Rtik : O_Cnode;
+ Depth : Rti_Depth_Type;
+ Layout_Loc : O_Cnode;
begin
Name := Generate_Type_Name (Atype);
Start_Init_Value (Info.Type_Rti);
Start_Record_Aggr (Aggr, Ghdl_Rtin_Type_Record);
+ Depth := 0;
+ Layout_Loc := Null_Loc;
if Get_Constraint_State (Atype) = Fully_Constrained then
Rtik := Ghdl_Rtik_Type_Record;
+ if Info.S.Composite_Layout /= Null_Var then
+ Depth := Get_Depth_From_Var (Info.S.Composite_Layout);
+ Layout_Loc := Var_Acc_To_Loc (Info.S.Composite_Layout);
+ end if;
else
Rtik := Ghdl_Rtik_Type_Unbounded_Record;
end if;
New_Record_Aggr_El
- (Aggr,
- Generate_Common_Type (Rtik, 0, Max_Depth, Type_To_Mode (Atype)));
+ (Aggr, Generate_Common_Type
+ (Rtik, Depth, Max_Depth, Type_To_Mode (Atype)));
New_Record_Aggr_El (Aggr, New_Name_Address (Name));
New_Record_Aggr_El
- (Aggr, New_Unsigned_Literal
- (Ghdl_Index_Type, Unsigned_64 (Get_Nbr_Elements (El_List))));
- New_Record_Aggr_El (Aggr,
- New_Global_Address (El_Arr, Ghdl_Rti_Arr_Acc));
+ (Aggr, New_Index_Lit (Unsigned_64 (Get_Nbr_Elements (El_List))));
+ New_Record_Aggr_El (Aggr, New_Global_Address (New_Global (El_Arr),
+ Ghdl_Rti_Arr_Acc));
+ New_Record_Aggr_El (Aggr, Layout_Loc);
Finish_Record_Aggr (Aggr, Res);
Finish_Init_Value (Info.Type_Rti, Res);
end;
@@ -1993,12 +2002,7 @@ package body Trans.Rtis is
end case;
New_Record_Aggr_El (List, Generate_Common (Comm, Var, Mode));
New_Record_Aggr_El (List, New_Name_Address (Name));
- if Var = Null_Var then
- Val := Get_Null_Loc;
- else
- Val := Var_Acc_To_Loc (Var);
- end if;
- New_Record_Aggr_El (List, Val);
+ New_Record_Aggr_El (List, Var_Acc_To_Loc_Maybe (Var));
Val := New_Rti_Address (Type_Info.Type_Rti);
New_Record_Aggr_El (List, Val);
New_Record_Aggr_El (List, Generate_Linecol (Decl));
@@ -2091,13 +2095,10 @@ package body Trans.Rtis is
Start_Init_Value (Info.Comp_Rti_Const);
Start_Record_Aggr (List, Ghdl_Rtin_Component);
New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Component));
- New_Record_Aggr_El (List,
- New_Global_Address (Name, Char_Ptr_Type));
- New_Record_Aggr_El
- (List, New_Unsigned_Literal (Ghdl_Index_Type,
- Get_Rti_Array_Length));
- New_Record_Aggr_El (List,
- New_Global_Address (Arr, Ghdl_Rti_Arr_Acc));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
+ New_Record_Aggr_El (List, New_Index_Lit (Get_Rti_Array_Length));
+ New_Record_Aggr_El (List, New_Global_Address (New_Global (Arr),
+ Ghdl_Rti_Arr_Acc));
Finish_Record_Aggr (List, Res);
Finish_Init_Value (Info.Comp_Rti_Const, Res);
Pop_Rti_Node (Prev);
@@ -2201,7 +2202,7 @@ package body Trans.Rtis is
Start_Init_Value (Info.Block_Rti_Const);
Start_Record_Aggr (List, Ghdl_Rtin_Instance);
New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Instance));
- New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
New_Record_Aggr_El (List, Generate_Linecol (Stmt));
New_Record_Aggr_El
(List, New_Offsetof (Get_Scope_Type
@@ -2495,7 +2496,7 @@ package body Trans.Rtis is
Start_Record_Aggr (List, Ghdl_Rtin_Block);
New_Record_Aggr_El (List, Generate_Common (Rtik));
- New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
-- Field Loc: offset in the instance of the entity.
Field_Off := New_Offsetof
@@ -2511,7 +2512,8 @@ package body Trans.Rtis is
-- Fields Nbr_Child and Children.
New_Record_Aggr_El
(List, New_Unsigned_Literal (Ghdl_Index_Type, Get_Rti_Array_Length));
- New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc));
+ New_Record_Aggr_El (List, New_Global_Address (New_Global (Arr),
+ Ghdl_Rti_Arr_Acc));
Finish_Record_Aggr (List, Res);
Finish_Init_Value (Rti, Res);
@@ -2557,7 +2559,7 @@ package body Trans.Rtis is
Start_Record_Aggr (List, Ghdl_Rtin_Generate);
New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_For_Generate));
- New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
-- Field Loc: offset in the instance of the entity.
Field_Off := New_Offsetof
@@ -2578,7 +2580,7 @@ package body Trans.Rtis is
Ghdl_Index_Type));
-- Child.
- New_Record_Aggr_El (List, Get_Context_Rti (Bod));
+ New_Record_Aggr_El (List, New_Rti_Address (Get_Context_Rti (Bod)));
Finish_Record_Aggr (List, Res);
@@ -2716,17 +2718,17 @@ package body Trans.Rtis is
Start_Record_Aggr (List, Ghdl_Rtin_Block);
New_Record_Aggr_El (List, Generate_Common (Kind));
- New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type));
+ New_Record_Aggr_El (List, New_Name_Address (Name));
-- Field Loc: offset in the instance of the entity.
if Field_Off = O_Cnode_Null then
- Field_Off := Get_Null_Loc;
+ Field_Off := Null_Loc;
end if;
New_Record_Aggr_El (List, Field_Off);
New_Record_Aggr_El (List, Generate_Linecol (Blk));
- -- Field Parent: RTI of the parent.
+ -- Field Parent: RTI of the parent.
if Parent_Rti = O_Dnode_Null then
Res := New_Null_Access (Ghdl_Rti_Access);
else
@@ -2736,14 +2738,14 @@ package body Trans.Rtis is
-- Fields Nbr_Child and Children.
New_Record_Aggr_El (List, New_Index_Lit (Get_Rti_Array_Length));
- New_Record_Aggr_El (List, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc));
+ New_Record_Aggr_El (List, New_Global_Address (New_Global (Arr),
+ Ghdl_Rti_Arr_Acc));
Finish_Record_Aggr (List, Res);
if Rti_Type = Ghdl_Rtin_Block_File then
New_Record_Aggr_El (List_File, Res);
New_Record_Aggr_El (List_File,
- New_Global_Address (Current_Filename_Node,
- Char_Ptr_Type));
+ New_Name_Address (Current_Filename_Node));
Finish_Record_Aggr (List_File, Res);
end if;
@@ -2945,43 +2947,46 @@ package body Trans.Rtis is
Pop_Rti_Node (Prev);
end Generate_Top;
- function Get_Context_Rti (Node : Iir) return O_Cnode
+ function Get_Context_Rti (Node : Iir) return O_Dnode
is
Node_Info : constant Ortho_Info_Acc := Get_Info (Node);
- Rti_Const : O_Dnode;
begin
case Get_Kind (Node) is
when Iir_Kind_Component_Declaration =>
- Rti_Const := Node_Info.Comp_Rti_Const;
+ return Node_Info.Comp_Rti_Const;
when Iir_Kind_Component_Instantiation_Statement =>
- Rti_Const := Node_Info.Block_Rti_Const;
+ return Node_Info.Block_Rti_Const;
when Iir_Kind_Entity_Declaration
| Iir_Kind_Architecture_Body
| Iir_Kind_Block_Statement
| Iir_Kind_Generate_Statement_Body =>
- Rti_Const := Node_Info.Block_Rti_Const;
+ return Node_Info.Block_Rti_Const;
when Iir_Kind_If_Generate_Statement
| Iir_Kind_For_Generate_Statement =>
declare
Bod : constant Iir := Get_Generate_Statement_Body (Node);
Bod_Info : constant Block_Info_Acc := Get_Info (Bod);
begin
- Rti_Const := Bod_Info.Block_Rti_Const;
+ return Bod_Info.Block_Rti_Const;
end;
when Iir_Kind_Package_Declaration
| Iir_Kind_Package_Body =>
- Rti_Const := Node_Info.Package_Rti_Const;
+ return Node_Info.Package_Rti_Const;
when Iir_Kind_Process_Statement
| Iir_Kind_Sensitized_Process_Statement =>
- Rti_Const := Node_Info.Process_Rti_Const;
+ return Node_Info.Process_Rti_Const;
when Iir_Kind_Psl_Assert_Statement
| Iir_Kind_Psl_Cover_Statement
| Iir_Kind_Psl_Endpoint_Declaration =>
- Rti_Const := Node_Info.Psl_Rti_Const;
+ return Node_Info.Psl_Rti_Const;
when others =>
Error_Kind ("get_context_rti", Node);
end case;
- return New_Rti_Address (Rti_Const);
+ end Get_Context_Rti;
+
+ function Get_Context_Rti (Node : Iir) return O_Enode is
+ begin
+ return New_Rti_Address (Get_Context_Rti (Node));
end Get_Context_Rti;
function Get_Context_Addr (Node : Iir) return O_Enode
@@ -3024,7 +3029,7 @@ package body Trans.Rtis is
procedure Associate_Rti_Context (Assoc : in out O_Assoc_List; Node : Iir)
is
begin
- New_Association (Assoc, New_Lit (Get_Context_Rti (Node)));
+ New_Association (Assoc, Get_Context_Rti (Node));
New_Association (Assoc, Get_Context_Addr (Node));
end Associate_Rti_Context;
diff --git a/src/vhdl/translate/trans-rtis.ads b/src/vhdl/translate/trans-rtis.ads
index 73bc514e0..e3c8c188e 100644
--- a/src/vhdl/translate/trans-rtis.ads
+++ b/src/vhdl/translate/trans-rtis.ads
@@ -114,7 +114,7 @@ package Trans.Rtis is
procedure Rti_Initialize;
-- Get address (as Ghdl_Rti_Access) of constant RTI.
- function New_Rti_Address (Rti : O_Dnode) return O_Cnode;
+ function New_Rti_Address (Rti : O_Dnode) return O_Enode;
-- Generate rtis for a library unit.
procedure Generate_Unit (Lib_Unit : Iir);
@@ -139,6 +139,6 @@ package Trans.Rtis is
(Assoc : in out O_Assoc_List; Node : Iir);
procedure Associate_Null_Rti_Context (Assoc : in out O_Assoc_List);
- function Get_Context_Rti (Node : Iir) return O_Cnode;
+ function Get_Context_Rti (Node : Iir) return O_Enode;
function Get_Context_Addr (Node : Iir) return O_Enode;
end Trans.Rtis;
diff --git a/src/vhdl/translate/trans.adb b/src/vhdl/translate/trans.adb
index a2385cbe6..4d6a0a44a 100644
--- a/src/vhdl/translate/trans.adb
+++ b/src/vhdl/translate/trans.adb
@@ -1133,6 +1133,24 @@ package body Trans is
end Instantiate_Var_Scope;
end Chap10;
+ function Align_Val (Algn : Alignment_Type) return O_Cnode is
+ begin
+ case Algn is
+ when Align_Undef =>
+ raise Internal_Error;
+ when Align_8 =>
+ return Ghdl_Index_1;
+ when Align_16 =>
+ return Ghdl_Index_2;
+ when Align_32 =>
+ return Ghdl_Index_4;
+ when Align_Ptr =>
+ return Ghdl_Index_Ptr_Align;
+ when Align_64 =>
+ return Ghdl_Index_8;
+ end case;
+ end Align_Val;
+
function Get_Object_Kind (M : Mnode) return Object_Kind_Type is
begin
return M.M1.K;
@@ -1401,9 +1419,6 @@ package body Trans is
procedure Free_Type_Info (Info : in out Type_Info_Acc) is
begin
- if Info.C /= null then
- Free_Complex_Type_Info (Info.C);
- end if;
Unchecked_Deallocation (Info);
end Free_Type_Info;
@@ -1433,7 +1448,26 @@ package body Trans is
function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is
begin
- return Tinfo.C /= null;
+ case Tinfo.Type_Mode is
+ when Type_Mode_Non_Composite =>
+ return False;
+ when Type_Mode_Static_Record
+ | Type_Mode_Static_Array =>
+ return False;
+ when Type_Mode_Complex_Record
+ | Type_Mode_Complex_Array =>
+ return True;
+ when Type_Mode_Unbounded_Record
+ | Type_Mode_Unbounded_Array =>
+ return False;
+ when Type_Mode_Protected =>
+ -- Considered as a complex type, as its size is known only in
+ -- the body.
+ -- Shouldn't be used.
+ raise Internal_Error;
+ when Type_Mode_Unknown =>
+ return False;
+ end case;
end Is_Complex_Type;
function Is_Static_Type (Tinfo : Type_Info_Acc) return Boolean is
@@ -1480,13 +1514,6 @@ package body Trans is
Clear_Info (I);
else
Info.Mark := True;
- if Info.Kind = Kind_Type and then Info.C /= null then
- if Info.C (Mode_Value).Mark then
- Info.C := null;
- else
- Info.C (Mode_Value).Mark := True;
- end if;
- end if;
end if;
end if;
end loop;
diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads
index 8b6888764..960323ee8 100644
--- a/src/vhdl/translate/trans.ads
+++ b/src/vhdl/translate/trans.ads
@@ -68,6 +68,10 @@ package Trans is
Ghdl_Index_Type : O_Tnode;
Ghdl_Index_0 : O_Cnode;
Ghdl_Index_1 : O_Cnode;
+ Ghdl_Index_2 : O_Cnode;
+ Ghdl_Index_4 : O_Cnode;
+ Ghdl_Index_8 : O_Cnode;
+ Ghdl_Index_Ptr_Align : O_Cnode; -- Alignment of a pointer
-- Type for a file (this is in fact a index in a private table).
Ghdl_File_Index_Type : O_Tnode;
@@ -105,6 +109,9 @@ package Trans is
Ghdl_Sizes_Val : O_Fnode;
Ghdl_Sizes_Sig : O_Fnode;
+ -- Access to size.
+ Ghdl_Sizes_Ptr : O_Tnode;
+
-- Comparaison type.
Ghdl_Compare_Type : O_Tnode;
Ghdl_Compare_Lt : O_Cnode;
@@ -750,6 +757,58 @@ package Trans is
type Rti_Depth_Type is new Natural range 0 .. 255;
+ -- Additional info for complex types.
+ type Complex_Type_Info is record
+ -- Parameters for type builders.
+ -- NOTE: this is only set for types (and *not* for subtypes).
+ Builder_Instance : Subprgs.Subprg_Instance_Type;
+ Builder_Layout_Param : O_Dnode;
+ Builder_Proc : O_Dnode := O_Dnode_Null;
+ end record;
+ type Complex_Type_Arr_Info is array (Object_Kind_Type) of Complex_Type_Info;
+
+ -- Alignment of a type.
+ -- This is only for Mode_Value (for Mode_Signal, the alignment is
+ -- Align_Ptr).
+ -- The size of complex types is determined at run-time, and the code to
+ -- compute it is generated by translation. But to know the size, the
+ -- alignment must also be known. It is assumed that allocators (malloc or
+ -- alloca) always return a pointer with the maximum alignment.
+ -- Eg: type cpl_rec is record
+ -- b : boolean;
+ -- v : integer_array (1 to n); -- n is a non-locally constant.
+ -- end record;
+ -- The static part contains only field 'b'. The whole size is of cpl_rec
+ -- is: sizeof (b) + align(v) + n * sizeof(integer) + align(cpl_rec).
+ -- This makes a lot of suppositions about the ABI:
+ -- * elementary types (including doubles) are always naturally aligned
+ -- * fields are aligned as their type
+ -- * records are aligned to their maximum field
+ -- * pointers have the same size
+ -- * finally, pointers are either 32 or 64 bits.
+ -- Note: deviation from the ABI may result in incorrect code as an object
+ -- that is statically constrained may be viewed as a complex/unbounded
+ -- object too.
+ -- Note: These suppositions are true on x86-64, on windows32.
+ -- but not for double on linux-x86!!
+ type Alignment_Type is
+ (
+ -- When alignment is not known.
+ Align_Undef,
+
+ -- For enumerations, integers, physical types.
+ Align_8, Align_16, Align_32,
+
+ -- For an access. We suppose that pointers are either 32 or 64 bits.
+ -- So Align_Ptr >= Align_32 but Align_64 >= Align_Ptr
+ Align_Ptr,
+
+ -- For float64 (floating point types), large integers or large physical
+ -- types.
+ Align_64);
+
+ function Align_Val (Algn : Alignment_Type) return O_Cnode;
+
type Ortho_Info_Basetype_Type
(Kind : Ortho_Info_Type_Kind := Kind_Type_Scalar) is record
-- For all types:
@@ -757,6 +816,8 @@ package Trans is
-- the type itself and every types it depends on.
Rti_Max_Depth : Rti_Depth_Type;
+ Align : Alignment_Type;
+
case Kind is
when Kind_Type_Scalar =>
-- For scalar types:
@@ -779,19 +840,38 @@ package Trans is
Base_Type : O_Tnode_Array;
Base_Ptr_Type : O_Tnode_Array;
-- The dope vector.
+ -- For arrays:
+ -- range of indexes
+ -- layout of element (if element is unbounded)
+ -- For record:
+ -- offsets of complex elements
+ -- layout of unbounded elements
Bounds_Type : O_Tnode;
Bounds_Ptr_Type : O_Tnode;
- -- Only for unbounded arrays: element size and bounds in
- -- the bounds record
- El_Size : O_Fnode;
- El_Bounds : O_Fnode;
+ -- For arrays with unbounded element, the layout field of the
+ -- bounds type.
+ Bounds_El : O_Fnode;
+
+ -- Size + bounds.
+ -- Always created for arrays, created for unbounded and complex
+ -- records.
+ Layout_Type : O_Tnode;
+ Layout_Ptr_Type : O_Tnode;
+
+ -- Size and bounds fields of the layout type.
+ Layout_Size : O_Fnode;
+ Layout_Bounds : O_Fnode;
-- The ortho type is a fat pointer to the base and the bounds.
-- These are the fields of the fat pointer.
Base_Field : O_Fnode_Array;
Bounds_Field : O_Fnode_Array;
+ -- Parameters for type builders.
+ -- NOTE: this is only set for types (and *not* for subtypes).
+ Builder : Complex_Type_Arr_Info;
+
when Kind_Type_File =>
-- Constant containing the signature of the file.
File_Signature : O_Dnode;
@@ -832,11 +912,8 @@ package Trans is
when Kind_Type_Array
| Kind_Type_Record =>
- -- True if the bounds are static.
- Static_Bounds : Boolean;
-
- -- Variable containing the bounds for a constrained type.
- Composite_Bounds : Var_Type;
+ -- Variable containing the layout for a constrained type.
+ Composite_Layout : Var_Type;
-- For a locally constrained record subtype whose base type has
-- unbounded elements: the field containing the base record.
@@ -863,47 +940,61 @@ package Trans is
Ortho_Info_Basetype_Array_Init : constant Ortho_Info_Basetype_Type :=
(Kind => Kind_Type_Array,
Rti_Max_Depth => 0,
+ Align => Align_Undef,
Base_Type => (O_Tnode_Null, O_Tnode_Null),
Base_Ptr_Type => (O_Tnode_Null, O_Tnode_Null),
Bounds_Type => O_Tnode_Null,
Bounds_Ptr_Type => O_Tnode_Null,
- El_Size => O_Fnode_Null,
- El_Bounds => O_Fnode_Null,
+ Bounds_El => O_Fnode_Null,
+ Layout_Type => O_Tnode_Null,
+ Layout_Ptr_Type => O_Tnode_Null,
+ Layout_Size => O_Fnode_Null,
+ Layout_Bounds => O_Fnode_Null,
Base_Field => (O_Fnode_Null, O_Fnode_Null),
- Bounds_Field => (O_Fnode_Null, O_Fnode_Null));
+ Bounds_Field => (O_Fnode_Null, O_Fnode_Null),
+ Builder => (others => (Builder_Instance => Subprgs.Null_Subprg_Instance,
+ Builder_Layout_Param => O_Dnode_Null,
+ Builder_Proc => O_Dnode_Null)));
Ortho_Info_Subtype_Array_Init : constant Ortho_Info_Subtype_Type :=
(Kind => Kind_Type_Array,
- Static_Bounds => False,
- Composite_Bounds => Null_Var,
+ Composite_Layout => Null_Var,
Box_Field => (O_Fnode_Null, O_Fnode_Null));
Ortho_Info_Basetype_Record_Init : constant Ortho_Info_Basetype_Type :=
(Kind => Kind_Type_Record,
Rti_Max_Depth => 0,
+ Align => Align_Undef,
Base_Type => (O_Tnode_Null, O_Tnode_Null),
Base_Ptr_Type => (O_Tnode_Null, O_Tnode_Null),
Bounds_Type => O_Tnode_Null,
Bounds_Ptr_Type => O_Tnode_Null,
- El_Size => O_Fnode_Null,
- El_Bounds => O_Fnode_Null,
+ Bounds_El => O_Fnode_Null,
+ Layout_Type => O_Tnode_Null,
+ Layout_Ptr_Type => O_Tnode_Null,
+ Layout_Size => O_Fnode_Null,
+ Layout_Bounds => O_Fnode_Null,
Base_Field => (O_Fnode_Null, O_Fnode_Null),
- Bounds_Field => (O_Fnode_Null, O_Fnode_Null));
+ Bounds_Field => (O_Fnode_Null, O_Fnode_Null),
+ Builder => (others => (Builder_Instance => Subprgs.Null_Subprg_Instance,
+ Builder_Layout_Param => O_Dnode_Null,
+ Builder_Proc => O_Dnode_Null)));
Ortho_Info_Subtype_Record_Init : constant Ortho_Info_Subtype_Type :=
(Kind => Kind_Type_Record,
- Static_Bounds => False,
- Composite_Bounds => Null_Var,
+ Composite_Layout => Null_Var,
Box_Field => (O_Fnode_Null, O_Fnode_Null));
Ortho_Info_Basetype_File_Init : constant Ortho_Info_Basetype_Type :=
(Kind => Kind_Type_File,
Rti_Max_Depth => 0,
+ Align => Align_Undef,
File_Signature => O_Dnode_Null);
Ortho_Info_Basetype_Prot_Init : constant Ortho_Info_Basetype_Type :=
(Kind => Kind_Type_Protected,
Rti_Max_Depth => 0,
+ Align => Align_Undef,
Prot_Scope => Null_Var_Scope,
Prot_Prev_Scope => null,
Prot_Init_Subprg => O_Dnode_Null,
@@ -1071,6 +1162,88 @@ package Trans is
-- that doesn't suspend is not decomposed by this mechanism).
type State_Type is new Nat32;
+ -- Translation of types.
+ -- (Where you understand that VHDL is more complex than C...)
+ --
+ -- 1) For scalar types (integers, physical types, enumeration, floating
+ -- point types) and pointers, the type is fully known during analysis
+ -- and translation:
+ -- a) for integers and physical types, the size is defined by the range.
+ -- GHDL uses either 32-bit or 64-bit types.
+ -- b) for enumeration, the size is defined by the number of literals.
+ -- GHDL uses either 8-bit or 32-bit types.
+ -- c) for floating-point type, GHDL always uses 64-bit types (Float64).
+ -- d) for access types, GHDL uses pointers. This is slightly more
+ -- complex as sometimes it can be a fat pointer, which is a record
+ -- of two pointers. But in all cases, the size is known.
+ --
+ -- For composite subtypes (arrays and records), there are several cases:
+ --
+ -- 2) Composite types whose sub-elements are statically constrained.
+ -- Eg: subtype byte is bit_vector (7 downto 0);
+ -- Eg: subtype word is std_logic_vector (31 downto 0);
+ -- Eg: type my_bus is record
+ -- req: bit;
+ -- ack: bit;
+ -- data: byte;
+ -- end record;
+ -- This still corresponds to C: sizes and offsets are known during
+ -- translation.
+ -- However, for arrays a bound variable is created. This variable
+ -- contains the bounds of the array (left, right and direction) and the
+ -- length of each bound. This is used both for 'introspection' and for
+ -- conversion to fat pointers.
+ --
+ -- 3) Unbounded types. This is quite usual for parameters.
+ -- Eg: procedure disp_hex (v : std_logic_vector);
+ -- The bounds of an unbounded types are only known during execution, and
+ -- thus must be passed with the argument.
+ -- This is not the same case as an object declared with an unbounded
+ -- type; in that case the bounds are computed during elaboration (or
+ -- dynamic elaboration).
+ -- Eg: constant c : std_logic_vector := xxx;
+ --
+ -- For these unbounded types, the interface is translated as a fat
+ -- pointer, which is a structure containing a base pointer and a bound
+ -- pointer. The base pointer points to the data while the bound pointer
+ -- points to the bounds.
+ --
+ -- In some case, we need to convert from a bounded representation to an
+ -- unbounded representation. This happens while calling a subprogram
+ -- with a bounded object (and corresponds to a subtype conversion in
+ -- VHDL terms). In that case a fat pointer is created, using the object
+ -- as data and the bounds variable as the bounds. The opposite
+ -- conversion can also happen and we just need to check that the bounds
+ -- are matching and to keep only the data part.
+ --
+ -- 4) Complex types. Complex is a word used only by GHDL (not defined by
+ -- VHDL). You need to realize that VHDL types are more powerful than C
+ -- types as you can declare a type whose size is not known by the
+ -- compiler.
+ -- Eg: constant length : natural := call_to_a_complex_function(5);
+ -- subtype my_word is std_logic_vector (1 to length);
+ -- type my_bus is record
+ -- d : my_word;
+ -- req : std_logic_vector;
+ -- end record;
+ -- Clearly, LENGTH is not known during analysis. In many cases it
+ -- could be known during elaboration but this is not enough as such a
+ -- construct could also be used within subprograms using a parameter to
+ -- define a bound.
+ --
+ -- Because the size of these objects is not known during compilation,
+ -- the objects are allocated dynamically (either on the heap or on the
+ -- stack) during (dynamic) elaboration. They also comes with a bound
+ -- variable.
+ --
+ -- For arrays, the bound variable describes the index of the array and
+ -- the bounds of the elements (if the element is unbounded).
+ --
+ -- For records, the bound variable describes the offset and the bounds
+ -- of the non-static elements.
+ --
+
+ -- OLD:
-- Complex types.
--
-- A complex type is not a VHDL notion, but a translation notion.
@@ -1166,30 +1339,6 @@ package Trans is
-- | ... |
-- +--------------+
- -- Additional info for complex types.
- type Complex_Type_Info is record
- -- For a simple memory management: use mark and sweep to free all infos.
- Mark : Boolean := False;
-
- Builder_Need_Func : Boolean := False;
-
- -- Variable containing the size of the type.
- -- This is defined only for types whose size is only known at
- -- running time (and not a compile-time).
- Size_Var : Var_Type := Null_Var;
-
- -- Parameters for type builders.
- -- NOTE: this is only set for types (and *not* for subtypes).
- Builder_Instance : Subprgs.Subprg_Instance_Type;
- Builder_Base_Param : O_Dnode;
- Builder_Bound_Param : O_Dnode;
- Builder_Func : O_Dnode := O_Dnode_Null;
- end record;
- type Complex_Type_Arr_Info is array (Object_Kind_Type) of Complex_Type_Info;
- type Complex_Type_Info_Acc is access Complex_Type_Arr_Info;
- procedure Free_Complex_Type_Info is new Ada.Unchecked_Deallocation
- (Complex_Type_Arr_Info, Complex_Type_Info_Acc);
-
type Assoc_Conv_Info is record
-- The subprogram created to do the conversion.
Subprg : O_Dnode;
@@ -1238,9 +1387,6 @@ package Trans is
-- of its sub-element (ie being a complex type).
Type_Locally_Constrained : Boolean := False;
- -- Additionnal info for complex types.
- C : Complex_Type_Info_Acc := null;
-
-- Ortho node which represents the type.
-- Type -> Ortho type
-- scalar -> scalar
@@ -1275,10 +1421,13 @@ package Trans is
Index_Field : O_Fnode;
when Kind_Field =>
- -- Node for a record element declaration.
+ -- For element whose type is static: field in the record.
+ -- For element whose type is not static: offset field in the
+ -- bounds.
Field_Node : O_Fnode_Array := (O_Fnode_Null, O_Fnode_Null);
- -- The field in the dope vector (for unbounded element).
+ -- The field in the layout record for the layout of the
+ -- element (for unbounded element).
Field_Bound : O_Fnode := O_Fnode_Null;
when Kind_Expr =>
@@ -1709,9 +1858,8 @@ package Trans is
function Is_Composite (Info : Type_Info_Acc) return Boolean;
pragma Inline (Is_Composite);
- -- Type needs to be built.
+ -- Type is bounded but layout and size are known only during elaboration.
function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean;
- pragma Inline (Is_Complex_Type);
-- Type size is known at compile-time.
function Is_Static_Type (Tinfo : Type_Info_Acc) return Boolean;
diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb
index a7ec6e7da..68dd9a300 100644
--- a/src/vhdl/translate/translation.adb
+++ b/src/vhdl/translate/translation.adb
@@ -33,6 +33,7 @@ with Trans;
with Trans_Decls; use Trans_Decls;
with Trans.Chap1;
with Trans.Chap2;
+with Trans.Chap3;
with Trans.Chap4;
with Trans.Chap7;
with Trans.Chap12;
@@ -423,6 +424,9 @@ package body Translation is
Ghdl_Index_0 := New_Unsigned_Literal (Ghdl_Index_Type, 0);
Ghdl_Index_1 := New_Unsigned_Literal (Ghdl_Index_Type, 1);
+ Ghdl_Index_2 := New_Unsigned_Literal (Ghdl_Index_Type, 2);
+ Ghdl_Index_4 := New_Unsigned_Literal (Ghdl_Index_Type, 4);
+ Ghdl_Index_8 := New_Unsigned_Literal (Ghdl_Index_Type, 8);
Ghdl_I32_Type := New_Signed_Type (32);
New_Type_Decl (Get_Identifier ("__ghdl_i32"), Ghdl_I32_Type);
@@ -453,6 +457,8 @@ package body Translation is
Char_Ptr_Type := New_Access_Type (Chararray_Type);
New_Type_Decl (Get_Identifier ("__ghdl_char_ptr"), Char_Ptr_Type);
+ Ghdl_Index_Ptr_Align := New_Alignof (Char_Ptr_Type, Ghdl_Index_Type);
+
Char_Ptr_Array_Type := New_Array_Type (Char_Ptr_Type, Ghdl_Index_Type);
New_Type_Decl (Get_Identifier ("__ghdl_char_ptr_array"),
Char_Ptr_Array_Type);
@@ -531,6 +537,10 @@ package body Translation is
Ghdl_Sizes_Type);
end;
+ -- __ghdl_sizes_ptr is access __ghdl_sizes_type;
+ Ghdl_Sizes_Ptr := New_Access_Type (Ghdl_Sizes_Type);
+ New_Type_Decl (Get_Identifier ("__ghdl_sizes_ptr"), Ghdl_Sizes_Ptr);
+
-- Create type ghdl_compare_type is (lt, eq, ge);
declare
Constr : O_Enum_List;
@@ -1906,12 +1916,22 @@ package body Translation is
end Post_Initialize;
- procedure Translate_Type_Implicit_Subprograms (Decl : in out Iir)
+ procedure Translate_Type_Implicit_Subprograms
+ (Decl : in out Iir; Main : Boolean)
is
Infos : Chap7.Implicit_Subprogram_Infos;
+ Subprg_Kind : Subprg_Translate_Kind;
begin
- -- Skip type declaration.
pragma Assert (Get_Kind (Decl) in Iir_Kinds_Type_Declaration);
+
+ if Main then
+ Subprg_Kind := Subprg_Translate_Spec_And_Body;
+ else
+ Subprg_Kind := Subprg_Translate_Only_Spec;
+ end if;
+ Chap3.Translate_Type_Subprograms (Decl, Subprg_Kind);
+
+ -- Skip type declaration.
Decl := Get_Chain (Decl);
-- Implicit subprograms are immediately follow the type declaration.
@@ -1988,22 +2008,22 @@ package body Translation is
New_Array_Type (Std_Boolean_Type_Node, Ghdl_Index_Type);
New_Type_Decl (Create_Identifier ("BOOLEAN_ARRAY"),
Std_Boolean_Array_Type);
- Translate_Type_Implicit_Subprograms (Decl);
+ Translate_Type_Implicit_Subprograms (Decl, Main);
-- Second declaration: bit.
pragma Assert (Decl = Bit_Type_Declaration);
Chap4.Translate_Bool_Type_Declaration (Bit_Type_Declaration);
- Translate_Type_Implicit_Subprograms (Decl);
+ Translate_Type_Implicit_Subprograms (Decl, Main);
-- Nothing special for other declarations.
while Decl /= Null_Iir loop
case Get_Kind (Decl) is
when Iir_Kind_Type_Declaration =>
Chap4.Translate_Type_Declaration (Decl);
- Translate_Type_Implicit_Subprograms (Decl);
+ Translate_Type_Implicit_Subprograms (Decl, Main);
when Iir_Kind_Anonymous_Type_Declaration =>
Chap4.Translate_Anonymous_Type_Declaration (Decl);
- Translate_Type_Implicit_Subprograms (Decl);
+ Translate_Type_Implicit_Subprograms (Decl, Main);
when Iir_Kind_Subtype_Declaration =>
Chap4.Translate_Subtype_Declaration (Decl);
Decl := Get_Chain (Decl);
@@ -2078,8 +2098,7 @@ package body Translation is
--Pop_Global_Factory;
end Translate_Standard;
- procedure Finalize
- is
+ procedure Finalize is
begin
Free_Node_Infos;
Free_Old_Temp;