aboutsummaryrefslogtreecommitdiffstats
path: root/src/ortho/debug
diff options
context:
space:
mode:
Diffstat (limited to 'src/ortho/debug')
-rw-r--r--src/ortho/debug/ortho_debug-disp.adb57
-rw-r--r--src/ortho/debug/ortho_debug.adb338
-rw-r--r--src/ortho/debug/ortho_debug.private.ads49
3 files changed, 310 insertions, 134 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;
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-19 06:02:13 +0000