From 04cd83fb46bee1e7a7b37be95bee73449af9c8b8 Mon Sep 17 00:00:00 2001
From: Tristan Gingold <tgingold@free.fr>
Date: Fri, 24 Jul 2020 18:31:11 +0200
Subject: ortho: add unbounded records, rework array subtypes.
---
src/ortho/debug/ortho_debug-disp.adb | 57 ++++--
src/ortho/debug/ortho_debug.adb | 338 +++++++++++++++++++++----------
src/ortho/debug/ortho_debug.private.ads | 49 ++++-
src/ortho/gcc/ortho-lang-49.c | 53 ++++-
src/ortho/gcc/ortho-lang-5.c | 53 ++++-
src/ortho/gcc/ortho-lang-6.c | 53 ++++-
src/ortho/gcc/ortho-lang-7.c | 53 ++++-
src/ortho/gcc/ortho-lang-8.c | 53 ++++-
src/ortho/gcc/ortho-lang-9.c | 53 ++++-
src/ortho/gcc/ortho_gcc.ads | 41 +++-
src/ortho/gcc/ortho_gcc.private.ads | 16 +-
src/ortho/llvm6/llvm-cbindings.cpp | 88 ++++++--
src/ortho/llvm6/ortho_llvm.ads | 40 +++-
src/ortho/llvm6/ortho_llvm.private.ads | 15 +-
src/ortho/mcode/ortho_code-consts.adb | 43 ++--
src/ortho/mcode/ortho_code-consts.ads | 4 +-
src/ortho/mcode/ortho_code-disps.adb | 10 +
src/ortho/mcode/ortho_code-dwarf.adb | 50 +++--
src/ortho/mcode/ortho_code-exprs.adb | 19 +-
src/ortho/mcode/ortho_code-types.adb | 257 +++++++++++++++++------
src/ortho/mcode/ortho_code-types.ads | 54 +++--
src/ortho/mcode/ortho_code-x86-emits.adb | 13 +-
src/ortho/mcode/ortho_mcode.adb | 44 +++-
src/ortho/mcode/ortho_mcode.ads | 40 ++--
src/ortho/mcode/ortho_mcode.private.ads | 15 +-
src/ortho/oread/ortho_front.adb | 241 ++++++++++++++++------
src/ortho/ortho_nodes.common.ads | 25 ++-
src/vhdl/translate/trans-chap12.adb | 5 +-
src/vhdl/translate/trans-chap3.adb | 5 +-
src/vhdl/translate/trans-chap7.adb | 9 +-
src/vhdl/translate/trans-chap8.adb | 36 +++-
src/vhdl/translate/trans-chap9.adb | 6 +-
src/vhdl/translate/trans-helpers2.adb | 12 +-
src/vhdl/translate/trans-rtis.adb | 36 ++--
src/vhdl/translate/translation.adb | 10 +-
35 files changed, 1455 insertions(+), 441 deletions(-)
diff --git a/src/ortho/debug/ortho_debug-disp.adb b/src/ortho/debug/ortho_debug-disp.adb
index a7bbbe907..fd18f1260 100644
--- a/src/ortho/debug/ortho_debug-disp.adb
+++ b/src/ortho/debug/ortho_debug-disp.adb
@@ -572,6 +572,11 @@ package body Ortho_Debug.Disp is
Put ("'sizeof (");
Disp_Tnode_Name (C.S_Type);
Put (")");
+ when OC_Record_Sizeof_Lit =>
+ Disp_Tnode_Name (C.Ctype);
+ Put ("'record_sizeof (");
+ Disp_Tnode_Name (C.S_Type);
+ Put (")");
when OC_Alignof_Lit =>
Disp_Tnode_Name (C.Ctype);
Put ("'alignof (");
@@ -590,14 +595,7 @@ package body Ortho_Debug.Disp is
El_Type : O_Tnode;
begin
El := C.Arr_Els;
- case C.Ctype.Kind is
- when ON_Array_Sub_Type =>
- El_Type := C.Ctype.Base_Type.El_Type;
- when ON_Array_Type =>
- El_Type := C.Ctype.El_Type;
- when others =>
- raise Program_Error;
- end case;
+ El_Type := Get_Array_El_Type (C.Ctype);
Put ('[');
Put_Trim (Unsigned_32'Image (C.Arr_Len));
Put (']');
@@ -622,7 +620,7 @@ package body Ortho_Debug.Disp is
Put ('{');
El := C.Rec_Els;
pragma Assert (C.Ctype.Kind = ON_Record_Type);
- Field := C.Ctype.Elements;
+ Field := C.Ctype.Rec_Elements;
if El /= null then
loop
Set_Mark;
@@ -898,24 +896,41 @@ package body Ortho_Debug.Disp is
when ON_Record_Type =>
Put_Keyword ("record");
New_Line;
- Disp_Fnodes (Atype.Elements);
+ Disp_Fnodes (Atype.Rec_Elements);
Put_Keyword ("end");
Put (" ");
Put_Keyword ("record");
+ when ON_Record_Subtype =>
+ Put_Keyword ("subrecord");
+ Put (" ");
+ Disp_Tnode_Name (Atype.Subrec_Base);
+ Put ("(");
+ Disp_Fnodes (Atype.Subrec_Elements);
+ Put (")");
when ON_Union_Type =>
Put_Keyword ("union");
New_Line;
- Disp_Fnodes (Atype.Elements);
+ Disp_Fnodes (Atype.Rec_Elements);
Put_Keyword ("end");
Put (" ");
Put_Keyword ("union");
- when ON_Array_Sub_Type =>
- Put_Keyword ("subarray");
- Put (" ");
- Disp_Tnode_Name (Atype.Base_Type);
- Put ("[");
- Disp_Cnode (Atype.Length, Atype.Base_Type.Index_Type);
- Put ("]");
+ when ON_Array_Subtype =>
+ declare
+ Base : constant O_Tnode := Atype.Arr_Base;
+ begin
+ Put_Keyword ("subarray");
+ Put (" ");
+ Disp_Tnode_Name (Base);
+ Put ("[");
+ Disp_Cnode (Atype.Length, Base.Index_Type);
+ Put ("]");
+ if Atype.Arr_El_Type /= Base.El_Type then
+ Put (" ");
+ Put_Keyword ("of");
+ Put (" ");
+ Disp_Tnode (Atype.Arr_El_Type, False);
+ end if;
+ end;
end case;
end Disp_Tnode;
@@ -1222,8 +1237,10 @@ package body Ortho_Debug.Disp is
procedure Disp_Tnode_Decl (N : O_Tnode) is
begin
- Disp_Ident (N.Decl.Name);
- Put (" : ");
+ if N.Decl /= O_Dnode_Null then
+ Disp_Ident (N.Decl.Name);
+ Put (" : ");
+ end if;
Disp_Tnode (N, True);
end Disp_Tnode_Decl;
diff --git a/src/ortho/debug/ortho_debug.adb b/src/ortho/debug/ortho_debug.adb
index bf28022da..3617ebbc8 100644
--- a/src/ortho/debug/ortho_debug.adb
+++ b/src/ortho/debug/ortho_debug.adb
@@ -262,8 +262,11 @@ package body Ortho_Debug is
if T1 = T2 then
return;
end if;
- if T1.Kind = ON_Array_Sub_Type and then T2.Kind = ON_Array_Sub_Type
- and then T1.Base_Type = T2.Base_Type
+ -- TODO: Two different subtypes with the same constraints are allowed.
+ -- Is it needed ?
+ if T1.Kind = ON_Array_Subtype and then T2.Kind = ON_Array_Subtype
+ and then T1.Arr_Base = T2.Arr_Base
+ and then T1.Arr_El_Type = T2.Arr_El_Type
and then T1.Length.all = T2.Length.all
then
return;
@@ -307,6 +310,16 @@ package body Ortho_Debug is
end if;
end Check_Complete_Type;
+ procedure Check_Constrained_Type (T : O_Tnode) is
+ begin
+ if not T.Constrained then
+ -- Unconstrained type cannot be used here (since its size is
+ -- required, for example).
+ null;
+ raise Syntax_Error;
+ end if;
+ end Check_Constrained_Type;
+
function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode)
return O_Enode
is
@@ -426,9 +439,7 @@ package body Ortho_Debug is
Ref => False);
end New_Default_Value;
- function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
- is
- subtype O_Cnode_Sizeof_Type is O_Cnode_Type (OC_Sizeof_Lit);
+ function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
begin
if Rtype.Kind /= ON_Unsigned_Type
and then Rtype.Kind /= ON_Access_Type
@@ -436,14 +447,30 @@ package body Ortho_Debug is
raise Type_Error;
end if;
Check_Complete_Type (Atype);
- if Atype.Kind = ON_Array_Type then
+ Check_Constrained_Type (Atype);
+ return new O_Cnode_Type'(Kind => OC_Sizeof_Lit,
+ Ctype => Rtype,
+ Ref => False,
+ S_Type => Atype);
+ end New_Sizeof;
+
+ function New_Record_Sizeof
+ (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ if Rtype.Kind /= ON_Unsigned_Type
+ and then Rtype.Kind /= ON_Access_Type
+ then
raise Type_Error;
end if;
- return new O_Cnode_Sizeof_Type'(Kind => OC_Sizeof_Lit,
- Ctype => Rtype,
- Ref => False,
- S_Type => Atype);
- end New_Sizeof;
+ Check_Complete_Type (Atype);
+ if Atype.Kind /= ON_Record_Type then
+ raise Type_Error;
+ end if;
+ return new O_Cnode_Type'(Kind => OC_Record_Sizeof_Lit,
+ Ctype => Rtype,
+ Ref => False,
+ S_Type => Atype);
+ end New_Record_Sizeof;
function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
is
@@ -496,23 +523,17 @@ package body Ortho_Debug is
return Res;
end New_Alloca;
- procedure Check_Constrained_Type (Atype : O_Tnode) is
+ function Get_Base_Type (Atype : O_Tnode) return O_Tnode is
begin
case Atype.Kind is
- when ON_Array_Type =>
- raise Type_Error;
- when ON_Unsigned_Type
- | ON_Signed_Type
- | ON_Boolean_Type
- | ON_Record_Type
- | ON_Union_Type
- | ON_Access_Type
- | ON_Float_Type
- | ON_Array_Sub_Type
- | ON_Enum_Type =>
- null;
+ when ON_Array_Subtype =>
+ return Atype.Arr_Base;
+ when ON_Record_Subtype =>
+ return Atype.Subrec_Base;
+ when others =>
+ return Atype;
end case;
- end Check_Constrained_Type;
+ end Get_Base_Type;
procedure New_Completed_Type_Decl (Atype : O_Tnode)
is
@@ -528,15 +549,14 @@ package body Ortho_Debug is
Add_Decl (N, False);
end New_Completed_Type_Decl;
- procedure New_Uncomplete_Record_Type (Res : out O_Tnode)
- is
- subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type);
+ procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
begin
- Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type,
- Decl => O_Dnode_Null,
- Uncomplete => True,
- Complete => False,
- Elements => O_Fnode_Null);
+ Res := new O_Tnode_Type'(Kind => ON_Record_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => True,
+ Complete => False,
+ Constrained => True,
+ Rec_Elements => O_Fnode_Null);
end New_Uncomplete_Record_Type;
procedure Start_Uncomplete_Record_Type (Res : O_Tnode;
@@ -546,7 +566,7 @@ package body Ortho_Debug is
-- RES record type is not an uncomplete record type.
raise Syntax_Error;
end if;
- if Res.Elements /= O_Fnode_Null then
+ if Res.Rec_Elements /= O_Fnode_Null then
-- RES record type already has elements...
raise Syntax_Error;
end if;
@@ -556,14 +576,16 @@ package body Ortho_Debug is
procedure Start_Record_Type (Elements : out O_Element_List)
is
- subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type);
+ Res : O_Tnode;
begin
- Elements.Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type,
- Decl => O_Dnode_Null,
- Uncomplete => False,
- Complete => False,
- Elements => O_Fnode_Null);
- Elements.Last := null;
+ Res := new O_Tnode_Type'(Kind => ON_Record_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => False,
+ Constrained => True,
+ Rec_Elements => O_Fnode_Null);
+ Elements := (Res => Res,
+ Last => null);
end Start_Record_Type;
procedure New_Record_Field
@@ -573,15 +595,16 @@ package body Ortho_Debug is
is
begin
Check_Complete_Type (Etype);
- Check_Constrained_Type (Etype);
+ if not Etype.Constrained then
+ Elements.Res.Constrained := False;
+ end if;
El := new O_Fnode_Type'(Parent => Elements.Res,
Next => null,
Ident => Ident,
- Ftype => Etype,
- Offset => 0);
+ Ftype => Etype);
-- Append EL.
if Elements.Last = null then
- Elements.Res.Elements := El;
+ Elements.Res.Rec_Elements := El;
else
Elements.Last.Next := El;
end if;
@@ -599,15 +622,82 @@ package body Ortho_Debug is
Res.Complete := True;
end Finish_Record_Type;
- procedure Start_Union_Type (Elements : out O_Element_List)
+ procedure Start_Record_Subtype
+ (Rtype : O_Tnode; Elements : out O_Element_Sublist)
+ is
+ Res : O_Tnode;
+ begin
+ if Rtype.Kind /= ON_Record_Type then
+ raise Syntax_Error;
+ end if;
+
+ Res := new O_Tnode_Type'(Kind => ON_Record_Subtype,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => False,
+ Constrained => True,
+ Subrec_Elements => O_Fnode_Null,
+ Subrec_Base => Rtype);
+ Elements := (Res => Res,
+ Last => null,
+ Base_Field => Rtype.Rec_Elements);
+ end Start_Record_Subtype;
+
+ procedure New_Subrecord_Field
+ (Elements : in out O_Element_Sublist; El : out O_Fnode; Etype : O_Tnode)
is
- subtype O_Tnode_Union_Type is O_Tnode_Type (ON_Union_Type);
+ Base_Field : O_Fnode;
+ begin
+ Check_Complete_Type (Etype);
+ Check_Constrained_Type (Etype);
+
+ Base_Field := Elements.Base_Field;
+ if Base_Field = O_Fnode_Null then
+ raise Syntax_Error;
+ end if;
+ if Base_Field.Ftype.Constrained then
+ -- For constrained field of the base type, the type must be the
+ -- same.
+ if Base_Field.Ftype /= Etype then
+ raise Syntax_Error;
+ end if;
+ else
+ -- Otherwise, must be a subtype.
+ if Get_Base_Type (Etype) /= Base_Field.Ftype then
+ raise Syntax_Error;
+ end if;
+ end if;
+ El := new O_Fnode_Type'(Parent => Elements.Res,
+ Next => null,
+ Ident => Base_Field.Ident,
+ Ftype => Etype);
+
+ -- Append EL.
+ if Elements.Last = null then
+ Elements.Res.Subrec_Elements := El;
+ else
+ Elements.Last.Next := El;
+ end if;
+ Elements.Last := El;
+
+ Elements.Base_Field := Base_Field.Next;
+ end New_Subrecord_Field;
+
+ procedure Finish_Record_Subtype
+ (Elements : in out O_Element_Sublist; Res : out O_Tnode) is
begin
- Elements.Res := new O_Tnode_Union_Type'(Kind => ON_Union_Type,
- Decl => O_Dnode_Null,
- Uncomplete => False,
- Complete => False,
- Elements => O_Fnode_Null);
+ Res := Elements.Res;
+ Res.Complete := True;
+ end Finish_Record_Subtype;
+
+ procedure Start_Union_Type (Elements : out O_Element_List) is
+ begin
+ Elements.Res := new O_Tnode_Type'(Kind => ON_Union_Type,
+ Decl => O_Dnode_Null,
+ Uncomplete => False,
+ Complete => False,
+ Constrained => True,
+ Rec_Elements => O_Fnode_Null);
Elements.Last := null;
end Start_Union_Type;
@@ -627,29 +717,34 @@ package body Ortho_Debug is
Res.Complete := True;
end Finish_Union_Type;
+ function Is_Subtype (T : O_Tnode) return Boolean is
+ begin
+ case T.Kind is
+ when ON_Array_Subtype
+ | ON_Record_Subtype =>
+ return True;
+ when others =>
+ return False;
+ end case;
+ end Is_Subtype;
+
function New_Access_Type (Dtype : O_Tnode) return O_Tnode
is
subtype O_Tnode_Access is O_Tnode_Type (ON_Access_Type);
Res : O_Tnode;
begin
- if Dtype /= O_Tnode_Null
- and then Dtype.Kind = ON_Array_Sub_Type
- then
- -- Access to sub array are not allowed, use access to array.
- raise Type_Error;
- end if;
Res := new O_Tnode_Access'(Kind => ON_Access_Type,
Decl => O_Dnode_Null,
Uncomplete => Dtype = O_Tnode_Null,
Complete => True,
+ Constrained => True,
D_Type => Dtype);
return Res;
end New_Access_Type;
- procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode)
- is
+ procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) is
begin
- if Dtype.Kind = ON_Array_Sub_Type then
+ if Is_Subtype (Dtype) then
-- Access to sub array are not allowed, use access to array.
raise Type_Error;
end if;
@@ -668,31 +763,47 @@ package body Ortho_Debug is
is
subtype O_Tnode_Array is O_Tnode_Type (ON_Array_Type);
begin
- Check_Constrained_Type (El_Type);
Check_Complete_Type (El_Type);
return new O_Tnode_Array'(Kind => ON_Array_Type,
Decl => O_Dnode_Null,
Uncomplete => False,
Complete => True,
+ Constrained => False, -- By definition
El_Type => El_Type,
Index_Type => Index_Type);
end New_Array_Type;
- function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
- return O_Tnode
+ function New_Array_Subtype
+ (Atype : O_Tnode; El_Type : O_Tnode; Length : O_Cnode) return O_Tnode
is
- subtype O_Tnode_Sub_Array is O_Tnode_Type (ON_Array_Sub_Type);
+ subtype O_Tnode_Sub_Array is O_Tnode_Type (ON_Array_Subtype);
begin
+ -- Can only constraint an array type.
if Atype.Kind /= ON_Array_Type then
raise Type_Error;
end if;
- return new O_Tnode_Sub_Array'(Kind => ON_Array_Sub_Type,
+
+ -- The element must either be ATYPE element or a constrained subtype
+ -- of it.
+ if El_Type /= Atype.El_Type then
+ if El_Type.Kind = ON_Array_Subtype then
+ if El_Type.Arr_Base /= Atype.El_Type then
+ raise Type_Error;
+ end if;
+ else
+ raise Type_Error;
+ end if;
+ end if;
+
+ return new O_Tnode_Sub_Array'(Kind => ON_Array_Subtype,
Decl => O_Dnode_Null,
Uncomplete => False,
Complete => True,
- Base_Type => Atype,
+ Constrained => True,
+ Arr_Base => Atype,
+ Arr_El_Type => El_Type,
Length => Length);
- end New_Constrained_Array_Type;
+ end New_Array_Subtype;
function New_Unsigned_Type (Size : Natural) return O_Tnode
is
@@ -702,6 +813,7 @@ package body Ortho_Debug is
Decl => O_Dnode_Null,
Uncomplete => False,
Complete => True,
+ Constrained => True,
Int_Size => Size);
end New_Unsigned_Type;
@@ -713,6 +825,7 @@ package body Ortho_Debug is
Decl => O_Dnode_Null,
Uncomplete => False,
Complete => True,
+ Constrained => True,
Int_Size => Size);
end New_Signed_Type;
@@ -723,7 +836,8 @@ package body Ortho_Debug is
return new O_Tnode_Float'(Kind => ON_Float_Type,
Decl => O_Dnode_Null,
Uncomplete => False,
- Complete => True);
+ Complete => True,
+ Constrained => True);
end New_Float_Type;
procedure New_Boolean_Type (Res : out O_Tnode;
@@ -739,6 +853,7 @@ package body Ortho_Debug is
Decl => O_Dnode_Null,
Uncomplete => False,
Complete => True,
+ Constrained => True,
True_N => O_Cnode_Null,
False_N => O_Cnode_Null);
True_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit,
@@ -765,6 +880,7 @@ package body Ortho_Debug is
Decl => O_Dnode_Null,
Uncomplete => False,
Complete => False,
+ Constrained => True,
Nbr => 0,
Literals => O_Cnode_Null);
List.Res := Res;
@@ -800,16 +916,17 @@ package body Ortho_Debug is
Res.Complete := True;
end Finish_Enum_Type;
- function Get_Base_Type (Atype : O_Tnode) return O_Tnode
- is
+ function Get_Array_El_Type (Atype : O_Tnode) return O_Tnode is
begin
case Atype.Kind is
- when ON_Array_Sub_Type =>
- return Atype.Base_Type;
+ when ON_Array_Subtype =>
+ return Atype.Arr_El_Type;
+ when ON_Array_Type =>
+ return Atype.El_Type;
when others =>
- return Atype;
+ raise Syntax_Error;
end case;
- end Get_Base_Type;
+ end Get_Array_El_Type;
procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode)
is
@@ -826,7 +943,7 @@ package body Ortho_Debug is
Rec_Els => null);
List.Res := Res;
List.Last := null;
- List.Field := Atype.Elements;
+ List.Field := Atype.Rec_Elements;
end Start_Record_Aggr;
procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List;
@@ -872,16 +989,16 @@ package body Ortho_Debug is
Res : O_Cnode;
begin
case Atype.Kind is
- when ON_Array_Sub_Type =>
+ when ON_Array_Subtype =>
if Atype.Length.U_Val /= Unsigned_64 (Len) then
raise Type_Error;
end if;
- List.El_Type := Atype.Base_Type.El_Type;
when ON_Array_Type =>
- List.El_Type := Atype.El_Type;
+ null;
when others =>
raise Type_Error;
end case;
+ List.El_Type := Get_Array_El_Type (Atype);
Check_Complete_Type (Atype);
Res := new O_Cnode_Aggregate'(Kind => OC_Array_Aggregate,
Ctype => Atype,
@@ -982,6 +1099,12 @@ package body Ortho_Debug is
subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element);
Res : O_Lnode;
begin
+ if Arr.Rtype.Kind not in ON_Array_Kinds then
+ -- Can only index an array.
+ raise Type_Error;
+ end if;
+ -- The element type of ARR must be constrained.
+ Check_Constrained_Type (Get_Array_El_Type (Arr.Rtype));
Check_Ref (Arr);
Res := new O_Lnode_Indexed'(Kind => OL_Indexed_Element,
Rtype => Get_Base_Type (Arr.Rtype).El_Type,
@@ -997,9 +1120,14 @@ package body Ortho_Debug is
subtype O_Lnode_Slice is O_Lnode_Type (OL_Slice);
Res : O_Lnode;
begin
- if Res_Type.Kind /= ON_Array_Type
- and then Res_Type.Kind /= ON_Array_Sub_Type
- then
+ if Arr.Rtype.Kind not in ON_Array_Kinds then
+ -- Can only slice an array.
+ raise Type_Error;
+ end if;
+ -- The element type of ARR must be constrained.
+ Check_Constrained_Type (Get_Array_El_Type (Arr.Rtype));
+ -- The result is an array.
+ if Res_Type.Kind not in ON_Array_Kinds then
raise Type_Error;
end if;
Check_Ref (Arr);
@@ -1018,11 +1146,14 @@ package body Ortho_Debug is
is
subtype O_Lnode_Selected_Element is O_Lnode_Type (OL_Selected_Element);
begin
- if Rec.Rtype.Kind /= ON_Record_Type
- and then Rec.Rtype.Kind /= ON_Union_Type
- then
- raise Type_Error;
- end if;
+ case Rec.Rtype.Kind is
+ when ON_Record_Type
+ | ON_Record_Subtype
+ | ON_Union_Type =>
+ null;
+ when others =>
+ raise Type_Error;
+ end case;
if Rec.Rtype /= El.Parent then
raise Type_Error;
end if;
@@ -1076,16 +1207,18 @@ package body Ortho_Debug is
T : constant Boolean := True;
F : constant Boolean := False;
Conv_Allowed : constant Conv_Array :=
- (ON_Boolean_Type => (T, F, T, T, F, F, F, F, F, F),
- ON_Enum_Type => (F, F, T, T, F, F, F, F, F, F),
- ON_Unsigned_Type => (T, T, T, T, F, F, F, F, F, F),
- ON_Signed_Type => (T, T, T, T, T, F, F, F, F, F),
- ON_Float_Type => (F, F, F, T, T, F, F, F, F, F),
- ON_Array_Type => (F, F, F, F, F, F, T, F, F, F),
- ON_Array_Sub_Type =>(F, F, F, F, F, T, T, F, F, F),
- ON_Record_Type => (F, F, F, F, F, F, F, F, F, F),
- ON_Union_Type => (F, F, F, F, F, F, F, F, F, F),
- ON_Access_Type => (F, F, F, F, F, F, F, F, F, T));
+ -- B E U S F A a R r U A
+ (ON_Boolean_Type => (T, F, T, T, F, F, F, F, F, F, F),
+ ON_Enum_Type => (F, F, T, T, F, F, F, F, F, F, F),
+ ON_Unsigned_Type => (T, T, T, T, F, F, F, F, F, F, F),
+ ON_Signed_Type => (T, T, T, T, T, F, F, F, F, F, F),
+ ON_Float_Type => (F, F, F, T, T, F, F, F, F, F, F),
+ ON_Array_Type => (F, F, F, F, F, F, F, F, F, F, F),
+ ON_Array_Subtype => (F, F, F, F, F, F, F, F, F, F, F),
+ ON_Record_Type => (F, F, F, F, F, F, F, F, F, F, F),
+ ON_Record_Subtype => (F, F, F, F, F, F, F, F, F, F, F),
+ ON_Union_Type => (F, F, F, F, F, F, F, F, F, F, F),
+ ON_Access_Type => (F, F, F, F, F, F, F, F, F, F, T));
begin
if Source = Target then
return True;
@@ -1149,11 +1282,7 @@ package body Ortho_Debug is
-- An address is of type access.
raise Type_Error;
end if;
- if Get_Base_Type (Lvalue.Rtype) /= Get_Base_Type (Atype.D_Type) then
- if not Disable_Checks then
- raise Type_Error;
- end if;
- end if;
+ Check_Type (Get_Base_Type (Lvalue.Rtype), Get_Base_Type (Atype.D_Type));
return new O_Enode_Address'(Kind => OE_Address,
Rtype => Atype,
Ref => False,
@@ -1225,8 +1354,9 @@ package body Ortho_Debug is
return;
when ON_Array_Type
| ON_Record_Type
+ | ON_Record_Subtype
| ON_Union_Type
- | ON_Array_Sub_Type =>
+ | ON_Array_Subtype =>
raise Type_Error;
end case;
end Check_Not_Composite;
@@ -1342,6 +1472,7 @@ package body Ortho_Debug is
subtype O_Dnode_Const is O_Dnode_Type (ON_Const_Decl);
begin
Check_Complete_Type (Atype);
+ Check_Constrained_Type (Atype);
if Storage = O_Storage_Local then
-- A constant cannot be local.
raise Syntax_Error;
@@ -1415,6 +1546,7 @@ package body Ortho_Debug is
subtype O_Dnode_Var is O_Dnode_Type (ON_Var_Decl);
begin
Check_Complete_Type (Atype);
+ Check_Constrained_Type (Atype);
Check_Object_Storage (Storage);
Res := new O_Dnode_Var'(Kind => ON_Var_Decl,
Name => Ident,
diff --git a/src/ortho/debug/ortho_debug.private.ads b/src/ortho/debug/ortho_debug.private.ads
index 0bf91f106..2419c07b8 100644
--- a/src/ortho/debug/ortho_debug.private.ads
+++ b/src/ortho/debug/ortho_debug.private.ads
@@ -29,6 +29,12 @@ private
-- This back-end supports nested subprograms.
Has_Nested_Subprograms : constant Boolean := True;
+ -- Return the type of elements of array type/subtype ATYPE.
+ function Get_Array_El_Type (Atype : O_Tnode) return O_Tnode;
+
+ -- Return the base type of T.
+ -- function Get_Base_Type (T : O_Tnode) return O_Tnode;
+
-- A node for a type.
type O_Tnode_Type (<>);
type O_Tnode is access O_Tnode_Type;
@@ -111,8 +117,6 @@ private
Ident : O_Ident;
-- Type of the record field.
Ftype : O_Tnode;
- -- Offset in the field.
- Offset : Unsigned_32;
end record;
type O_Anode_Type;
@@ -132,6 +136,7 @@ private
OC_Enum_Lit,
OC_Null_Lit,
OC_Sizeof_Lit,
+ OC_Record_Sizeof_Lit,
OC_Alignof_Lit,
OC_Offsetof_Lit,
OC_Default_Lit,
@@ -167,7 +172,8 @@ private
when OC_Default_Lit =>
null;
when OC_Sizeof_Lit
- | OC_Alignof_Lit =>
+ | OC_Record_Sizeof_Lit
+ | OC_Alignof_Lit =>
S_Type : O_Tnode;
when OC_Offsetof_Lit =>
Off_Field : O_Fnode;
@@ -342,14 +348,22 @@ private
O_Tnode_Null : constant O_Tnode := null;
type ON_Type_Kind is
(ON_Boolean_Type, ON_Enum_Type,
- ON_Unsigned_Type, ON_Signed_Type, ON_Float_Type, ON_Array_Type,
- ON_Array_Sub_Type, ON_Record_Type, ON_Union_Type, ON_Access_Type);
+ ON_Unsigned_Type, ON_Signed_Type, ON_Float_Type,
+ ON_Array_Type, ON_Array_Subtype,
+ ON_Record_Type, ON_Record_Subtype,
+ ON_Union_Type, ON_Access_Type);
+
+ subtype ON_Array_Kinds is ON_Type_Kind
+ range ON_Array_Type .. ON_Array_Subtype;
+
type O_Tnode_Type (Kind : ON_Type_Kind) is record
Decl : O_Dnode;
-- True if the type was first created as an uncomplete type.
Uncomplete : Boolean;
-- True if the type is complete.
Complete : Boolean;
+ -- True if the type is fully constrained.
+ Constrained : Boolean;
case Kind is
when ON_Boolean_Type =>
True_N : O_Cnode;
@@ -362,17 +376,21 @@ private
when ON_Enum_Type =>
Nbr : Natural;
Literals: O_Cnode;
+ when ON_Access_Type =>
+ D_Type : O_Tnode;
when ON_Array_Type =>
El_Type : O_Tnode;
Index_Type : O_Tnode;
- when ON_Access_Type =>
- D_Type : O_Tnode;
+ when ON_Array_Subtype =>
+ Length : O_Cnode;
+ Arr_El_Type : O_Tnode;
+ Arr_Base : O_Tnode;
when ON_Record_Type
| ON_Union_Type =>
- Elements : O_Fnode;
- when ON_Array_Sub_Type =>
- Length : O_Cnode;
- Base_Type : O_Tnode;
+ Rec_Elements : O_Fnode;
+ when ON_Record_Subtype =>
+ Subrec_Elements : O_Fnode;
+ Subrec_Base : O_Tnode;
end case;
end record;
@@ -455,6 +473,15 @@ private
Last : O_Fnode;
end record;
+ type O_Element_Sublist is record
+ -- The type definition.
+ Res : O_Tnode;
+ -- The last element added.
+ Last : O_Fnode;
+ -- The correspond field from the base type.
+ Base_Field : O_Fnode;
+ end record;
+
type O_Record_Aggr_List is record
Res : O_Cnode;
Last : O_Cnode;
diff --git a/src/ortho/gcc/ortho-lang-49.c b/src/ortho/gcc/ortho-lang-49.c
index 3e29f0a14..53a7e6fb9 100644
--- a/src/ortho/gcc/ortho-lang-49.c
+++ b/src/ortho/gcc/ortho-lang-49.c
@@ -1104,6 +1104,14 @@ struct GTY(()) o_element_list
struct chain_constr_type chain;
};
+struct GTY(()) o_element_sublist
+{
+ tree base;
+ tree field;
+ tree res;
+ struct chain_constr_type chain;
+};
+
void
new_uncomplete_record_type (tree *res)
{
@@ -1161,10 +1169,41 @@ finish_record_type (struct o_element_list *elements, tree *res)
}
}
+void
+start_record_subtype (tree rtype, struct o_element_sublist *elements)
+{
+ elements->base = rtype;
+ elements->field = TYPE_FIELDS (rtype);
+ elements->res = make_node (RECORD_TYPE);
+ chain_init (&elements->chain);
+}
+
+void
+new_subrecord_field (struct o_element_sublist *list,
+ tree *el,
+ tree etype)
+{
+ tree res;
+
+ res = build_decl (input_location, FIELD_DECL, DECL_NAME(list->field), etype);
+ DECL_CONTEXT (res) = list->res;
+ chain_append (&list->chain, res);
+ list->field = TREE_CHAIN(list->field);
+ *el = res;
+}
+
+void
+finish_record_subtype (struct o_element_sublist *elements, tree *res)
+{
+ TYPE_FIELDS (elements->res) = elements->chain.first;
+ layout_type (elements->res);
+ *res = elements->res;
+}
+
void
start_union_type (struct o_element_list *elements)
{
- elements->res = make_node (UNION_TYPE);
+ elements->res = make_node (UNION_TYPE);
chain_init (&elements->chain);
}
@@ -1269,7 +1308,7 @@ new_array_type (tree el_type, tree index_type)
}
tree
-new_constrained_array_type (tree atype, tree length)
+new_array_subtype (tree atype, tree eltype, tree length)
{
tree range_type;
tree index_type;
@@ -1278,7 +1317,7 @@ new_constrained_array_type (tree atype, tree length)
index_type = TYPE_DOMAIN (atype);
range_type = ortho_build_array_range(index_type, length);
- res = build_array_type (TREE_TYPE (atype), range_type);
+ res = build_array_type (eltype, range_type);
/* Constrained arrays are *always* a subtype of its array type.
Just copy alias set. */
@@ -1382,7 +1421,7 @@ start_array_aggr (struct o_array_aggr_list *list, tree atype, unsigned len)
tree length;
length = new_unsigned_literal (sizetype, len);
- list->atype = new_constrained_array_type (atype, length);
+ list->atype = new_array_subtype (atype, TREE_TYPE (atype), length);
vec_alloc(list->elts, len);
}
@@ -1497,6 +1536,12 @@ new_sizeof (tree atype, tree rtype)
return fold (build1 (NOP_EXPR, rtype, size));
}
+tree
+new_record_sizeof (tree atype, tree rtype)
+{
+ return new_sizeof (atype, rtype);
+}
+
tree
new_alignof (tree atype, tree rtype)
{
diff --git a/src/ortho/gcc/ortho-lang-5.c b/src/ortho/gcc/ortho-lang-5.c
index 3e046f7a3..dff47fb94 100644
--- a/src/ortho/gcc/ortho-lang-5.c
+++ b/src/ortho/gcc/ortho-lang-5.c
@@ -1090,6 +1090,14 @@ struct GTY(()) o_element_list
struct chain_constr_type chain;
};
+struct GTY(()) o_element_sublist
+{
+ tree base;
+ tree field;
+ tree res;
+ struct chain_constr_type chain;
+};
+
void
new_uncomplete_record_type (tree *res)
{
@@ -1147,10 +1155,41 @@ finish_record_type (struct o_element_list *elements, tree *res)
}
}
+void
+start_record_subtype (tree rtype, struct o_element_sublist *elements)
+{
+ elements->base = rtype;
+ elements->field = TYPE_FIELDS (rtype);
+ elements->res = make_node (RECORD_TYPE);
+ chain_init (&elements->chain);
+}
+
+void
+new_subrecord_field (struct o_element_sublist *list,
+ tree *el,
+ tree etype)
+{
+ tree res;
+
+ res = build_decl (input_location, FIELD_DECL, DECL_NAME(list->field), etype);
+ DECL_CONTEXT (res) = list->res;
+ chain_append (&list->chain, res);
+ list->field = TREE_CHAIN(list->field);
+ *el = res;
+}
+
+void
+finish_record_subtype (struct o_element_sublist *elements, tree *res)
+{
+ TYPE_FIELDS (elements->res) = elements->chain.first;
+ layout_type (elements->res);
+ *res = elements->res;
+}
+
void
start_union_type (struct o_element_list *elements)
{
- elements->res = make_node (UNION_TYPE);
+ elements->res = make_node (UNION_TYPE);
chain_init (&elements->chain);
}
@@ -1255,7 +1294,7 @@ new_array_type (tree el_type, tree index_type)
}
tree
-new_constrained_array_type (tree atype, tree length)
+new_array_subtype (tree atype, tree eltype, tree length)
{
tree range_type;
tree index_type;
@@ -1264,7 +1303,7 @@ new_constrained_array_type (tree atype, tree length)
index_type = TYPE_DOMAIN (atype);
range_type = ortho_build_array_range(index_type, length);
- res = build_array_type (TREE_TYPE (atype), range_type);
+ res = build_array_type (eltype, range_type);
/* Constrained arrays are *always* a subtype of its array type.
Just copy alias set. */
@@ -1368,7 +1407,7 @@ start_array_aggr (struct o_array_aggr_list *list, tree atype, unsigned len)
tree length;
length = new_unsigned_literal (sizetype, len);
- list->atype = new_constrained_array_type (atype, length);
+ list->atype = new_array_subtype (atype, TREE_TYPE (atype), length);
vec_alloc(list->elts, len);
}
@@ -1483,6 +1522,12 @@ new_sizeof (tree atype, tree rtype)
return fold (build1 (NOP_EXPR, rtype, size));
}
+tree
+new_record_sizeof (tree atype, tree rtype)
+{
+ return new_sizeof (atype, rtype);
+}
+
tree
new_alignof (tree atype, tree rtype)
{
diff --git a/src/ortho/gcc/ortho-lang-6.c b/src/ortho/gcc/ortho-lang-6.c
index bd989d9a8..706b23574 100644
--- a/src/ortho/gcc/ortho-lang-6.c
+++ b/src/ortho/gcc/ortho-lang-6.c
@@ -1090,6 +1090,14 @@ struct GTY(()) o_element_list
struct chain_constr_type chain;
};
+struct GTY(()) o_element_sublist
+{
+ tree base;
+ tree field;
+ tree res;
+ struct chain_constr_type chain;
+};
+
void
new_uncomplete_record_type (tree *res)
{
@@ -1147,10 +1155,41 @@ finish_record_type (struct o_element_list *elements, tree *res)
}
}
+void
+start_record_subtype (tree rtype, struct o_element_sublist *elements)
+{
+ elements->base = rtype;
+ elements->field = TYPE_FIELDS (rtype);
+ elements->res = make_node (RECORD_TYPE);
+ chain_init (&elements->chain);
+}
+
+void
+new_subrecord_field (struct o_element_sublist *list,
+ tree *el,
+ tree etype)
+{
+ tree res;
+
+ res = build_decl (input_location, FIELD_DECL, DECL_NAME(list->field), etype);
+ DECL_CONTEXT (res) = list->res;
+ chain_append (&list->chain, res);
+ list->field = TREE_CHAIN(list->field);
+ *el = res;
+}
+
+void
+finish_record_subtype (struct o_element_sublist *elements, tree *res)
+{
+ TYPE_FIELDS (elements->res) = elements->chain.first;
+ layout_type (elements->res);
+ *res = elements->res;
+}
+
void
start_union_type (struct o_element_list *elements)
{
- elements->res = make_node (UNION_TYPE);
+ elements->res = make_node (UNION_TYPE);
chain_init (&elements->chain);
}
@@ -1255,7 +1294,7 @@ new_array_type (tree el_type, tree index_type)
}
tree
-new_constrained_array_type (tree atype, tree length)
+new_array_subtype (tree atype, tree eltype, tree length)
{
tree range_type;
tree index_type;
@@ -1264,7 +1303,7 @@ new_constrained_array_type (tree atype, tree length)
index_type = TYPE_DOMAIN (atype);
range_type = ortho_build_array_range(index_type, length);
- res = build_array_type (TREE_TYPE (atype), range_type);
+ res = build_array_type (eltype, range_type);
/* Constrained arrays are *always* a subtype of its array type.
Just copy alias set. */
@@ -1368,7 +1407,7 @@ start_array_aggr (struct o_array_aggr_list *list, tree atype, unsigned len)
tree length;
length = new_unsigned_literal (sizetype, len);
- list->atype = new_constrained_array_type (atype, length);
+ list->atype = new_array_subtype (atype, TREE_TYPE (atype), length);
vec_alloc(list->elts, len);
}
@@ -1483,6 +1522,12 @@ new_sizeof (tree atype, tree rtype)
return fold (build1 (NOP_EXPR, rtype, size));
}
+tree
+new_record_sizeof (tree atype, tree rtype)
+{
+ return new_sizeof (atype, rtype);
+}
+
tree
new_alignof (tree atype, tree rtype)
{
diff --git a/src/ortho/gcc/ortho-lang-7.c b/src/ortho/gcc/ortho-lang-7.c
index e9c0d47c8..f64c42102 100644
--- a/src/ortho/gcc/ortho-lang-7.c
+++ b/src/ortho/gcc/ortho-lang-7.c
@@ -1102,6 +1102,14 @@ struct GTY(()) o_element_list
struct chain_constr_type chain;
};
+struct GTY(()) o_element_sublist
+{
+ tree base;
+ tree field;
+ tree res;
+ struct chain_constr_type chain;
+};
+
void
new_uncomplete_record_type (tree *res)
{
@@ -1159,10 +1167,41 @@ finish_record_type (struct o_element_list *elements, tree *res)
}
}
+void
+start_record_subtype (tree rtype, struct o_element_sublist *elements)
+{
+ elements->base = rtype;
+ elements->field = TYPE_FIELDS (rtype);
+ elements->res = make_node (RECORD_TYPE);
+ chain_init (&elements->chain);
+}
+
+void
+new_subrecord_field (struct o_element_sublist *list,
+ tree *el,
+ tree etype)
+{
+ tree res;
+
+ res = build_decl (input_location, FIELD_DECL, DECL_NAME(list->field), etype);
+ DECL_CONTEXT (res) = list->res;
+ chain_append (&list->chain, res);
+ list->field = TREE_CHAIN(list->field);
+ *el = res;
+}
+
+void
+finish_record_subtype (struct o_element_sublist *elements, tree *res)
+{
+ TYPE_FIELDS (elements->res) = elements->chain.first;
+ layout_type (elements->res);
+ *res = elements->res;
+}
+
void
start_union_type (struct o_element_list *elements)
{
- elements->res = make_node (UNION_TYPE);
+ elements->res = make_node (UNION_TYPE);
chain_init (&elements->chain);
}
@@ -1267,7 +1306,7 @@ new_array_type (tree el_type, tree index_type)
}
tree
-new_constrained_array_type (tree atype, tree length)
+new_array_subtype (tree atype, tree eltype, tree length)
{
tree range_type;
tree index_type;
@@ -1276,7 +1315,7 @@ new_constrained_array_type (tree atype, tree length)
index_type = TYPE_DOMAIN (atype);
range_type = ortho_build_array_range(index_type, length);
- res = build_array_type (TREE_TYPE (atype), range_type);
+ res = build_array_type (eltype, range_type);
/* Constrained arrays are *always* a subtype of its array type.
Just copy alias set. */
@@ -1380,7 +1419,7 @@ start_array_aggr (struct o_array_aggr_list *list, tree atype, unsigned len)
tree length;
length = new_unsigned_literal (sizetype, len);
- list->atype = new_constrained_array_type (atype, length);
+ list->atype = new_array_subtype (atype, TREE_TYPE (atype), length);
vec_alloc(list->elts, len);
}
@@ -1495,6 +1534,12 @@ new_sizeof (tree atype, tree rtype)
return fold (build1 (NOP_EXPR, rtype, size));
}
+tree
+new_record_sizeof (tree atype, tree rtype)
+{
+ return new_sizeof (atype, rtype);
+}
+
tree
new_alignof (tree atype, tree rtype)
{
diff --git a/src/ortho/gcc/ortho-lang-8.c b/src/ortho/gcc/ortho-lang-8.c
index 350504cdf..33dc894ee 100644
--- a/src/ortho/gcc/ortho-lang-8.c
+++ b/src/ortho/gcc/ortho-lang-8.c
@@ -1103,6 +1103,14 @@ struct GTY(()) o_element_list
struct chain_constr_type chain;
};
+struct GTY(()) o_element_sublist
+{
+ tree base;
+ tree field;
+ tree res;
+ struct chain_constr_type chain;
+};
+
void
new_uncomplete_record_type (tree *res)
{
@@ -1160,10 +1168,41 @@ finish_record_type (struct o_element_list *elements, tree *res)
}
}
+void
+start_record_subtype (tree rtype, struct o_element_sublist *elements)
+{
+ elements->base = rtype;
+ elements->field = TYPE_FIELDS (rtype);
+ elements->res = make_node (RECORD_TYPE);
+ chain_init (&elements->chain);
+}
+
+void
+new_subrecord_field (struct o_element_sublist *list,
+ tree *el,
+ tree etype)
+{
+ tree res;
+
+ res = build_decl (input_location, FIELD_DECL, DECL_NAME(list->field), etype);
+ DECL_CONTEXT (res) = list->res;
+ chain_append (&list->chain, res);
+ list->field = TREE_CHAIN(list->field);
+ *el = res;
+}
+
+void
+finish_record_subtype (struct o_element_sublist *elements, tree *res)
+{
+ TYPE_FIELDS (elements->res) = elements->chain.first;
+ layout_type (elements->res);
+ *res = elements->res;
+}
+
void
start_union_type (struct o_element_list *elements)
{
- elements->res = make_node (UNION_TYPE);
+ elements->res = make_node (UNION_TYPE);
chain_init (&elements->chain);
}
@@ -1268,7 +1307,7 @@ new_array_type (tree el_type, tree index_type)
}
tree
-new_constrained_array_type (tree atype, tree length)
+new_array_subtype (tree atype, tree eltype, tree length)
{
tree range_type;
tree index_type;
@@ -1277,7 +1316,7 @@ new_constrained_array_type (tree atype, tree length)
index_type = TYPE_DOMAIN (atype);
range_type = ortho_build_array_range(index_type, length);
- res = build_array_type (TREE_TYPE (atype), range_type);
+ res = build_array_type (eltype, range_type);
/* Constrained arrays are *always* a subtype of its array type.
Just copy alias set. */
@@ -1381,7 +1420,7 @@ start_array_aggr (struct o_array_aggr_list *list, tree atype, unsigned len)
tree length;
length = new_unsigned_literal (sizetype, len);
- list->atype = new_constrained_array_type (atype, length);
+ list->atype = new_array_subtype (atype, TREE_TYPE (atype), length);
vec_alloc(list->elts, len);
}
@@ -1496,6 +1535,12 @@ new_sizeof (tree atype, tree rtype)
return fold (build1 (NOP_EXPR, rtype, size));
}
+tree
+new_record_sizeof (tree atype, tree rtype)
+{
+ return new_sizeof (atype, rtype);
+}
+
tree
new_alignof (tree atype, tree rtype)
{
diff --git a/src/ortho/gcc/ortho-lang-9.c b/src/ortho/gcc/ortho-lang-9.c
index b027f0d6d..8b5ef1e19 100644
--- a/src/ortho/gcc/ortho-lang-9.c
+++ b/src/ortho/gcc/ortho-lang-9.c
@@ -1103,6 +1103,14 @@ struct GTY(()) o_element_list
struct chain_constr_type chain;
};
+struct GTY(()) o_element_sublist
+{
+ tree base;
+ tree field;
+ tree res;
+ struct chain_constr_type chain;
+};
+
void
new_uncomplete_record_type (tree *res)
{
@@ -1160,10 +1168,41 @@ finish_record_type (struct o_element_list *elements, tree *res)
}
}
+void
+start_record_subtype (tree rtype, struct o_element_sublist *elements)
+{
+ elements->base = rtype;
+ elements->field = TYPE_FIELDS (rtype);
+ elements->res = make_node (RECORD_TYPE);
+ chain_init (&elements->chain);
+}
+
+void
+new_subrecord_field (struct o_element_sublist *list,
+ tree *el,
+ tree etype)
+{
+ tree res;
+
+ res = build_decl (input_location, FIELD_DECL, DECL_NAME(list->field), etype);
+ DECL_CONTEXT (res) = list->res;
+ chain_append (&list->chain, res);
+ list->field = TREE_CHAIN(list->field);
+ *el = res;
+}
+
+void
+finish_record_subtype (struct o_element_sublist *elements, tree *res)
+{
+ TYPE_FIELDS (elements->res) = elements->chain.first;
+ layout_type (elements->res);
+ *res = elements->res;
+}
+
void
start_union_type (struct o_element_list *elements)
{
- elements->res = make_node (UNION_TYPE);
+ elements->res = make_node (UNION_TYPE);
chain_init (&elements->chain);
}
@@ -1268,7 +1307,7 @@ new_array_type (tree el_type, tree index_type)
}
tree
-new_constrained_array_type (tree atype, tree length)
+new_array_subtype (tree atype, tree eltype, tree length)
{
tree range_type;
tree index_type;
@@ -1277,7 +1316,7 @@ new_constrained_array_type (tree atype, tree length)
index_type = TYPE_DOMAIN (atype);
range_type = ortho_build_array_range(index_type, length);
- res = build_array_type (TREE_TYPE (atype), range_type);
+ res = build_array_type (eltype, range_type);
/* Constrained arrays are *always* a subtype of its array type.
Just copy alias set. */
@@ -1381,7 +1420,7 @@ start_array_aggr (struct o_array_aggr_list *list, tree atype, unsigned len)
tree length;
length = new_unsigned_literal (sizetype, len);
- list->atype = new_constrained_array_type (atype, length);
+ list->atype = new_array_subtype (atype, TREE_TYPE (atype), length);
vec_alloc(list->elts, len);
}
@@ -1496,6 +1535,12 @@ new_sizeof (tree atype, tree rtype)
return fold (build1 (NOP_EXPR, rtype, size));
}
+tree
+new_record_sizeof (tree atype, tree rtype)
+{
+ return new_sizeof (atype, rtype);
+}
+
tree
new_alignof (tree atype, tree rtype)
{
diff --git a/src/ortho/gcc/ortho_gcc.ads b/src/ortho/gcc/ortho_gcc.ads
index 0c1ee81b6..d98ae01ed 100644
--- a/src/ortho/gcc/ortho_gcc.ads
+++ b/src/ortho/gcc/ortho_gcc.ads
@@ -57,8 +57,8 @@ package Ortho_Gcc is
-- Build a record type.
procedure Start_Record_Type (Elements : out O_Element_List);
- -- Add a field in the record; not constrained array are prohibited, since
- -- its size is unlimited.
+ -- Add a field in the record. Unconstrained fields must be at the end,
+ -- and cannot be followed by a constrained one.
procedure New_Record_Field
(Elements : in out O_Element_List;
El : out O_Fnode;
@@ -67,6 +67,17 @@ package Ortho_Gcc is
procedure Finish_Record_Type
(Elements : in out O_Element_List; Res : out O_Tnode);
+ type O_Element_Sublist is limited private;
+
+ -- Build a record subtype.
+ -- Re-declare only unconstrained fields with a subtype of them.
+ procedure Start_Record_Subtype
+ (Rtype : O_Tnode; Elements : out O_Element_Sublist);
+ procedure New_Subrecord_Field
+ (Elements : in out O_Element_Sublist; El : out O_Fnode; Etype : O_Tnode);
+ procedure Finish_Record_Subtype
+ (Elements : in out O_Element_Sublist; Res : out O_Tnode);
+
-- Build an uncomplete record type:
-- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
-- This type can be declared or used to define access types on it.
@@ -98,8 +109,8 @@ package Ortho_Gcc is
return O_Tnode;
-- Build a constrained array type.
- function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
- return O_Tnode;
+ function New_Array_Subtype
+ (Atype : O_Tnode; El_Type : O_Tnode; Length : O_Cnode) return O_Tnode;
-- Build a scalar type; size may be 8, 16, 32 or 64.
function New_Unsigned_Type (Size : Natural) return O_Tnode;
@@ -172,9 +183,13 @@ package Ortho_Gcc is
-- Returns the size in bytes of ATYPE. The result is a literal of
-- unsigned type RTYPE
- -- ATYPE cannot be an unconstrained array type.
+ -- ATYPE cannot be an unconstrained type.
function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+ -- Get the size of the bounded part of a record.
+ function New_Record_Sizeof
+ (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
-- Returns the alignment in bytes for ATYPE. The result is a literal of
-- unsgined type RTYPE.
function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
@@ -556,6 +571,14 @@ private
end record;
pragma Convention (C, O_Element_List);
+ type O_Element_Sublist is record
+ Base : Tree;
+ Field : Tree;
+ Res : Tree;
+ Chain : Chain_Constr_Type;
+ end record;
+ pragma Convention (C, O_Element_Sublist);
+
type O_Case_Block is record
Prev_Stmts : Tree;
Case_Type : Tree;
@@ -622,6 +645,11 @@ private
pragma Import (C, Start_Record_Type);
pragma Import (C, New_Record_Field);
pragma Import (C, Finish_Record_Type);
+
+ pragma Import (C, Start_Record_Subtype);
+ pragma Import (C, New_Subrecord_Field);
+ pragma Import (C, Finish_Record_Subtype);
+
pragma Import (C, New_Uncomplete_Record_Type);
pragma Import (C, Start_Uncomplete_Record_Type);
@@ -637,7 +665,7 @@ private
pragma Import (C, Finish_Access_Type);
pragma Import (C, New_Array_Type);
- pragma Import (C, New_Constrained_Array_Type);
+ pragma Import (C, New_Array_Subtype);
pragma Import (C, New_Boolean_Type);
pragma Import (C, Start_Enum_Type);
@@ -659,6 +687,7 @@ private
pragma Import (C, New_Access_Element);
pragma Import (C, New_Sizeof);
+ pragma Import (C, New_Record_Sizeof);
pragma Import (C, New_Alignof);
pragma Import (C, New_Offsetof);
diff --git a/src/ortho/gcc/ortho_gcc.private.ads b/src/ortho/gcc/ortho_gcc.private.ads
index f8f6cfb3c..2a068aeb9 100644
--- a/src/ortho/gcc/ortho_gcc.private.ads
+++ b/src/ortho/gcc/ortho_gcc.private.ads
@@ -110,6 +110,14 @@ private
end record;
pragma Convention (C, O_Element_List);
+ type O_Element_Sublist is record
+ Base : Tree;
+ Field : Tree;
+ Res : Tree;
+ Chain : Chain_Constr_Type;
+ end record;
+ pragma Convention (C, O_Element_Sublist);
+
type O_Case_Block is record
Prev_Stmts : Tree;
Case_Type : Tree;
@@ -176,6 +184,11 @@ private
pragma Import (C, Start_Record_Type);
pragma Import (C, New_Record_Field);
pragma Import (C, Finish_Record_Type);
+
+ pragma Import (C, Start_Record_Subtype);
+ pragma Import (C, New_Subrecord_Field);
+ pragma Import (C, Finish_Record_Subtype);
+
pragma Import (C, New_Uncomplete_Record_Type);
pragma Import (C, Start_Uncomplete_Record_Type);
@@ -191,7 +204,7 @@ private
pragma Import (C, Finish_Access_Type);
pragma Import (C, New_Array_Type);
- pragma Import (C, New_Constrained_Array_Type);
+ pragma Import (C, New_Array_Subtype);
pragma Import (C, New_Boolean_Type);
pragma Import (C, Start_Enum_Type);
@@ -213,6 +226,7 @@ private
pragma Import (C, New_Access_Element);
pragma Import (C, New_Sizeof);
+ pragma Import (C, New_Record_Sizeof);
pragma Import (C, New_Alignof);
pragma Import (C, New_Offsetof);
diff --git a/src/ortho/llvm6/llvm-cbindings.cpp b/src/ortho/llvm6/llvm-cbindings.cpp
index 984258592..1841f5f8e 100644
--- a/src/ortho/llvm6/llvm-cbindings.cpp
+++ b/src/ortho/llvm6/llvm-cbindings.cpp
@@ -392,6 +392,9 @@ struct OTnodeBase {
unsigned long long getSize() const {
return LLVMABISizeOfType(TheTargetData, Ref);
}
+ unsigned long long getBitSize() const {
+ return 8 * getSize();
+ }
};
typedef OTnodeBase *OTnode;
@@ -713,11 +716,11 @@ buildDebugRecordElements(OTnodeRecBase *Atype)
unsigned i = 0;
for (OFnodeBase *e : Atype->Els) {
- unsigned off = LLVMOffsetOfElement(TheTargetData, Atype->Ref, i);
+ unsigned bitoff = 8 * LLVMOffsetOfElement(TheTargetData, Atype->Ref, i);
els[i++] = DBuilder->createMemberType
- (DebugCurrentSubprg, StringRef(e->Ident.cstr), DebugCurrentFile,
- DebugCurrentLine, e->FType->getSize(), e->FType->getAlignment(),
- off, DINode::DIFlags::FlagPublic, e->FType->Dbg);
+ (DebugCurrentSubprg, StringRef(e->Ident.cstr), NULL, 0,
+ e->FType->getBitSize(), /* align */ 0,
+ bitoff, DINode::DIFlags::FlagZero, e->FType->Dbg);
}
return DBuilder->getOrCreateArray(els);
@@ -744,24 +747,68 @@ finish_record_type(OElementList *Els, OTnode *Res)
LLVMStructSetBody (Els->RecType->Ref, Types, Els->Count, 0);
Els->RecType->Bounded = Bounded;
T = static_cast<OTnodeRecBase *>(Els->RecType);
+ T->Els = std::move(*Els->Els);
#ifdef USE_DEBUG
if (FlagDebug) {
DICompositeType *Dbg;
Dbg = DBuilder->createStructType
(DebugCurrentSubprg, T->Dbg->getName(), DebugCurrentFile,
- DebugCurrentLine, T->getSize(), T->getAlignment(),
- DINode::DIFlags::FlagPublic, nullptr,
+ DebugCurrentLine, T->getBitSize(), /* Align */ 0,
+ DINode::DIFlags::FlagZero, nullptr,
buildDebugRecordElements(T));
llvm::TempMDNode fwd_decl(T->Dbg);
T->Dbg = DBuilder->replaceTemporary(std::move(fwd_decl), Dbg);
}
#endif
} else {
+ // Non-completion.
+ // Debug info are created when the type is declared.
T = new OTnodeRec(LLVMStructType(Types, Els->Count, 0), Bounded);
+ T->Els = std::move(*Els->Els);
}
+ *Res = T;
+}
+
+struct OElementSublist {
+ // Number of fields.
+ unsigned Count;
+ std::vector<OFnodeBase *> *Base_Els;
+ std::vector<OFnodeBase *> *Els;
+};
+
+extern "C" void
+start_record_subtype (OTnodeRec *Rtype, OElementSublist *Elements)
+{
+ *Elements = {0,
+ &Rtype->Els,
+ new std::vector<OFnodeBase *>()};
+}
+
+extern "C" void
+new_subrecord_field(OElementSublist *Elements,
+ OFnodeRec **El, OTnode Etype)
+{
+ OFnodeBase *Bel = (*Elements->Base_Els)[Elements->Count];
+ *El = new OFnodeRec(Etype, Bel->Ident, Elements->Count);
+ Elements->Els->push_back(*El);
+ Elements->Count++;
+}
+
+extern "C" void
+finish_record_subtype(OElementSublist *Els, OTnode *Res)
+{
+ LLVMTypeRef *Types = new LLVMTypeRef[Els->Count];
+
+ // Create types array for elements.
+ int i = 0;
+ for (OFnodeBase *Field : *Els->Els) {
+ Types[i++] = Field->FType->Ref;
+ }
+
+ OTnodeRecBase *T;
+ T = new OTnodeRec(LLVMStructType(Types, Els->Count, 0), true);
T->Els = std::move(*Els->Els);
*Res = T;
- delete Els->Els;
}
extern "C" void
@@ -895,14 +942,14 @@ new_array_type(OTnode ElType, OTnode IndexType)
}
extern "C" OTnode
-new_constrained_array_type(OTnodeArr *ArrType, OCnode *Length)
+new_array_subtype(OTnodeArr *ArrType, OTnode ElType, OCnode *Length)
{
OTnodeArr *Res;
unsigned Len = LLVMConstIntGetZExtValue(Length->Ref);
- Res = new OTnodeArr(LLVMArrayType(ArrType->ElType->Ref, Len),
- ArrType->ElType->Bounded,
- ArrType->ElType);
+ Res = new OTnodeArr(LLVMArrayType(ElType->Ref, Len),
+ ElType->Bounded,
+ ElType);
#ifdef USE_DEBUG
if (FlagDebug)
@@ -960,14 +1007,14 @@ new_type_decl(OIdent Ident, OTnode Atype)
if (static_cast<OTnodeAccBase*>(Atype)->Acc == nullptr) {
// Still incomplete
Atype->Dbg = DBuilder->createPointerType
- (nullptr, Atype->getSize(), 0, None, StringRef(Ident.cstr));
+ (nullptr, Atype->getBitSize(), 0, None, StringRef(Ident.cstr));
break;
}
// Fallthrough
case OTKAccess:
Atype->Dbg = DBuilder->createPointerType
(static_cast<OTnodeAcc*>(Atype)->Acc->Dbg,
- Atype->getSize(), 0, None, StringRef(Ident.cstr));
+ Atype->getBitSize(), 0, None, StringRef(Ident.cstr));
break;
case OTKArray:
@@ -981,7 +1028,7 @@ new_type_decl(OIdent Ident, OTnode Atype)
case OTKRecord:
Atype->Dbg = DBuilder->createStructType
(DebugCurrentSubprg, StringRef(Ident.cstr), DebugCurrentFile,
- DebugCurrentLine, Atype->getSize(), Atype->getAlignment(),
+ DebugCurrentLine, Atype->getBitSize(), /* align */ 0,
DINode::DIFlags::FlagPublic, nullptr,
buildDebugRecordElements(static_cast<OTnodeRecBase *>(Atype)));
break;
@@ -995,13 +1042,14 @@ new_type_decl(OIdent Ident, OTnode Atype)
for (OFnodeBase *e : static_cast<OTnodeUnion *>(Atype)->Els) {
els[i++] = DBuilder->createMemberType
(DebugCurrentSubprg, StringRef(e->Ident.cstr), DebugCurrentFile,
- DebugCurrentLine, e->FType->getSize(), e->FType->getAlignment(),
- 0, DINode::DIFlags::FlagPublic, e->FType->Dbg);
+ DebugCurrentLine, e->FType->getBitSize(),
+ e->FType->getAlignment(), 0, DINode::DIFlags::FlagPublic,
+ e->FType->Dbg);
}
Atype->Dbg = DBuilder->createUnionType
(DebugCurrentSubprg, StringRef(Ident.cstr), DebugCurrentFile,
- DebugCurrentLine, Atype->getSize(), Atype->getAlignment(),
+ DebugCurrentLine, Atype->getBitSize(), Atype->getAlignment(),
DINode::DIFlags::FlagPublic, DBuilder->getOrCreateArray(els));
}
break;
@@ -1120,6 +1168,12 @@ new_sizeof(OTnode Atype, OTnode Rtype)
return constToConst(Rtype, LLVMABISizeOfType(TheTargetData, Atype->Ref));
}
+extern "C" OCnode
+new_record_sizeof(OTnode Atype, OTnode Rtype)
+{
+ return new_sizeof(Atype, Rtype);
+}
+
extern "C" OCnode
new_alignof(OTnode Atype, OTnode Rtype)
{
diff --git a/src/ortho/llvm6/ortho_llvm.ads b/src/ortho/llvm6/ortho_llvm.ads
index b342140dc..74bae8ed5 100644
--- a/src/ortho/llvm6/ortho_llvm.ads
+++ b/src/ortho/llvm6/ortho_llvm.ads
@@ -98,8 +98,8 @@ package Ortho_LLVM is
-- Build a record type.
procedure Start_Record_Type (Elements : out O_Element_List);
- -- Add a field in the record; not constrained array are prohibited, since
- -- its size is unlimited.
+ -- Add a field in the record. Unconstrained fields must be at the end,
+ -- and cannot be followed by a constrained one.
procedure New_Record_Field
(Elements : in out O_Element_List;
El : out O_Fnode;
@@ -108,6 +108,17 @@ package Ortho_LLVM is
procedure Finish_Record_Type
(Elements : in out O_Element_List; Res : out O_Tnode);
+ type O_Element_Sublist is limited private;
+
+ -- Build a record subtype.
+ -- Re-declare only unconstrained fields with a subtype of them.
+ procedure Start_Record_Subtype
+ (Rtype : O_Tnode; Elements : out O_Element_Sublist);
+ procedure New_Subrecord_Field
+ (Elements : in out O_Element_Sublist; El : out O_Fnode; Etype : O_Tnode);
+ procedure Finish_Record_Subtype
+ (Elements : in out O_Element_Sublist; Res : out O_Tnode);
+
-- Build an uncomplete record type:
-- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
-- This type can be declared or used to define access types on it.
@@ -139,8 +150,8 @@ package Ortho_LLVM is
return O_Tnode;
-- Build a constrained array type.
- function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
- return O_Tnode;
+ function New_Array_Subtype
+ (Atype : O_Tnode; El_Type : O_Tnode; Length : O_Cnode) return O_Tnode;
-- Build a scalar type; size may be 8, 16, 32 or 64.
function New_Unsigned_Type (Size : Natural) return O_Tnode;
@@ -213,9 +224,13 @@ package Ortho_LLVM is
-- Returns the size in bytes of ATYPE. The result is a literal of
-- unsigned type RTYPE
- -- ATYPE cannot be an unconstrained array type.
+ -- ATYPE cannot be an unconstrained type.
function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+ -- Get the size of the bounded part of a record.
+ function New_Record_Sizeof
+ (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
-- Returns the alignment in bytes for ATYPE. The result is a literal of
-- unsgined type RTYPE.
function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
@@ -668,6 +683,14 @@ private
end record;
pragma Convention (C, O_Element_List);
+ type O_Element_Sublist is record
+ -- Number of fields.
+ Count : Natural;
+ Base_Els : O_Element_Vec;
+ Els : O_Element_Vec;
+ end record;
+ pragma Convention (C, O_Element_Sublist);
+
type ValueRefArray_Acc is access Opaque_Type;
pragma Convention (C, ValueRefArray_Acc);
@@ -770,6 +793,10 @@ private
pragma Import (C, New_Uncomplete_Record_Type);
pragma Import (C, Start_Uncomplete_Record_Type);
+ pragma Import (C, Start_Record_Subtype);
+ pragma Import (C, New_Subrecord_Field);
+ pragma Import (C, Finish_Record_Subtype);
+
pragma Import (C, Start_Union_Type);
pragma Import (C, New_Union_Field);
pragma Import (C, Finish_Union_Type);
@@ -782,7 +809,7 @@ private
pragma Import (C, Finish_Access_Type);
pragma Import (C, New_Array_Type);
- pragma Import (C, New_Constrained_Array_Type);
+ pragma Import (C, New_Array_Subtype);
pragma Import (C, New_Boolean_Type);
pragma Import (C, Start_Enum_Type);
@@ -804,6 +831,7 @@ private
pragma Import (C, New_Access_Element);
pragma Import (C, New_Sizeof);
+ pragma Import (C, New_Record_Sizeof);
pragma Import (C, New_Alignof);
pragma Import (C, New_Offsetof);
diff --git a/src/ortho/llvm6/ortho_llvm.private.ads b/src/ortho/llvm6/ortho_llvm.private.ads
index 7a873d8bf..35fdefe0e 100644
--- a/src/ortho/llvm6/ortho_llvm.private.ads
+++ b/src/ortho/llvm6/ortho_llvm.private.ads
@@ -222,6 +222,14 @@ private
end record;
pragma Convention (C, O_Element_List);
+ type O_Element_Sublist is record
+ -- Number of fields.
+ Count : Natural;
+ Base_Els : O_Element_Vec;
+ Els : O_Element_Vec;
+ end record;
+ pragma Convention (C, O_Element_Sublist);
+
type ValueRefArray_Acc is access Opaque_Type;
pragma Convention (C, ValueRefArray_Acc);
@@ -324,6 +332,10 @@ private
pragma Import (C, New_Uncomplete_Record_Type);
pragma Import (C, Start_Uncomplete_Record_Type);
+ pragma Import (C, Start_Record_Subtype);
+ pragma Import (C, New_Subrecord_Field);
+ pragma Import (C, Finish_Record_Subtype);
+
pragma Import (C, Start_Union_Type);
pragma Import (C, New_Union_Field);
pragma Import (C, Finish_Union_Type);
@@ -336,7 +348,7 @@ private
pragma Import (C, Finish_Access_Type);
pragma Import (C, New_Array_Type);
- pragma Import (C, New_Constrained_Array_Type);
+ pragma Import (C, New_Array_Subtype);
pragma Import (C, New_Boolean_Type);
pragma Import (C, Start_Enum_Type);
@@ -358,6 +370,7 @@ private
pragma Import (C, New_Access_Element);
pragma Import (C, New_Sizeof);
+ pragma Import (C, New_Record_Sizeof);
pragma Import (C, New_Alignof);
pragma Import (C, New_Offsetof);
diff --git a/src/ortho/mcode/ortho_code-consts.adb b/src/ortho/mcode/ortho_code-consts.adb
index dcb9c13be..c83b98459 100644
--- a/src/ortho/mcode/ortho_code-consts.adb
+++ b/src/ortho/mcode/ortho_code-consts.adb
@@ -507,11 +507,11 @@ package body Ortho_Code.Consts is
return To_Cnode_Union (Cnodes.Table (Cst + 1)).El;
end Get_Const_Union_Value;
+ function To_Cnode_Common is new Ada.Unchecked_Conversion
+ (Source => Cnode_Sizeof, Target => Cnode_Common);
+
function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
is
- function To_Cnode_Common is new Ada.Unchecked_Conversion
- (Source => Cnode_Sizeof, Target => Cnode_Common);
-
Res : O_Cnode;
begin
if Debug.Flag_Debug_Hli then
@@ -527,6 +527,24 @@ package body Ortho_Code.Consts is
end if;
end New_Sizeof;
+ function New_Record_Sizeof
+ (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode
+ is
+ Res : O_Cnode;
+ begin
+ if Debug.Flag_Debug_Hli then
+ Cnodes.Append (Cnode_Common'(Kind => OC_Record_Sizeof,
+ Lit_Type => Rtype));
+ Res := Cnodes.Last;
+ Cnodes.Append (To_Cnode_Common (Cnode_Sizeof'(Atype => Atype,
+ Pad => 0)));
+ return Res;
+ else
+ return New_Unsigned_Literal
+ (Rtype, Unsigned_64 (Get_Type_Record_Size (Atype)));
+ end if;
+ end New_Record_Sizeof;
+
function Get_Sizeof_Type (Cst : O_Cnode) return O_Tnode
is
function To_Cnode_Sizeof is new Ada.Unchecked_Conversion
@@ -645,8 +663,8 @@ package body Ortho_Code.Consts is
begin
case Get_Const_Kind (Cst) is
when OC_Signed
- | OC_Unsigned
- | OC_Float =>
+ | OC_Unsigned
+ | OC_Float =>
H := Get_Const_High (Cst);
L := Get_Const_Low (Cst);
when OC_Null =>
@@ -656,13 +674,14 @@ package body Ortho_Code.Consts is
H := 0;
L := To_Cnode_Enum (Cnodes.Table (Cst + 1)).Val;
when OC_Array
- | OC_Record
- | OC_Union
- | OC_Sizeof
- | OC_Alignof
- | OC_Address
- | OC_Subprg_Address
- | OC_Zero =>
+ | OC_Record
+ | OC_Union
+ | OC_Sizeof
+ | OC_Record_Sizeof
+ | OC_Alignof
+ | OC_Address
+ | OC_Subprg_Address
+ | OC_Zero =>
raise Syntax_Error;
end case;
end Get_Const_Bytes;
diff --git a/src/ortho/mcode/ortho_code-consts.ads b/src/ortho/mcode/ortho_code-consts.ads
index f49dbb315..05ff4389e 100644
--- a/src/ortho/mcode/ortho_code-consts.ads
+++ b/src/ortho/mcode/ortho_code-consts.ads
@@ -22,7 +22,7 @@ package Ortho_Code.Consts is
OC_Zero,
OC_Array, OC_Record, OC_Union,
OC_Subprg_Address, OC_Address,
- OC_Sizeof, OC_Alignof);
+ OC_Sizeof, OC_Record_Sizeof, OC_Alignof);
type OG_Kind is (OG_Decl, OG_Record_Ref);
@@ -140,6 +140,8 @@ package Ortho_Code.Consts is
-- unsigned type RTYPE
-- ATYPE cannot be an unconstrained array type.
function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+ function New_Record_Sizeof
+ (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
-- Returns the alignment in bytes for ATYPE. The result is a literal of
-- unsgined type RTYPE.
diff --git a/src/ortho/mcode/ortho_code-disps.adb b/src/ortho/mcode/ortho_code-disps.adb
index 45507a52e..8195f675d 100644
--- a/src/ortho/mcode/ortho_code-disps.adb
+++ b/src/ortho/mcode/ortho_code-disps.adb
@@ -400,10 +400,20 @@ package body Ortho_Code.Disps is
Put ("[");
Put_Trim (Uns32'Image (Get_Type_Subarray_Length (Atype)));
Put ("]");
+ Put (" ");
+ Put ("of");
+ Put (" ");
+ Disp_Type (Get_Type_Subarray_Element (Atype));
when OT_Record =>
Put_Line ("record");
Disp_Fields (1, Atype);
Put ("end record");
+ when OT_Subrecord =>
+ Put_Line ("subrecord");
+ Disp_Type (Get_Type_Subrecord_Base (Atype));
+ Put ("(");
+ Disp_Fields (1, Atype);
+ Put (")");
when OT_Union =>
Put_Line ("union");
Disp_Fields (1, Atype);
diff --git a/src/ortho/mcode/ortho_code-dwarf.adb b/src/ortho/mcode/ortho_code-dwarf.adb
index 0275b870f..31acadd0f 100644
--- a/src/ortho/mcode/ortho_code-dwarf.adb
+++ b/src/ortho/mcode/ortho_code-dwarf.adb
@@ -674,10 +674,9 @@ package body Ortho_Code.Dwarf is
end if;
end Emit_Access_Type;
- procedure Emit_Ucarray_Type (Atype : O_Tnode; Decl : O_Dnode)
+ procedure Emit_Array_Type
+ (Decl : O_Dnode; El_Type : O_Tnode; Idx_Type : O_Tnode)
is
- use Ortho_Code.Types;
-
procedure Finish_Gen_Abbrev is
begin
Gen_Abbrev_Tuple (DW_AT_Type, DW_FORM_Ref4);
@@ -701,7 +700,7 @@ package body Ortho_Code.Dwarf is
Gen_Info_Header (Abbrev_Ucarray_Name);
Emit_Decl_Ident (Decl);
end if;
- Emit_Type_Ref (Get_Type_Ucarray_Element (Atype));
+ Emit_Type_Ref (El_Type);
if Abbrev_Uc_Subrange = 0 then
Generate_Abbrev (Abbrev_Uc_Subrange);
@@ -712,9 +711,18 @@ package body Ortho_Code.Dwarf is
end if;
Gen_Info_Header (Abbrev_Uc_Subrange);
- Emit_Type_Ref (Get_Type_Ucarray_Index (Atype));
+ Emit_Type_Ref (Idx_Type);
Gen_Uleb128 (0);
+ end Emit_Array_Type;
+
+ procedure Emit_Ucarray_Type (Atype : O_Tnode; Decl : O_Dnode)
+ is
+ use Ortho_Code.Types;
+ begin
+ Emit_Array_Type (Decl,
+ Get_Type_Ucarray_Element (Atype),
+ Get_Type_Ucarray_Index (Atype));
end Emit_Ucarray_Type;
procedure Emit_Subarray_Type (Atype : O_Tnode; Decl : O_Dnode)
@@ -747,9 +755,8 @@ package body Ortho_Code.Dwarf is
Emit_Decl_Ident (Decl);
end if;
- Base := Get_Type_Subarray_Base (Atype);
- Emit_Type_Ref (Get_Type_Ucarray_Element (Base));
+ Emit_Type_Ref (Get_Type_Subarray_Element (Atype));
Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype)));
if Abbrev_Subrange = 0 then
@@ -763,6 +770,7 @@ package body Ortho_Code.Dwarf is
end if;
Gen_Info_Header (Abbrev_Subrange);
+ Base := Get_Type_Subarray_Base (Atype);
Emit_Type_Ref (Get_Type_Ucarray_Index (Base));
Gen_8 (0);
Gen_Uleb128 (Unsigned_32 (Get_Type_Subarray_Length (Atype)));
@@ -777,6 +785,7 @@ package body Ortho_Code.Dwarf is
F : O_Fnode;
Loc_Pc : Pc_Type;
Sibling_Pc : Pc_Type;
+ Sz : Uns32;
begin
if Abbrev_Member = 0 then
Generate_Abbrev (Abbrev_Member);
@@ -792,7 +801,12 @@ package body Ortho_Code.Dwarf is
Set_Current_Section (Info_Sect);
Sibling_Pc := Gen_Info_Sibling;
Emit_Decl_Ident_If_Set (Decl);
- Gen_Uleb128 (Unsigned_32 (Get_Type_Size (Atype)));
+ if Get_Type_Sized (Atype) then
+ Sz := Get_Type_Size (Atype);
+ else
+ Sz := Get_Type_Record_Size (Atype);
+ end if;
+ Gen_Uleb128 (Unsigned_32 (Sz));
Nbr := Get_Type_Record_Nbr_Fields (Atype);
F := Get_Type_Record_Fields (Atype);
@@ -975,10 +989,10 @@ package body Ortho_Code.Dwarf is
-- First step: emit inner types (if any).
case Kind is
when OT_Signed
- | OT_Unsigned
- | OT_Float
- | OT_Boolean
- | OT_Enum =>
+ | OT_Unsigned
+ | OT_Float
+ | OT_Boolean
+ | OT_Enum =>
null;
when OT_Access =>
null;
@@ -988,7 +1002,8 @@ package body Ortho_Code.Dwarf is
when OT_Subarray =>
Emit_Type (Get_Type_Subarray_Base (Atype));
when OT_Record
- | OT_Union =>
+ | OT_Subrecord
+ | OT_Union =>
declare
Nbr : Uns32;
F : O_Fnode;
@@ -1013,8 +1028,8 @@ package body Ortho_Code.Dwarf is
-- Second step: emit info.
case Kind is
when OT_Signed
- | OT_Unsigned
- | OT_Float =>
+ | OT_Unsigned
+ | OT_Float =>
Emit_Base_Type (Atype, Decl);
-- base types.
when OT_Access =>
@@ -1023,12 +1038,13 @@ package body Ortho_Code.Dwarf is
Emit_Ucarray_Type (Atype, Decl);
when OT_Subarray =>
Emit_Subarray_Type (Atype, Decl);
- when OT_Record =>
+ when OT_Record
+ | OT_Subrecord =>
Emit_Record_Type (Atype, Decl);
when OT_Union =>
Emit_Union_Type (Atype, Decl);
when OT_Enum
- | OT_Boolean =>
+ | OT_Boolean =>
Emit_Enum_Type (Atype, Decl);
when OT_Complete =>
null;
diff --git a/src/ortho/mcode/ortho_code-exprs.adb b/src/ortho/mcode/ortho_code-exprs.adb
index e580082c7..619f124a6 100644
--- a/src/ortho/mcode/ortho_code-exprs.adb
+++ b/src/ortho/mcode/ortho_code-exprs.adb
@@ -708,10 +708,10 @@ package body Ortho_Code.Exprs is
else
case Get_Const_Kind (Lit) is
when OC_Signed
- | OC_Unsigned
- | OC_Float
- | OC_Null
- | OC_Lit =>
+ | OC_Unsigned
+ | OC_Float
+ | OC_Null
+ | OC_Lit =>
declare
H, L : Uns32;
begin
@@ -726,11 +726,12 @@ package body Ortho_Code.Exprs is
return New_Enode (OE_Addrd, L_Type,
O_Enode (Get_Const_Decl (Lit)), O_Enode_Null);
when OC_Array
- | OC_Record
- | OC_Union
- | OC_Sizeof
- | OC_Alignof
- | OC_Zero =>
+ | OC_Record
+ | OC_Record_Sizeof
+ | OC_Union
+ | OC_Sizeof
+ | OC_Alignof
+ | OC_Zero =>
raise Syntax_Error;
end case;
end if;
diff --git a/src/ortho/mcode/ortho_code-types.adb b/src/ortho/mcode/ortho_code-types.adb
index 177c1ec99..5cd17f0d1 100644
--- a/src/ortho/mcode/ortho_code-types.adb
+++ b/src/ortho/mcode/ortho_code-types.adb
@@ -32,8 +32,9 @@ package body Ortho_Code.Types is
Mode : Mode_Type; -- 4 bits.
Align : Small_Natural; -- 2 bits.
Deferred : Boolean; -- 1 bit (True if the type was incomplete at first)
+ Sized : Boolean; -- 1 bit (True if the type has a size, is constrained)
Flag1 : Boolean;
- Pad0 : Bool_Array (0 .. 19);
+ Pad0 : Bool_Array (0 .. 18);
Size : Uns32;
end record;
pragma Pack (Tnode_Common);
@@ -49,7 +50,7 @@ package body Ortho_Code.Types is
Index_Type : O_Tnode;
end record;
- type Tnode_Subarray is record
+ type Tnode_Subarray_2 is record
Base_Type : O_Tnode;
Length : Uns32;
end record;
@@ -59,6 +60,11 @@ package body Ortho_Code.Types is
Nbr_Fields : Uns32;
end record;
+ type Tnode_Subrecord_2 is record
+ Base_Type : O_Tnode;
+ Pad : Uns32;
+ end record;
+
type Tnode_Enum is record
Lits : O_Cnode;
Nbr_Lits : Uns32;
@@ -94,12 +100,28 @@ package body Ortho_Code.Types is
return Tnodes.Table (Atype).Kind;
end Get_Type_Kind;
+ function Get_Type_Sized (Atype : O_Tnode) return Boolean is
+ begin
+ return Tnodes.Table (Atype).Sized;
+ end Get_Type_Sized;
+
+ procedure Set_Type_Sized (Atype : O_Tnode; Sized : Boolean) is
+ begin
+ Tnodes.Table (Atype).Sized := Sized;
+ end Set_Type_Sized;
+
function Get_Type_Size (Atype : O_Tnode) return Uns32 is
begin
- pragma Assert (Get_Type_Kind (Atype) /= OT_Ucarray);
+ pragma Assert (Get_Type_Sized (Atype));
return Tnodes.Table (Atype).Size;
end Get_Type_Size;
+ function Get_Type_Record_Size (Atype : O_Tnode) return Uns32 is
+ begin
+ pragma Assert (Get_Type_Kind (Atype) = OT_Record);
+ return Tnodes.Table (Atype).Size;
+ end Get_Type_Record_Size;
+
function Get_Type_Align (Atype : O_Tnode) return Small_Natural is
begin
return Tnodes.Table (Atype).Align;
@@ -154,20 +176,26 @@ package body Ortho_Code.Types is
end Get_Type_Ucarray_Element;
- function To_Tnode_Subarray is new Ada.Unchecked_Conversion
- (Source => Tnode_Common, Target => Tnode_Subarray);
+ function To_Tnode_Subarray_2 is new Ada.Unchecked_Conversion
+ (Source => Tnode_Common, Target => Tnode_Subarray_2);
function Get_Type_Subarray_Base (Atype : O_Tnode) return O_Tnode is
begin
- return To_Tnode_Subarray (Tnodes.Table (Atype + 1)).Base_Type;
+ return To_Tnode_Subarray_2 (Tnodes.Table (Atype + 2)).Base_Type;
end Get_Type_Subarray_Base;
function Get_Type_Subarray_Length (Atype : O_Tnode) return Uns32 is
begin
- return To_Tnode_Subarray (Tnodes.Table (Atype + 1)).Length;
+ return To_Tnode_Subarray_2 (Tnodes.Table (Atype + 2)).Length;
end Get_Type_Subarray_Length;
+ function Get_Type_Subarray_Element (Atype : O_Tnode) return O_Tnode is
+ begin
+ return To_Tnode_Array (Tnodes.Table (Atype + 1)).Element_Type;
+ end Get_Type_Subarray_Element;
+
+
function To_Tnode_Record is new Ada.Unchecked_Conversion
(Source => Tnode_Common, Target => Tnode_Record);
@@ -181,6 +209,14 @@ package body Ortho_Code.Types is
return To_Tnode_Record (Tnodes.Table (Atype + 1)).Nbr_Fields;
end Get_Type_Record_Nbr_Fields;
+ function To_Tnode_Subrecord_2 is new Ada.Unchecked_Conversion
+ (Source => Tnode_Common, Target => Tnode_Subrecord_2);
+
+ function Get_Type_Subrecord_Base (Atype : O_Tnode) return O_Tnode is
+ begin
+ return To_Tnode_Subrecord_2 (Tnodes.Table (Atype + 2)).Base_Type;
+ end Get_Type_Subrecord_Base;
+
function To_Tnode_Enum is new Ada.Unchecked_Conversion
(Source => Tnode_Common, Target => Tnode_Enum);
@@ -271,6 +307,7 @@ package body Ortho_Code.Types is
Mode => Mode,
Align => Mode_Align (Mode),
Deferred => False,
+ Sized => True,
Flag1 => False,
Pad0 => (others => False),
Size => Sz));
@@ -302,6 +339,7 @@ package body Ortho_Code.Types is
Mode => Mode,
Align => Mode_Align (Mode),
Deferred => False,
+ Sized => True,
Flag1 => False,
Pad0 => (others => False),
Size => Sz));
@@ -314,6 +352,7 @@ package body Ortho_Code.Types is
Mode => Mode_F64,
Align => Mode_Align (Mode_F64),
Deferred => False,
+ Sized => True,
Flag1 => False,
Pad0 => (others => False),
Size => 8));
@@ -348,6 +387,7 @@ package body Ortho_Code.Types is
Mode => Mode,
Align => Mode_Align (Mode),
Deferred => False,
+ Sized => True,
Flag1 => False,
Pad0 => (others => False),
Size => Sz));
@@ -393,6 +433,7 @@ package body Ortho_Code.Types is
Mode => Mode_B2,
Align => 0,
Deferred => False,
+ Sized => True,
Flag1 => False,
Pad0 => (others => False),
Size => 1));
@@ -415,6 +456,7 @@ package body Ortho_Code.Types is
Mode => Mode_Blk,
Align => Get_Type_Align (El_Type),
Deferred => False,
+ Sized => False,
Flag1 => False,
Pad0 => (others => False),
Size => 0));
@@ -425,27 +467,32 @@ package body Ortho_Code.Types is
end New_Array_Type;
function To_Tnode_Common is new Ada.Unchecked_Conversion
- (Source => Tnode_Subarray, Target => Tnode_Common);
+ (Source => Tnode_Subarray_2, Target => Tnode_Common);
- function New_Constrained_Array_Type (Atype : O_Tnode; Length : Uns32)
- return O_Tnode
+ function New_Array_Subtype
+ (Atype : O_Tnode; El_Type : O_Tnode; Length : Uns32) return O_Tnode
is
Res : O_Tnode;
Size : Uns32;
begin
- Size := Get_Type_Size (Get_Type_Array_Element (Atype));
+ Size := Get_Type_Size (El_Type);
Tnodes.Append (Tnode_Common'(Kind => OT_Subarray,
Mode => Mode_Blk,
Align => Get_Type_Align (Atype),
Deferred => False,
+ Sized => True,
Flag1 => False,
Pad0 => (others => False),
Size => Size * Length));
Res := Tnodes.Last;
- Tnodes.Append (To_Tnode_Common (Tnode_Subarray'(Base_Type => Atype,
- Length => Length)));
+ Tnodes.Append (To_Tnode_Common
+ (Tnode_Array'(Element_Type => El_Type,
+ Index_Type => O_Tnode_Null)));
+ Tnodes.Append (To_Tnode_Common
+ (Tnode_Subarray_2'(Base_Type => Atype,
+ Length => Length)));
return Res;
- end New_Constrained_Array_Type;
+ end New_Array_Subtype;
procedure Create_Completer (Atype : O_Tnode) is
begin
@@ -453,6 +500,7 @@ package body Ortho_Code.Types is
Mode => Mode_Nil,
Align => 0,
Deferred => False,
+ Sized => False,
Flag1 => False,
Pad0 => (others => False),
Size => To_Uns32 (Int32 (Atype))));
@@ -476,6 +524,7 @@ package body Ortho_Code.Types is
Mode => Mode_Ptr,
Align => Mode_Align (Mode_Ptr),
Deferred => Dtype = O_Tnode_Null,
+ Sized => True,
Flag1 => False,
Pad0 => (others => False),
Size => Sz));
@@ -502,6 +551,9 @@ package body Ortho_Code.Types is
function To_Tnode_Common is new Ada.Unchecked_Conversion
(Source => Tnode_Record, Target => Tnode_Common);
+ function To_Tnode_Common is new Ada.Unchecked_Conversion
+ (Source => Tnode_Subrecord_2, Target => Tnode_Common);
+
function Create_Record_Type (Deferred : Boolean) return O_Tnode
is
Res : O_Tnode;
@@ -510,6 +562,7 @@ package body Ortho_Code.Types is
Mode => Mode_Blk,
Align => 0,
Deferred => Deferred,
+ Sized => True,
Flag1 => False,
Pad0 => (others => False),
Size => 0));
@@ -519,17 +572,6 @@ package body Ortho_Code.Types is
return Res;
end Create_Record_Type;
- procedure Start_Record_Type (Elements : out O_Element_List)
- is
- begin
- Elements := (Res => Create_Record_Type (False),
- First_Field => O_Fnode_Null,
- Last_Field => O_Fnode_Null,
- Off => 0,
- Align => 0,
- Nbr => 0);
- end Start_Record_Type;
-
procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
begin
Res := Create_Record_Type (True);
@@ -544,7 +586,8 @@ package body Ortho_Code.Types is
Last_Field => O_Fnode_Null,
Off => 0,
Align => 0,
- Nbr => 0);
+ Nbr => 0,
+ Base_Field => O_Fnode_Null);
end Start_Uncomplete_Record_Type;
function Get_Mode_Size (Mode : Mode_Type) return Uns32 is
@@ -590,12 +633,10 @@ package body Ortho_Code.Types is
return (Off + Msk) and (not Msk);
end Do_Align;
- procedure New_Record_Field
- (Elements : in out O_Element_List;
- El : out O_Fnode;
- Ident : O_Ident;
- Etype : O_Tnode)
- is
+ procedure Append_Field (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode) is
begin
Elements.Off := Do_Align (Elements.Off, Etype);
@@ -605,7 +646,11 @@ package body Ortho_Code.Types is
Offset => Elements.Off,
Next => O_Fnode_Null));
El := Fnodes.Last;
- Elements.Off := Elements.Off + Get_Type_Size (Etype);
+ if Get_Type_Sized (Etype) then
+ Elements.Off := Elements.Off + Get_Type_Size (Etype);
+ else
+ Set_Type_Sized (Elements.Res, False);
+ end if;
if Get_Type_Align (Etype) > Elements.Align then
Elements.Align := Get_Type_Align (Etype);
end if;
@@ -615,12 +660,35 @@ package body Ortho_Code.Types is
Elements.First_Field := Fnodes.Last;
end if;
Elements.Last_Field := Fnodes.Last;
+ end Append_Field;
+
+ procedure Start_Record_Type (Elements : out O_Element_List) is
+ begin
+ Elements := (Res => Create_Record_Type (False),
+ First_Field => O_Fnode_Null,
+ Last_Field => O_Fnode_Null,
+ Off => 0,
+ Align => 0,
+ Nbr => 0,
+ Base_Field => O_Fnode_Null);
+ end Start_Record_Type;
+
+ procedure New_Record_Field (Elements : in out O_Element_List;
+ El : out O_Fnode;
+ Ident : O_Ident;
+ Etype : O_Tnode) is
+ begin
+ if Get_Type_Sized (Etype) then
+ -- Cannot append bounded elements after unbounded onces.
+ pragma Assert (Get_Type_Sized (Elements.Res));
+ null;
+ end if;
+
+ Append_Field (Elements, El, Ident, Etype);
Elements.Nbr := Elements.Nbr + 1;
end New_Record_Field;
- procedure Finish_Record_Type
- (Elements : in out O_Element_List; Res : out O_Tnode)
- is
+ procedure Finish_Record (Elements : O_Element_List) is
begin
Tnodes.Table (Elements.Res).Align := Elements.Align;
Tnodes.Table (Elements.Res).Size := Do_Align (Elements.Off,
@@ -628,6 +696,12 @@ package body Ortho_Code.Types is
Tnodes.Table (Elements.Res + 1) := To_Tnode_Common
(Tnode_Record'(Fields => Elements.First_Field,
Nbr_Fields => Elements.Nbr));
+ end Finish_Record;
+
+ procedure Finish_Record_Type
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ Finish_Record (Elements);
Res := Elements.Res;
if Flag_Type_Completer
and then Tnodes.Table (Elements.Res).Deferred
@@ -636,6 +710,71 @@ package body Ortho_Code.Types is
end if;
end Finish_Record_Type;
+ procedure Start_Record_Subtype
+ (Rtype : O_Tnode; Elements : out O_Element_List)
+ is
+ Res : O_Tnode;
+ Nbr : Uns32;
+ begin
+ pragma Assert (Get_Type_Kind (Rtype) = OT_Record);
+ Nbr := Get_Type_Record_Nbr_Fields (Rtype);
+
+ Tnodes.Append (Tnode_Common'(Kind => OT_Subrecord,
+ Mode => Mode_Blk,
+ Align => 0,
+ Deferred => False,
+ Sized => True,
+ Flag1 => False,
+ Pad0 => (others => False),
+ Size => 0));
+ Res := Tnodes.Last;
+ Tnodes.Append (To_Tnode_Common (Tnode_Record'(Fields => O_Fnode_Null,
+ Nbr_Fields => Nbr)));
+ Tnodes.Append (To_Tnode_Common (Tnode_Subrecord_2'(Base_Type => Rtype,
+ Pad => 0)));
+ Elements := (Res => Res,
+ First_Field => O_Fnode_Null,
+ Last_Field => O_Fnode_Null,
+ Off => 0,
+ Align => 0,
+ Nbr => Nbr,
+ Base_Field => Get_Type_Record_Fields (Rtype));
+ end Start_Record_Subtype;
+
+ procedure New_Subrecord_Field
+ (Elements : in out O_Element_List; El : out O_Fnode; Etype : O_Tnode)
+ is
+ Base_Type : O_Tnode;
+ begin
+ pragma Assert (Elements.Nbr > 0);
+ Elements.Nbr := Elements.Nbr - 1;
+
+ Base_Type := Get_Field_Type (Elements.Base_Field);
+ if Get_Type_Sized (Base_Type) then
+ -- For bounded elements, the type must be the same.
+ pragma Assert (Etype = Base_Type);
+ null;
+ else
+ -- For unbounded elements, those from the subtype must be bounded.
+ pragma Assert (Get_Base_Type (Etype) = Base_Type);
+ pragma Assert (Get_Type_Sized (Etype));
+ null;
+ end if;
+
+ Append_Field (Elements,
+ El, Get_Field_Ident (Elements.Base_Field), Etype);
+ Elements.Base_Field := Get_Field_Chain (Elements.Base_Field);
+ end New_Subrecord_Field;
+
+ procedure Finish_Record_Subtype
+ (Elements : in out O_Element_List; Res : out O_Tnode) is
+ begin
+ Elements.Nbr := Get_Type_Record_Nbr_Fields (Elements.Res);
+ Finish_Record (Elements);
+ Res := Elements.Res;
+ end Finish_Record_Subtype;
+
+
procedure Start_Union_Type (Elements : out O_Element_List)
is
begin
@@ -643,6 +782,7 @@ package body Ortho_Code.Types is
Mode => Mode_Blk,
Align => 0,
Deferred => False,
+ Sized => True,
Flag1 => False,
Pad0 => (others => False),
Size => 0));
@@ -651,7 +791,8 @@ package body Ortho_Code.Types is
Last_Field => O_Fnode_Null,
Off => 0,
Align => 0,
- Nbr => 0);
+ Nbr => 0,
+ Base_Field => O_Fnode_Null);
Tnodes.Append (To_Tnode_Common (Tnode_Record'(Fields => O_Fnode_Null,
Nbr_Fields => 0)));
end Start_Union_Type;
@@ -679,22 +820,19 @@ package body Ortho_Code.Types is
Finish_Record_Type (Elements, Res);
end Finish_Union_Type;
- function Get_Type_Array_Element (Atype : O_Tnode) return O_Tnode
- is
- Base : O_Tnode;
+ function Get_Type_Array_Element (Atype : O_Tnode) return O_Tnode is
begin
case Get_Type_Kind (Atype) is
when OT_Ucarray =>
- Base := Atype;
+ return Get_Type_Ucarray_Element (Atype);
when OT_Subarray =>
- Base := Get_Type_Subarray_Base (Atype);
+ return Get_Type_Subarray_Element (Atype);
when others =>
raise Program_Error;
end case;
- return Get_Type_Ucarray_Element (Base);
end Get_Type_Array_Element;
- procedure Debug_Type (Atype : O_Tnode)
+ procedure Dump_Tnode (Atype : O_Tnode)
is
use Ortho_Code.Debug.Int32_IO;
use Ada.Text_IO;
@@ -733,13 +871,15 @@ package body Ortho_Code.Types is
Put (Int32 (Get_Type_Subarray_Base (Atype)));
Put (", length: ");
Put (To_Int32 (Get_Type_Subarray_Length (Atype)));
+ Put (", el_type: ");
+ Put (Int32 (Get_Type_Subarray_Element (Atype)));
New_Line;
when others =>
null;
end case;
- end Debug_Type;
+ end Dump_Tnode;
- procedure Debug_Field (Field : O_Fnode)
+ procedure Dump_Fnode (Field : O_Fnode)
is
use Ortho_Code.Debug.Int32_IO;
use Ada.Text_IO;
@@ -755,7 +895,7 @@ package body Ortho_Code.Types is
Put (", Chain=");
Put (Int32 (Get_Field_Chain (Field)), 0);
New_Line;
- end Debug_Field;
+ end Dump_Fnode;
function Get_Type_Limit return O_Tnode is
begin
@@ -766,28 +906,31 @@ package body Ortho_Code.Types is
begin
case Tnodes.Table (Atype).Kind is
when OT_Unsigned
- | OT_Signed
- | OT_Float =>
+ | OT_Signed
+ | OT_Float =>
return Atype + 1;
when OT_Boolean
- | OT_Enum
- | OT_Ucarray
- | OT_Subarray
- | OT_Access
- | OT_Record
- | OT_Union =>
+ | OT_Enum
+ | OT_Ucarray
+ | OT_Access
+ | OT_Record
+ | OT_Union =>
return Atype + 2;
+ when OT_Subarray
+ | OT_Subrecord =>
+ return Atype + 3;
when OT_Complete =>
return Atype + 1;
end case;
end Get_Type_Next;
- function Get_Base_Type (Atype : O_Tnode) return O_Tnode
- is
+ function Get_Base_Type (Atype : O_Tnode) return O_Tnode is
begin
case Get_Type_Kind (Atype) is
when OT_Subarray =>
return Get_Type_Subarray_Base (Atype);
+ when OT_Subrecord =>
+ return Get_Type_Subrecord_Base (Atype);
when others =>
return Atype;
end case;
diff --git a/src/ortho/mcode/ortho_code-types.ads b/src/ortho/mcode/ortho_code-types.ads
index a9d15b60a..1fd336ebd 100644
--- a/src/ortho/mcode/ortho_code-types.ads
+++ b/src/ortho/mcode/ortho_code-types.ads
@@ -17,8 +17,10 @@
-- 02111-1307, USA.
package Ortho_Code.Types is
type OT_Kind is (OT_Unsigned, OT_Signed, OT_Boolean, OT_Enum, OT_Float,
- OT_Ucarray, OT_Subarray, OT_Access,
- OT_Record, OT_Union,
+ OT_Ucarray, OT_Subarray,
+ OT_Access,
+ OT_Record, OT_Subrecord,
+ OT_Union,
-- Type completion. Mark the completion of a type.
-- Optionnal.
@@ -32,6 +34,9 @@ package Ortho_Code.Types is
-- Number of bytes of type ATYPE.
function Get_Type_Size (Atype : O_Tnode) return Uns32;
+ -- True if ATYPE is bounded (and therefore its size is valid).
+ function Get_Type_Sized (Atype : O_Tnode) return Boolean;
+
-- Same as Get_Type_Size but for modes.
-- Returns 0 in case of error.
function Get_Mode_Size (Mode : Mode_Type) return Uns32;
@@ -75,12 +80,21 @@ package Ortho_Code.Types is
-- Get number of element for array type ATYPE.
function Get_Type_Subarray_Length (Atype : O_Tnode) return Uns32;
+ -- Get the element type of subarray type ATYPE.
+ function Get_Type_Subarray_Element (Atype : O_Tnode) return O_Tnode;
+
+ -- Get the size of the bounded part of ATYPE.
+ function Get_Type_Record_Size (Atype : O_Tnode) return Uns32;
+
-- Get the first field of record/union ATYPE.
function Get_Type_Record_Fields (Atype : O_Tnode) return O_Fnode;
-- Get the number of fields of record/union ATYPE.
function Get_Type_Record_Nbr_Fields (Atype : O_Tnode) return Uns32;
+ -- Get the base type of subrecord ATYPE.
+ function Get_Type_Subrecord_Base (Atype : O_Tnode) return O_Tnode;
+
-- Get the first literal of enum type ATYPE.
function Get_Type_Enum_Lits (Atype : O_Tnode) return O_Cnode;
@@ -148,11 +162,11 @@ package Ortho_Code.Types is
-- Build an array type.
-- The array is not constrained and unidimensional.
function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode)
- return O_Tnode;
+ return O_Tnode;
-- Build a constrained array type.
- function New_Constrained_Array_Type (Atype : O_Tnode; Length : Uns32)
- return O_Tnode;
+ function New_Array_Subtype
+ (Atype : O_Tnode; El_Type : O_Tnode; Length : Uns32) return O_Tnode;
-- Return the base type of ATYPE: for a subarray this is the uc array,
-- otherwise this is the type.
@@ -172,6 +186,14 @@ package Ortho_Code.Types is
procedure Finish_Record_Type
(Elements : in out O_Element_List; Res : out O_Tnode);
+ -- Record subtype.
+ procedure Start_Record_Subtype
+ (Rtype : O_Tnode; Elements : out O_Element_List);
+ procedure New_Subrecord_Field
+ (Elements : in out O_Element_List; El : out O_Fnode; Etype : O_Tnode);
+ procedure Finish_Record_Subtype
+ (Elements : in out O_Element_List; Res : out O_Tnode);
+
-- Build an uncomplete record type:
-- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
-- This type can be declared or used to define access types on it.
@@ -214,23 +236,25 @@ package Ortho_Code.Types is
procedure Mark (M : out Mark_Type);
procedure Release (M : Mark_Type);
- procedure Debug_Type (Atype : O_Tnode);
- procedure Debug_Field (Field : O_Fnode);
+ procedure Dump_Tnode (Atype : O_Tnode);
+ procedure Dump_Fnode (Field : O_Fnode);
private
type O_Enum_List is record
- Res : O_Tnode;
+ Res : O_Tnode;
First : O_Cnode;
- Last : O_Cnode;
- Nbr : Uns32;
+ Last : O_Cnode;
+ Nbr : Uns32;
end record;
type O_Element_List is record
- Res : O_Tnode;
- Nbr : Uns32;
- Off : Uns32;
- Align : Small_Natural;
+ Res : O_Tnode;
+ Nbr : Uns32;
+ Off : Uns32;
+ Align : Small_Natural;
First_Field : O_Fnode;
- Last_Field : O_Fnode;
+ Last_Field : O_Fnode;
+ -- For subrecords
+ Base_Field : O_Fnode;
end record;
type Mark_Type is record
diff --git a/src/ortho/mcode/ortho_code-x86-emits.adb b/src/ortho/mcode/ortho_code-x86-emits.adb
index 91db6b54d..f55793eec 100644
--- a/src/ortho/mcode/ortho_code-x86-emits.adb
+++ b/src/ortho/mcode/ortho_code-x86-emits.adb
@@ -3163,10 +3163,10 @@ package body Ortho_Code.X86.Emits is
begin
case Get_Const_Kind (Val) is
when OC_Signed
- | OC_Unsigned
- | OC_Float
- | OC_Null
- | OC_Lit =>
+ | OC_Unsigned
+ | OC_Float
+ | OC_Null
+ | OC_Lit =>
Get_Const_Bytes (Val, H, L);
case Get_Type_Mode (Get_Const_Type (Val)) is
when Mode_U8
@@ -3216,8 +3216,9 @@ package body Ortho_Code.X86.Emits is
Gen_8 (0);
end loop;
when OC_Sizeof
- | OC_Alignof
- | OC_Union =>
+ | OC_Record_Sizeof
+ | OC_Alignof
+ | OC_Union =>
raise Program_Error;
end case;
end Emit_Const;
diff --git a/src/ortho/mcode/ortho_mcode.adb b/src/ortho/mcode/ortho_mcode.adb
index cd7131d73..235bb0e47 100644
--- a/src/ortho/mcode/ortho_mcode.adb
+++ b/src/ortho/mcode/ortho_mcode.adb
@@ -60,6 +60,31 @@ package body Ortho_Mcode is
Ortho_Code.O_Tnode (Res));
end Finish_Record_Type;
+ procedure Start_Record_Subtype
+ (Rtype : O_Tnode; Elements : out O_Element_Sublist) is
+ begin
+ Ortho_Code.Types.Start_Record_Subtype
+ (Ortho_Code.O_Tnode (Rtype),
+ Ortho_Code.Types.O_Element_List (Elements));
+ end Start_Record_Subtype;
+
+ procedure New_Subrecord_Field
+ (Elements : in out O_Element_Sublist; El : out O_Fnode; Etype : O_Tnode)
+ is
+ begin
+ Ortho_Code.Types.New_Subrecord_Field
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Fnode (El), Ortho_Code.O_Tnode (Etype));
+ end New_Subrecord_Field;
+
+ procedure Finish_Record_Subtype
+ (Elements : in out O_Element_Sublist; Res : out O_Tnode) is
+ begin
+ Ortho_Code.Types.Finish_Record_Subtype
+ (Ortho_Code.Types.O_Element_List (Elements),
+ Ortho_Code.O_Tnode (Res));
+ end Finish_Record_Subtype;
+
procedure New_Uncomplete_Record_Type (Res : out O_Tnode) is
begin
Ortho_Code.Types.New_Uncomplete_Record_Type (Ortho_Code.O_Tnode (Res));
@@ -127,8 +152,8 @@ package body Ortho_Mcode is
Ortho_Code.O_Tnode (Index_Type)));
end New_Array_Type;
- function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
- return O_Tnode
+ function New_Array_Subtype
+ (Atype : O_Tnode; El_Type : O_Tnode; Length : O_Cnode) return O_Tnode
is
Len : constant Ortho_Code.O_Cnode := Ortho_Code.O_Cnode (Length);
L_Type : Ortho_Code.O_Tnode;
@@ -137,9 +162,10 @@ package body Ortho_Mcode is
if Get_Type_Kind (L_Type) /= OT_Unsigned then
raise Syntax_Error;
end if;
- return O_Tnode (New_Constrained_Array_Type
- (Ortho_Code.O_Tnode (Atype), Get_Const_U32 (Len)));
- end New_Constrained_Array_Type;
+ return O_Tnode (New_Array_Subtype (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Tnode (El_Type),
+ Get_Const_U32 (Len)));
+ end New_Array_Subtype;
function New_Unsigned_Type (Size : Natural) return O_Tnode is
begin
@@ -325,6 +351,14 @@ package body Ortho_Mcode is
Ortho_Code.O_Tnode (Rtype)));
end New_Sizeof;
+ function New_Record_Sizeof
+ (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
+ begin
+ return O_Cnode
+ (Ortho_Code.Consts.New_Record_Sizeof (Ortho_Code.O_Tnode (Atype),
+ Ortho_Code.O_Tnode (Rtype)));
+ end New_Record_Sizeof;
+
function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode is
begin
return O_Cnode
diff --git a/src/ortho/mcode/ortho_mcode.ads b/src/ortho/mcode/ortho_mcode.ads
index ef24372e3..1e3aa6a44 100644
--- a/src/ortho/mcode/ortho_mcode.ads
+++ b/src/ortho/mcode/ortho_mcode.ads
@@ -64,8 +64,8 @@ package Ortho_Mcode is
-- Build a record type.
procedure Start_Record_Type (Elements : out O_Element_List);
- -- Add a field in the record; not constrained array are prohibited, since
- -- its size is unlimited.
+ -- Add a field in the record. Unconstrained fields must be at the end,
+ -- and cannot be followed by a constrained one.
procedure New_Record_Field
(Elements : in out O_Element_List;
El : out O_Fnode;
@@ -74,6 +74,17 @@ package Ortho_Mcode is
procedure Finish_Record_Type
(Elements : in out O_Element_List; Res : out O_Tnode);
+ type O_Element_Sublist is limited private;
+
+ -- Build a record subtype.
+ -- Re-declare only unconstrained fields with a subtype of them.
+ procedure Start_Record_Subtype
+ (Rtype : O_Tnode; Elements : out O_Element_Sublist);
+ procedure New_Subrecord_Field
+ (Elements : in out O_Element_Sublist; El : out O_Fnode; Etype : O_Tnode);
+ procedure Finish_Record_Subtype
+ (Elements : in out O_Element_Sublist; Res : out O_Tnode);
+
-- Build an uncomplete record type:
-- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
-- This type can be declared or used to define access types on it.
@@ -105,8 +116,8 @@ package Ortho_Mcode is
return O_Tnode;
-- Build a constrained array type.
- function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
- return O_Tnode;
+ function New_Array_Subtype
+ (Atype : O_Tnode; El_Type : O_Tnode; Length : O_Cnode) return O_Tnode;
-- Build a scalar type; size may be 8, 16, 32 or 64.
function New_Unsigned_Type (Size : Natural) return O_Tnode;
@@ -179,9 +190,13 @@ package Ortho_Mcode is
-- Returns the size in bytes of ATYPE. The result is a literal of
-- unsigned type RTYPE
- -- ATYPE cannot be an unconstrained array type.
+ -- ATYPE cannot be an unconstrained type.
function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+ -- Get the size of the bounded part of a record.
+ function New_Record_Sizeof
+ (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
-- Returns the alignment in bytes for ATYPE. The result is a literal of
-- unsgined type RTYPE.
function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
@@ -498,14 +513,15 @@ private
O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null);
O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null);
- type O_Element_List is new Ortho_Code.Types.O_Element_List;
- type O_Enum_List is new Ortho_Code.Types.O_Enum_List;
- type O_Inter_List is new Ortho_Code.Decls.O_Inter_List;
+ type O_Element_List is new Ortho_Code.Types.O_Element_List;
+ type O_Element_Sublist is new Ortho_Code.Types.O_Element_List;
+ type O_Enum_List is new Ortho_Code.Types.O_Enum_List;
+ type O_Inter_List is new Ortho_Code.Decls.O_Inter_List;
type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List;
- type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List;
- type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List;
- type O_If_Block is new Ortho_Code.Exprs.O_If_Block;
- type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block;
+ type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List;
+ type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List;
+ type O_If_Block is new Ortho_Code.Exprs.O_If_Block;
+ type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block;
pragma Inline (New_Lit);
pragma Inline (New_Dyadic_Op);
diff --git a/src/ortho/mcode/ortho_mcode.private.ads b/src/ortho/mcode/ortho_mcode.private.ads
index a78a1a170..def9b7a72 100644
--- a/src/ortho/mcode/ortho_mcode.private.ads
+++ b/src/ortho/mcode/ortho_mcode.private.ads
@@ -52,14 +52,15 @@ private
O_Snode_Null : constant O_Snode := O_Snode (Ortho_Code.Exprs.O_Snode_Null);
O_Tnode_Null : constant O_Tnode := O_Tnode (Ortho_Code.O_Tnode_Null);
- type O_Element_List is new Ortho_Code.Types.O_Element_List;
- type O_Enum_List is new Ortho_Code.Types.O_Enum_List;
- type O_Inter_List is new Ortho_Code.Decls.O_Inter_List;
+ type O_Element_List is new Ortho_Code.Types.O_Element_List;
+ type O_Element_Sublist is new Ortho_Code.Types.O_Element_List;
+ type O_Enum_List is new Ortho_Code.Types.O_Enum_List;
+ type O_Inter_List is new Ortho_Code.Decls.O_Inter_List;
type O_Record_Aggr_List is new Ortho_Code.Consts.O_Record_Aggr_List;
- type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List;
- type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List;
- type O_If_Block is new Ortho_Code.Exprs.O_If_Block;
- type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block;
+ type O_Array_Aggr_List is new Ortho_Code.Consts.O_Array_Aggr_List;
+ type O_Assoc_List is new Ortho_Code.Exprs.O_Assoc_List;
+ type O_If_Block is new Ortho_Code.Exprs.O_If_Block;
+ type O_Case_Block is new Ortho_Code.Exprs.O_Case_Block;
pragma Inline (New_Lit);
pragma Inline (New_Dyadic_Op);
diff --git a/src/ortho/oread/ortho_front.adb b/src/ortho/oread/ortho_front.adb
index fecca6876..84dace138 100644
--- a/src/ortho/oread/ortho_front.adb
+++ b/src/ortho/oread/ortho_front.adb
@@ -174,7 +174,8 @@ package body Ortho_Front is
Tok_Left_Brack, Tok_Right_Brack,
Tok_Unsigned, Tok_Signed, Tok_Float,
Tok_Array, Tok_Subarray,
- Tok_Access, Tok_Record, Tok_Union,
+ Tok_Access,
+ Tok_Record, Tok_Subrecord, Tok_Union,
Tok_Boolean, Tok_Enum,
Tok_If, Tok_Then, Tok_Else, Tok_Elsif,
Tok_Loop, Tok_Exit, Tok_Next,
@@ -213,6 +214,7 @@ package body Ortho_Front is
Id_Subprg_Addr : Syment_Acc;
Id_Conv : Syment_Acc;
Id_Sizeof : Syment_Acc;
+ Id_Record_Sizeof : Syment_Acc;
Id_Alignof : Syment_Acc;
Id_Alloca : Syment_Acc;
Id_Offsetof : Syment_Acc;
@@ -253,7 +255,7 @@ package body Ortho_Front is
Node_Lit,
Type_Boolean, Type_Enum,
Type_Unsigned, Type_Signed, Type_Float,
- Type_Array, Type_Subarray,
+ Type_Array, Type_Subarray, Type_Subrecord,
Type_Access, Type_Record, Type_Union);
subtype Nodes_Subprogram is Node_Kind range Node_Function .. Node_Procedure;
@@ -267,6 +269,8 @@ package body Ortho_Front is
end record;
type Node_Map_Acc is access Node_Map;
+ type Node_Array_Acc is access Node_Array;
+
type Node (Kind : Node_Kind) is record
case Kind is
when Decl_Keyword =>
@@ -322,6 +326,7 @@ package body Ortho_Front is
end case;
when Node_Field =>
-- Record field.
+ Field_Pos : Natural; -- From 1 to N.
Field_Ident : Syment_Acc;
Field_Fnode : O_Fnode;
Field_Type : Node_Acc;
@@ -334,6 +339,7 @@ package body Ortho_Front is
| Type_Array
| Type_Subarray
| Type_Record
+ | Type_Subrecord
| Type_Union
| Type_Access
| Type_Boolean
@@ -353,9 +359,12 @@ package body Ortho_Front is
| Type_Union =>
-- Simply linked list of fields. Works well unless the
-- number of fields is too high.
- Record_Union_Fields : Node_Acc;
+ Record_Union_Fields : Node_Array_Acc;
-- Hash map of fields (the key is the hash of the ident).
Record_Union_Map : Node_Map_Acc;
+ when Type_Subrecord =>
+ Subrecord_Base : Node_Acc;
+ Subrecord_Fields : Node_Array_Acc;
when Type_Enum
| Type_Boolean =>
Enum_Lits : Node_Acc;
@@ -1100,30 +1109,37 @@ package body Ortho_Front is
-- Grammar:
-- { ident : type ; }
-- end
- procedure Parse_Fields (Aggr_Type : Node_Acc;
- Constr : in out O_Element_List)
+ function Parse_Fields return Node_Array_Acc
is
F_Type : Node_Acc;
F : Syment_Acc;
+ First_Field : Node_Acc;
Last_Field : Node_Acc;
Field : Node_Acc;
Num : Natural;
+ Res : Node_Array_Acc;
begin
Push_Scope;
Last_Field := null;
+ First_Field := null;
Num := 0;
loop
exit when Tok = Tok_End;
+ exit when Tok = Tok_Right_Paren;
if Tok /= Tok_Ident then
Parse_Error ("field name expected");
end if;
+
+ Num := Num + 1;
+
F := Token_Sym;
Next_Expect (Tok_Colon, "':' expected");
Next_Token;
F_Type := Parse_Type;
Field := new Node'(Kind => Node_Field,
+ Field_Pos => Num,
Field_Ident => F,
Field_Fnode => O_Fnode_Null,
Field_Type => F_Type,
@@ -1133,48 +1149,69 @@ package body Ortho_Front is
-- Check fields are uniq.
Add_Decl (F, Field);
- case Aggr_Type.Kind is
- when Type_Record =>
- New_Record_Field (Constr, Field.Field_Fnode, F.Ident,
- F_Type.Type_Onode);
- when Type_Union =>
- New_Union_Field (Constr, Field.Field_Fnode, F.Ident,
- F_Type.Type_Onode);
- when others =>
- raise Program_Error;
- end case;
-
-- Append field
if Last_Field = null then
- Aggr_Type.Record_Union_Fields := Field;
+ First_Field := Field;
else
Last_Field.Field_Next := Field;
end if;
Last_Field := Field;
- Num := Num + 1;
-
Expect (Tok_Semicolon, "';' expected");
Next_Token;
end loop;
Pop_Scope;
+ Res := new Node_Array(1 .. Num);
+ for I in Res'Range loop
+ Res (I) := First_Field;
+ First_Field := First_Field.Field_Next;
+ end loop;
+
+ return Res;
+ end Parse_Fields;
+
+ procedure Parse_Fields (Aggr_Type : Node_Acc;
+ Constr : in out O_Element_List)
+ is
+ Fields : Node_Array_Acc;
+ Field : Node_Acc;
+ begin
+ Fields := Parse_Fields;
+ Expect (Tok_End, "end expected");
+ Aggr_Type.Record_Union_Fields := Fields;
+
+ for I in Fields'Range loop
+ Field := Fields (I);
+ case Aggr_Type.Kind is
+ when Type_Record =>
+ New_Record_Field (Constr, Field.Field_Fnode,
+ Field.Field_Ident.Ident,
+ Field.Field_Type.Type_Onode);
+ when Type_Union =>
+ New_Union_Field (Constr, Field.Field_Fnode,
+ Field.Field_Ident.Ident,
+ Field.Field_Type.Type_Onode);
+ when others =>
+ raise Program_Error;
+ end case;
+ end loop;
+
-- Create a map if there are a lot of fields.
- if Num > 16 then
+ if Fields'Last > 16 then
declare
Map : Node_Map_Acc;
Idx : Natural;
begin
- Map := new Node_Map'(Len => Num / 3, Map => (others => null));
+ Map := new Node_Map'(Len => Fields'Last / 3,
+ Map => (others => null));
Aggr_Type.Record_Union_Map := Map;
- Field := Aggr_Type.Record_Union_Fields;
- while Field /= null loop
+ for I in Fields'Range loop
+ Field := Fields (I);
Idx := Field_Map_Index (Map, Field.Field_Ident);
Field.Field_Hash_Next := Map.Map (Idx);
Map.Map (Idx) := Field;
-
- Field := Field.Field_Next;
end loop;
end;
end if;
@@ -1194,6 +1231,34 @@ package body Ortho_Front is
Finish_Record_Type (Constr, Def.Type_Onode);
end Parse_Record_Type;
+ procedure Parse_Subrecord_Type (Def : Node_Acc)
+ is
+ Base : Node_Acc;
+ Constr : O_Element_Sublist;
+ Fields : Node_Array_Acc;
+ Field : Node_Acc;
+ begin
+ Base := Parse_Type;
+ if Base.Kind /= Type_Record then
+ Parse_Error ("subrecord base type must be a record type");
+ end if;
+ Def.Subrecord_Base := Base;
+ Expect (Tok_Left_Paren);
+ Next_Token;
+
+ Fields := Parse_Fields;
+ Def.Subrecord_Fields := Fields;
+ Expect (Tok_Right_Paren);
+
+ Start_Record_Subtype (Base.Type_Onode, Constr);
+ for I in Fields'Range loop
+ Field := Fields (I);
+ New_Subrecord_Field (Constr, Field.Field_Fnode,
+ Field.Field_Type.Type_Onode);
+ end loop;
+ Finish_Record_Subtype (Constr, Def.Type_Onode);
+ end Parse_Subrecord_Type;
+
procedure Parse_Union_Type (Def : Node_Acc)
is
Constr : O_Element_List;
@@ -1267,8 +1332,9 @@ package body Ortho_Front is
end if;
Expect (Tok_Left_Brack);
Next_Token;
- Res_Type := New_Constrained_Array_Type
+ Res_Type := New_Array_Subtype
(Base_Node.Type_Onode,
+ Base_Node.Array_Element.Type_Onode,
Parse_Constant_Value (Base_Node.Array_Index));
Expect (Tok_Right_Brack);
Next_Token;
@@ -1327,6 +1393,13 @@ package body Ortho_Front is
Record_Union_Fields => null,
Record_Union_Map => null);
Parse_Record_Type (Res);
+ when Tok_Subrecord =>
+ Next_Token;
+ Res := new Node'(Kind => Type_Subrecord,
+ Type_Onode => O_Tnode_Null,
+ Subrecord_Base => null,
+ Subrecord_Fields => null);
+ Parse_Subrecord_Type (Res);
when Tok_Union =>
Next_Token;
Res := new Node'(Kind => Type_Union,
@@ -1462,22 +1535,42 @@ package body Ortho_Front is
function Find_Field_By_Name (Aggr_Type : Node_Acc) return Node_Acc
is
- Map : constant Node_Map_Acc := Aggr_Type.Record_Union_Map;
+ Map : Node_Map_Acc;
Field : Node_Acc;
- begin
+ Fields : Node_Array_Acc;
+ begin
+ case Aggr_Type.Kind is
+ when Type_Record
+ | Type_Union =>
+ Map := Aggr_Type.Record_Union_Map;
+ Fields := Aggr_Type.Record_Union_Fields;
+ when Type_Subrecord =>
+ Map := Aggr_Type.Subrecord_Base.Record_Union_Map;
+ Fields := Aggr_Type.Subrecord_Fields;
+ when others =>
+ raise Program_Error;
+ end case;
+
if Map /= null then
-- Look in the hash map if it is present.
Field := Map.Map (Field_Map_Index (Map, Token_Sym));
while Field /= null loop
- exit when Field.Field_Ident = Token_Sym;
+ if Field.Field_Ident = Token_Sym then
+ -- Get the field by position as the map is shared between
+ -- a record and its subrecords.
+ Field := Fields (Field.Field_Pos);
+ exit;
+ end if;
Field := Field.Field_Hash_Next;
end loop;
else
-- Linear look.
- Field := Aggr_Type.Record_Union_Fields;
- while Field /= null loop
- exit when Field.Field_Ident = Token_Sym;
- Field := Field.Field_Next;
+ Field := null;
+ for I in Fields'Range loop
+ if Fields (I).Field_Ident = Token_Sym then
+ Field := Fields (I);
+ exit;
+ end if;
end loop;
end if;
@@ -1497,9 +1590,10 @@ package body Ortho_Front is
Next_Expect (Tok_Ident);
Rec_Type := Get_Decl (Token_Sym);
if Rec_Type.Kind /= Decl_Type
- or else Rec_Type.Decl_Dtype.Kind /= Type_Record
+ or else (Rec_Type.Decl_Dtype.Kind /= Type_Record
+ and then Rec_Type.Decl_Dtype.Kind /= Type_Subrecord)
then
- Parse_Error ("type name expected");
+ Parse_Error ("record type name expected");
end if;
Next_Expect (Tok_Dot);
Next_Expect (Tok_Ident);
@@ -1510,36 +1604,42 @@ package body Ortho_Front is
Atype.Type_Onode);
end Parse_Offsetof;
- function Parse_Sizeof (Atype : Node_Acc) return O_Cnode
+ function Parse_Type_Attribute return Node_Acc
is
- Res : O_Cnode;
+ Res : Node_Acc;
begin
Next_Expect (Tok_Left_Paren);
Next_Token;
if Tok /= Tok_Ident then
Parse_Error ("type name expected");
end if;
- Res := New_Sizeof
- (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode,
- Atype.Type_Onode);
+ Res := Get_Decl (Token_Sym).Decl_Dtype;
Next_Expect (Tok_Right_Paren);
return Res;
+ end Parse_Type_Attribute;
+
+ function Parse_Sizeof (Atype : Node_Acc) return O_Cnode
+ is
+ T : Node_Acc;
+ begin
+ T := Parse_Type_Attribute;
+ return New_Sizeof (T.Type_Onode, Atype.Type_Onode);
end Parse_Sizeof;
+ function Parse_Record_Sizeof (Atype : Node_Acc) return O_Cnode
+ is
+ T : Node_Acc;
+ begin
+ T := Parse_Type_Attribute;
+ return New_Record_Sizeof (T.Type_Onode, Atype.Type_Onode);
+ end Parse_Record_Sizeof;
+
function Parse_Alignof (Atype : Node_Acc) return O_Cnode
is
- Res : O_Cnode;
+ T : Node_Acc;
begin
- Next_Expect (Tok_Left_Paren);
- Next_Token;
- if Tok /= Tok_Ident then
- Parse_Error ("type name expected");
- end if;
- Res := New_Alignof
- (Get_Decl (Token_Sym).Decl_Dtype.Type_Onode,
- Atype.Type_Onode);
- Next_Expect (Tok_Right_Paren);
- return Res;
+ T := Parse_Type_Attribute;
+ return New_Alignof (T.Type_Onode, Atype.Type_Onode);
end Parse_Alignof;
function Parse_Minus_Num (Atype : Node_Acc) return O_Cnode
@@ -1613,6 +1713,8 @@ package body Ortho_Front is
Res := Parse_Offsetof (N);
elsif Token_Sym = Id_Sizeof then
Res := Parse_Sizeof (N);
+ elsif Token_Sym = Id_Record_Sizeof then
+ Res := Parse_Record_Sizeof (N);
elsif Token_Sym = Id_Alignof then
Res := Parse_Alignof (N);
elsif Token_Sym = Id_Address
@@ -1725,6 +1827,11 @@ package body Ortho_Front is
Res := New_Lit (Parse_Sizeof (Res_Type));
Next_Token;
return;
+ elsif Token_Sym = Id_Record_Sizeof then
+ Res_Type := Name.Decl_Dtype;
+ Res := New_Lit (Parse_Record_Sizeof (Res_Type));
+ Next_Token;
+ return;
elsif Token_Sym = Id_Alignof then
Res_Type := Name.Decl_Dtype;
Res := New_Lit (Parse_Alignof (Res_Type));
@@ -1957,9 +2064,14 @@ package body Ortho_Front is
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;
+ case N_Type.Kind is
+ when Type_Record
+ | Type_Union
+ | Type_Subrecord =>
+ null;
+ when others =>
+ Parse_Error ("type of prefix is neither a record nor an union");
+ end case;
end Check_Selected_Prefix;
-- Expect and leave: next token
@@ -2753,28 +2865,27 @@ package body Ortho_Front is
declare
Constr : O_Record_Aggr_List;
- Field : Node_Acc;
+ Fields : Node_Array_Acc;
begin
Expect (Tok_Left_Brace);
Next_Token;
Start_Record_Aggr (Constr, Atype.Type_Onode);
- Field := Atype.Record_Union_Fields;
- while Field /= null loop
+ Fields := Atype.Record_Union_Fields;
+ for I in Fields'Range loop
+ if I /= 1 then
+ Expect (Tok_Comma);
+ Next_Token;
+ end if;
if Tok = Tok_Dot then
Next_Expect (Tok_Ident);
- if Token_Sym /= Field.Field_Ident then
+ if Token_Sym /= Fields (I).Field_Ident then
Parse_Error ("bad field name");
end if;
Next_Expect (Tok_Equal);
Next_Token;
end if;
New_Record_Aggr_El
- (Constr, Parse_Constant_Value (Field.Field_Type));
- Field := Field.Field_Next;
- if Field /= null then
- Expect (Tok_Comma);
- Next_Token;
- end if;
+ (Constr, Parse_Constant_Value (Fields (I).Field_Type));
end loop;
Finish_Record_Aggr (Constr, Res);
Expect (Tok_Right_Brace);
@@ -2998,6 +3109,7 @@ package body Ortho_Front is
Add_Keyword ("array", Tok_Array);
Add_Keyword ("access", Tok_Access);
Add_Keyword ("record", Tok_Record);
+ Add_Keyword ("subrecord", Tok_Subrecord);
Add_Keyword ("union", Tok_Union);
Add_Keyword ("end", Tok_End);
Add_Keyword ("boolean", Tok_Boolean);
@@ -3024,6 +3136,7 @@ package body Ortho_Front is
Id_Subprg_Addr := New_Symbol ("subprg_addr");
Id_Conv := New_Symbol ("conv");
Id_Sizeof := New_Symbol ("sizeof");
+ Id_Record_Sizeof := New_Symbol ("record_sizeof");
Id_Alignof := New_Symbol ("alignof");
Id_Alloca := New_Symbol ("alloca");
Id_Offsetof := New_Symbol ("offsetof");
diff --git a/src/ortho/ortho_nodes.common.ads b/src/ortho/ortho_nodes.common.ads
index e9c43aa46..82882a6e6 100644
--- a/src/ortho/ortho_nodes.common.ads
+++ b/src/ortho/ortho_nodes.common.ads
@@ -51,8 +51,8 @@ package ORTHO_NODES is
-- Build a record type.
procedure Start_Record_Type (Elements : out O_Element_List);
- -- Add a field in the record; not constrained array are prohibited, since
- -- its size is unlimited.
+ -- Add a field in the record. Unconstrained fields must be at the end,
+ -- and cannot be followed by a constrained one.
procedure New_Record_Field
(Elements : in out O_Element_List;
El : out O_Fnode;
@@ -61,6 +61,17 @@ package ORTHO_NODES is
procedure Finish_Record_Type
(Elements : in out O_Element_List; Res : out O_Tnode);
+ type O_Element_Sublist is limited private;
+
+ -- Build a record subtype.
+ -- Re-declare only unconstrained fields with a subtype of them.
+ procedure Start_Record_Subtype
+ (Rtype : O_Tnode; Elements : out O_Element_Sublist);
+ procedure New_Subrecord_Field
+ (Elements : in out O_Element_Sublist; El : out O_Fnode; Etype : O_Tnode);
+ procedure Finish_Record_Subtype
+ (Elements : in out O_Element_Sublist; Res : out O_Tnode);
+
-- Build an uncomplete record type:
-- First call NEW_UNCOMPLETE_RECORD_TYPE, which returns a record type.
-- This type can be declared or used to define access types on it.
@@ -92,8 +103,8 @@ package ORTHO_NODES is
return O_Tnode;
-- Build a constrained array type.
- function New_Constrained_Array_Type (Atype : O_Tnode; Length : O_Cnode)
- return O_Tnode;
+ function New_Array_Subtype
+ (Atype : O_Tnode; El_Type : O_Tnode; Length : O_Cnode) return O_Tnode;
-- Build a scalar type; size may be 8, 16, 32 or 64.
function New_Unsigned_Type (Size : Natural) return O_Tnode;
@@ -166,9 +177,13 @@ package ORTHO_NODES is
-- Returns the size in bytes of ATYPE. The result is a literal of
-- unsigned type RTYPE
- -- ATYPE cannot be an unconstrained array type.
+ -- ATYPE cannot be an unconstrained type.
function New_Sizeof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+ -- Get the size of the bounded part of a record.
+ function New_Record_Sizeof
+ (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
+
-- Returns the alignment in bytes for ATYPE. The result is a literal of
-- unsgined type RTYPE.
function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode;
diff --git a/src/vhdl/translate/trans-chap12.adb b/src/vhdl/translate/trans-chap12.adb
index 230a2cc58..05485a2cd 100644
--- a/src/vhdl/translate/trans-chap12.adb
+++ b/src/vhdl/translate/trans-chap12.adb
@@ -59,9 +59,10 @@ package body Trans.Chap12 is
-- Create the array of RTIs for packages (as a variable, initialized
-- during elaboration).
- Arr_Type := New_Constrained_Array_Type
+ Arr_Type := New_Array_Subtype
(Rtis.Ghdl_Rti_Array,
- New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Elab_Nbr_Pkgs)));
+ Rtis.Ghdl_Rti_Access,
+ Helpers.New_Index_Lit (Unsigned_64 (Elab_Nbr_Pkgs)));
New_Var_Decl (Pkgs_Arr, Get_Identifier ("__ghdl_top_RTIARRAY"),
O_Storage_Private, Arr_Type);
diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb
index 8e5cb9f33..bc3078460 100644
--- a/src/vhdl/translate/trans-chap3.adb
+++ b/src/vhdl/translate/trans-chap3.adb
@@ -1022,8 +1022,9 @@ package body Trans.Chap3 is
when Mode_Signal =>
Id := Create_Identifier ("SIG");
end case;
- Info.Ortho_Type (I) := New_Constrained_Array_Type
- (Base (I), New_Index_Lit (Unsigned_64 (Len)));
+ Info.Ortho_Type (I) := New_Array_Subtype
+ (Base (I), Get_Ortho_Type (El_Type, I),
+ New_Index_Lit (Unsigned_64 (Len)));
New_Type_Decl (Id, Info.Ortho_Type (I));
end loop;
end if;
diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb
index f7ea2cdf7..cd21d4755 100644
--- a/src/vhdl/translate/trans-chap7.adb
+++ b/src/vhdl/translate/trans-chap7.adb
@@ -348,12 +348,17 @@ package body Trans.Chap7 is
function Create_String_Literal_Var (Str : Iir) return Var_Type
is
Str_Type : constant Iir := Get_Type (Str);
+ El_Type : constant Iir := Get_Element_Subtype (Str_Type);
Arr_Type : O_Tnode;
+ Arr_St : O_Tnode;
begin
-- Create the string value.
Arr_Type := Get_Info (Str_Type).B.Base_Type (Mode_Value);
- return Create_String_Literal_Var_Inner
- (Str, Get_Element_Subtype (Str_Type), Arr_Type);
+ Arr_St := New_Array_Subtype
+ (Arr_Type,
+ Get_Ortho_Type (El_Type, Mode_Value),
+ New_Index_Lit (Unsigned_64 (Get_String_Length (Str))));
+ return Create_String_Literal_Var_Inner (Str, El_Type, Arr_St);
end Create_String_Literal_Var;
-- Some strings literal have an unconstrained array type,
diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb
index 0b9dbce3b..65b559963 100644
--- a/src/vhdl/translate/trans-chap8.adb
+++ b/src/vhdl/translate/trans-chap8.adb
@@ -1368,13 +1368,13 @@ package body Trans.Chap8 is
(Stmt : Iir_Case_Statement;
Choices : Iir;
Len_Type : out Iir;
- Tinfo : out Type_Info_Acc;
+ Base_Type : out Iir;
Expr_Node : out O_Dnode;
C_Node : out O_Dnode)
is
Expr : constant Iir := Get_Expression (Stmt);
Expr_Type : Iir;
- Base_Type : Iir;
+ Tinfo : Type_Info_Acc;
Sel_Length : Int64;
Cond : O_Enode;
begin
@@ -1446,7 +1446,8 @@ package body Trans.Chap8 is
Handler : in out Case_Handler'Class)
is
First, Last : Choice_Id;
- El : Choice_Id;
+ El : Choice_Id;
+ Base_Type : Iir;
-- Selector.
Tinfo : Type_Info_Acc;
@@ -1468,6 +1469,7 @@ package body Trans.Chap8 is
-- Dichotomy table (table of choices).
String_Type : O_Tnode;
Table_Base_Type : O_Tnode;
+ Table_Type : O_Tnode;
Table : O_Dnode;
List : O_Array_Aggr_List;
Table_Cst : O_Cnode;
@@ -1477,6 +1479,7 @@ package body Trans.Chap8 is
-- statement list.
-- Could be replaced by jump table.
Assoc_Table_Base_Type : O_Tnode;
+ Assoc_Table_Type : O_Tnode;
Assoc_Table : O_Dnode;
begin
-- Fill Choices_Info array, and count number of associations.
@@ -1573,21 +1576,27 @@ package body Trans.Chap8 is
Open_Temp;
Translate_String_Case_Statement_Common
- (Stmt, Choices_Chain, Len_Type, Tinfo, Expr_Node, C_Node);
+ (Stmt, Choices_Chain, Len_Type, Base_Type, Expr_Node, C_Node);
+
+ Tinfo := Get_Info (Base_Type);
-- Generate the sorted array of choices.
Sel_Length := Eval_Discrete_Type_Length
(Get_String_Type_Bound_Type (Len_Type));
- String_Type := New_Constrained_Array_Type
+ String_Type := New_Array_Subtype
(Tinfo.B.Base_Type (Mode_Value),
- New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Sel_Length)));
+ Get_Ortho_Type (Get_Element_Subtype (Base_Type), Mode_Value),
+ New_Index_Lit (Unsigned_64 (Sel_Length)));
Table_Base_Type := New_Array_Type (String_Type, Ghdl_Index_Type);
New_Type_Decl (Create_Uniq_Identifier, Table_Base_Type);
+ Table_Type := New_Array_Subtype
+ (Table_Base_Type,
+ String_Type, New_Index_Lit (Unsigned_64 (Nbr_Choices)));
New_Const_Decl (Table, Create_Uniq_Identifier, O_Storage_Private,
- Table_Base_Type);
+ Table_Type);
Start_Init_Value (Table);
- Start_Array_Aggr (List, Table_Base_Type, Unsigned_32 (Nbr_Choices));
+ Start_Array_Aggr (List, Table_Type, Unsigned_32 (Nbr_Choices));
El := First;
while El /= No_Choice_Id loop
@@ -1602,11 +1611,14 @@ package body Trans.Chap8 is
Assoc_Table_Base_Type :=
New_Array_Type (Ghdl_Index_Type, Ghdl_Index_Type);
New_Type_Decl (Create_Uniq_Identifier, Assoc_Table_Base_Type);
+ Assoc_Table_Type := New_Array_Subtype
+ (Assoc_Table_Base_Type,
+ Ghdl_Index_Type, New_Index_Lit (Unsigned_64 (Nbr_Choices)));
New_Const_Decl (Assoc_Table, Create_Uniq_Identifier,
- O_Storage_Private, Assoc_Table_Base_Type);
+ O_Storage_Private, Assoc_Table_Type);
Start_Init_Value (Assoc_Table);
Start_Array_Aggr
- (List, Assoc_Table_Base_Type, Unsigned_32 (Nbr_Choices));
+ (List, Assoc_Table_Type, Unsigned_32 (Nbr_Choices));
El := First;
while El /= No_Choice_Id loop
New_Array_Aggr_El
@@ -1824,6 +1836,7 @@ package body Trans.Chap8 is
Expr_Node : O_Dnode;
-- Node containing the current choice.
Val_Node : O_Dnode;
+ Base_Type : Iir;
Tinfo : Type_Info_Acc;
Cond_Var : O_Dnode;
@@ -1887,7 +1900,8 @@ package body Trans.Chap8 is
begin
Open_Temp;
Translate_String_Case_Statement_Common
- (Stmt, Choices, Len_Type, Tinfo, Expr_Node, Val_Node);
+ (Stmt, Choices, Len_Type, Base_Type, Expr_Node, Val_Node);
+ Tinfo := Get_Info (Base_Type);
Func := Chap7.Find_Predefined_Function
(Get_Base_Type (Len_Type), Iir_Predefined_Array_Equality);
diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb
index 2c7fd68cc..d1bd829cb 100644
--- a/src/vhdl/translate/trans-chap9.adb
+++ b/src/vhdl/translate/trans-chap9.adb
@@ -338,10 +338,10 @@ package body Trans.Chap9 is
Push_Instance_Factory (Info.Psl_Scope'Access);
-- Create the state vector type.
- Info.Psl_Vect_Type := New_Constrained_Array_Type
+ Info.Psl_Vect_Type := New_Array_Subtype
(Std_Boolean_Array_Type,
- New_Unsigned_Literal (Ghdl_Index_Type,
- Unsigned_64 (Get_PSL_Nbr_States (Stmt))));
+ Std_Boolean_Type_Node,
+ New_Index_Lit (Unsigned_64 (Get_PSL_Nbr_States (Stmt))));
New_Type_Decl (Create_Identifier ("VECTTYPE"), Info.Psl_Vect_Type);
-- Create the variables.
diff --git a/src/vhdl/translate/trans-helpers2.adb b/src/vhdl/translate/trans-helpers2.adb
index 4072fe321..22ea225d3 100644
--- a/src/vhdl/translate/trans-helpers2.adb
+++ b/src/vhdl/translate/trans-helpers2.adb
@@ -38,10 +38,10 @@ package body Trans.Helpers2 is
-- Append a NUL terminator (to make interfaces with C easier).
function Create_String_Type (Str : String) return O_Tnode is
begin
- return New_Constrained_Array_Type
+ return New_Array_Subtype
(Chararray_Type,
- New_Unsigned_Literal (Ghdl_Index_Type,
- Unsigned_64 (Str'Length + 1)));
+ Char_Type_Node,
+ New_Index_Lit (Str'Length + 1));
end Create_String_Type;
procedure Create_String_Value
@@ -65,9 +65,11 @@ package body Trans.Helpers2 is
function Create_String (Str : String; Id : O_Ident) return O_Dnode
is
Const : O_Dnode;
+ Stype : O_Tnode;
begin
- New_Const_Decl (Const, Id, O_Storage_Private, Chararray_Type);
- Create_String_Value (Const, Chararray_Type, Str);
+ Stype := Create_String_Type (Str);
+ New_Const_Decl (Const, Id, O_Storage_Private, Stype);
+ Create_String_Value (Const, Stype, Str);
return Const;
end Create_String;
diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb
index 5b55c69c6..d52a025db 100644
--- a/src/vhdl/translate/trans-rtis.adb
+++ b/src/vhdl/translate/trans-rtis.adb
@@ -877,16 +877,19 @@ package body Trans.Rtis is
function Generate_Rti_Array (Id : O_Ident) return O_Dnode
is
- List : O_Array_Aggr_List;
- L : Rti_Array_List_Acc;
- Nbr : Integer;
- Val : O_Cnode;
- Res : O_Dnode;
+ List : O_Array_Aggr_List;
+ L : Rti_Array_List_Acc;
+ Nbr : Integer;
+ Val : O_Cnode;
+ Res : O_Dnode;
+ Stype : O_Tnode;
begin
- New_Const_Decl (Res, Id, O_Storage_Private, Ghdl_Rti_Array);
+ Stype := New_Array_Subtype
+ (Ghdl_Rti_Array, Ghdl_Rti_Access,
+ New_Index_Lit (Unsigned_64 (Cur_Block.Nbr + 1)));
+ New_Const_Decl (Res, Id, O_Storage_Private, Stype);
Start_Init_Value (Res);
- Start_Array_Aggr
- (List, Ghdl_Rti_Array, Unsigned_32 (Cur_Block.Nbr + 1));
+ Start_Array_Aggr (List, Stype, Unsigned_32 (Cur_Block.Nbr + 1));
Nbr := Cur_Block.Nbr;
-- First chunk.
@@ -1094,6 +1097,7 @@ package body Trans.Rtis is
type Dnode_Array is array (Natural range <>) of O_Dnode;
Name_Lits : Dnode_Array (0 .. Nbr_Lit - 1);
Mark : Id_Mark_Type;
+ Name_Arr_St : O_Tnode;
Name_Arr : O_Dnode;
Arr_Aggr : O_Array_Aggr_List;
@@ -1110,11 +1114,14 @@ package body Trans.Rtis is
end loop;
-- Generate array of names.
+ Name_Arr_St := New_Array_Subtype
+ (Char_Ptr_Array_Type,
+ Char_Ptr_Type,
+ New_Index_Lit (Unsigned_64 (Nbr_Lit)));
New_Const_Decl (Name_Arr, Create_Identifier ("RTINAMES"),
- O_Storage_Private, Char_Ptr_Array_Type);
+ O_Storage_Private, Name_Arr_St);
Start_Init_Value (Name_Arr);
- Start_Array_Aggr
- (Arr_Aggr, Char_Ptr_Array_Type, Unsigned_32 (Nbr_Lit));
+ Start_Array_Aggr (Arr_Aggr, Name_Arr_St, Unsigned_32 (Nbr_Lit));
for I in Name_Lits'Range loop
New_Array_Aggr_El (Arr_Aggr, New_Name_Address (Name_Lits (I)));
end loop;
@@ -1405,6 +1412,7 @@ package body Trans.Rtis is
Index : Iir;
Tmp : O_Dnode;
pragma Unreferenced (Tmp);
+ Stype : O_Tnode;
Arr_Aggr : O_Array_Aggr_List;
Val : O_Cnode;
Mark : Id_Mark_Type;
@@ -1420,11 +1428,13 @@ package body Trans.Rtis is
end loop;
-- Generate array of index.
+ Stype := New_Array_Subtype (Ghdl_Rti_Array, Ghdl_Rti_Access,
+ New_Index_Lit (Unsigned_64 (Nbr_Indexes)));
New_Const_Decl (Res, Create_Identifier ("RTIINDEXES"),
- Global_Storage, Ghdl_Rti_Array);
+ Global_Storage, Stype);
Start_Init_Value (Res);
- Start_Array_Aggr (Arr_Aggr, Ghdl_Rti_Array, Unsigned_32 (Nbr_Indexes));
+ Start_Array_Aggr (Arr_Aggr, Stype, Unsigned_32 (Nbr_Indexes));
for I in 1 .. Nbr_Indexes loop
Index := Get_Index_Type (List, I - 1);
New_Array_Aggr_El
diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb
index 519671970..b510a7ae5 100644
--- a/src/vhdl/translate/translation.adb
+++ b/src/vhdl/translate/translation.adb
@@ -1364,8 +1364,10 @@ package body Translation is
-- Max length of a scalar type.
-- Note: this type is not correctly aligned. Restricted use only.
-- type __ghdl_scalar_bytes is __ghdl_chararray (0 .. 8);
- Ghdl_Scalar_Bytes := New_Constrained_Array_Type
- (Chararray_Type, New_Unsigned_Literal (Ghdl_Index_Type, 8));
+ Ghdl_Scalar_Bytes := New_Array_Subtype
+ (Chararray_Type,
+ Char_Type_Node,
+ New_Unsigned_Literal (Ghdl_Index_Type, 8));
New_Type_Decl (Get_Identifier ("__ghdl_scalar_bytes"),
Ghdl_Scalar_Bytes);
@@ -2130,8 +2132,8 @@ package body Translation is
-- Std_Ulogic indexed array of STD.Boolean.
-- Used by PSL to convert Std_Ulogic to boolean.
- Std_Ulogic_Boolean_Array_Type :=
- New_Constrained_Array_Type (Std_Boolean_Array_Type, New_Index_Lit (9));
+ Std_Ulogic_Boolean_Array_Type := New_Array_Subtype
+ (Std_Boolean_Array_Type, Std_Boolean_Type_Node, New_Index_Lit (9));
New_Type_Decl (Get_Identifier ("__ghdl_std_ulogic_boolean_array_type"),
Std_Ulogic_Boolean_Array_Type);
New_Const_Decl (Ghdl_Std_Ulogic_To_Boolean_Array,
--
cgit v1.2.3