diff options
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) { @@ -1162,9 +1170,40 @@ 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); } @@ -1498,6 +1537,12 @@ new_sizeof (tree atype, tree rtype) } tree +new_record_sizeof (tree atype, tree rtype) +{ + return new_sizeof (atype, rtype); +} + +tree new_alignof (tree atype, tree rtype) { return build_int_cstu (rtype, TYPE_ALIGN_UNIT (atype)); 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) { @@ -1148,9 +1156,40 @@ 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); } @@ -1484,6 +1523,12 @@ new_sizeof (tree atype, tree rtype) } tree +new_record_sizeof (tree atype, tree rtype) +{ + return new_sizeof (atype, rtype); +} + +tree new_alignof (tree atype, tree rtype) { return build_int_cstu (rtype, TYPE_ALIGN_UNIT (atype)); 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) { @@ -1148,9 +1156,40 @@ 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); } @@ -1484,6 +1523,12 @@ new_sizeof (tree atype, tree rtype) } tree +new_record_sizeof (tree atype, tree rtype) +{ + return new_sizeof (atype, rtype); +} + +tree new_alignof (tree atype, tree rtype) { return build_int_cstu (rtype, TYPE_ALIGN_UNIT (atype)); 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) { @@ -1160,9 +1168,40 @@ 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); } @@ -1496,6 +1535,12 @@ new_sizeof (tree atype, tree rtype) } tree +new_record_sizeof (tree atype, tree rtype) +{ + return new_sizeof (atype, rtype); +} + +tree new_alignof (tree atype, tree rtype) { return build_int_cstu (rtype, TYPE_ALIGN_UNIT (atype)); 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) { @@ -1161,9 +1169,40 @@ 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); } @@ -1497,6 +1536,12 @@ new_sizeof (tree atype, tree rtype) } tree +new_record_sizeof (tree atype, tree rtype) +{ + return new_sizeof (atype, rtype); +} + +tree new_alignof (tree atype, tree rtype) { return build_int_cstu (rtype, TYPE_ALIGN_UNIT (atype)); 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) { @@ -1161,9 +1169,40 @@ 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); } @@ -1497,6 +1536,12 @@ new_sizeof (tree atype, tree rtype) } tree +new_record_sizeof (tree atype, tree rtype) +{ + return new_sizeof (atype, rtype); +} + +tree new_alignof (tree atype, tree rtype) { return build_int_cstu (rtype, TYPE_ALIGN_UNIT (atype)); 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; @@ -1121,6 +1169,12 @@ new_sizeof(OTnode Atype, OTnode Rtype) } extern "C" OCnode +new_record_sizeof(OTnode Atype, OTnode Rtype) +{ + return new_sizeof(Atype, Rtype); +} + +extern "C" OCnode new_alignof(OTnode Atype, OTnode Rtype) { return constToConst 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, |