summaryrefslogtreecommitdiff
path: root/ortho/debug
diff options
context:
space:
mode:
Diffstat (limited to 'ortho/debug')
-rw-r--r--ortho/debug/ortho_debug-disp.adb116
-rw-r--r--ortho/debug/ortho_debug.adb9
-rw-r--r--ortho/debug/ortho_debug.private.ads5
3 files changed, 81 insertions, 49 deletions
diff --git a/ortho/debug/ortho_debug-disp.adb b/ortho/debug/ortho_debug-disp.adb
index b2779a3..ebaf3e9 100644
--- a/ortho/debug/ortho_debug-disp.adb
+++ b/ortho/debug/ortho_debug-disp.adb
@@ -17,6 +17,8 @@
-- 02111-1307, USA.
package body Ortho_Debug.Disp is
+ Disp_All_Types : constant Boolean := False;
+
package Formated_Output is
use Interfaces.C_Streams;
@@ -231,7 +233,7 @@ package body Ortho_Debug.Disp is
Formated_Output.Init_Context (File);
end Init_Context;
- procedure Disp_Enode (E : O_Enode);
+ procedure Disp_Enode (E : O_Enode; Etype : O_Tnode);
procedure Disp_Lnode (Node : O_Lnode);
procedure Disp_Snode (First, Last : O_Snode);
procedure Disp_Dnode (Decl : O_Dnode);
@@ -390,7 +392,7 @@ package body Ortho_Debug.Disp is
Put ("(");
if El /= null then
loop
- Disp_Enode (El.Actual);
+ Disp_Enode (El.Actual, El.Formal.Dtype);
El := El.Next;
exit when El = null;
Put (", ");
@@ -410,9 +412,10 @@ package body Ortho_Debug.Disp is
end if;
end Image;
- procedure Disp_Lit (Lit_Type : O_Tnode; Str : String) is
+ -- Disp STR as a literal for scalar type LIT_TYPE.
+ procedure Disp_Lit (Lit_Type : O_Tnode; Known : Boolean; Str : String) is
begin
- if False then
+ if Known and not Disp_All_Types then
Put_Trim (Str);
else
Disp_Tnode_Name (Lit_Type);
@@ -422,8 +425,18 @@ package body Ortho_Debug.Disp is
end if;
end Disp_Lit;
- procedure Disp_Cnode (C : O_Cnode) is
+ -- Display C. If CTYPE is set, this is the known type of C.
+ procedure Disp_Cnode (C : O_Cnode; Ctype : O_Tnode)
+ is
+ Known : constant Boolean := Ctype /= O_Tnode_Null;
begin
+ -- Sanity check.
+ if Known then
+ if Ctype /= C.Ctype then
+ raise Program_Error;
+ end if;
+ end if;
+
case C.Kind is
when OC_Unsigned_Lit =>
if False and then (C.U_Val >= Character'Pos(' ')
@@ -433,18 +446,21 @@ package body Ortho_Debug.Disp is
Put (Character'Val (C.U_Val));
Put (''');
else
- Disp_Lit (C.Ctype, Unsigned_64'Image (C.U_Val));
+ Disp_Lit (C.Ctype, Known, Unsigned_64'Image (C.U_Val));
end if;
when OC_Signed_Lit =>
- Disp_Lit (C.Ctype, Integer_64'Image (C.S_Val));
+ Disp_Lit (C.Ctype, Known, Integer_64'Image (C.S_Val));
when OC_Float_Lit =>
- Disp_Lit (C.Ctype, IEEE_Float_64'Image (C.F_Val));
+ Disp_Lit (C.Ctype, Known, IEEE_Float_64'Image (C.F_Val));
when OC_Boolean_Lit =>
- Disp_Lit (C.Ctype, Get_String (C.B_Id));
+ -- Always disp the type of boolean literals.
+ Disp_Lit (C.Ctype, False, Get_String (C.B_Id));
when OC_Null_Lit =>
- Disp_Lit (C.Ctype, "null");
+ -- Always disp the type of null literals.
+ Disp_Lit (C.Ctype, False, "null");
when OC_Enum_Lit =>
- Disp_Lit (C.Ctype, Get_String (C.E_Name));
+ -- Always disp the type of enum literals.
+ Disp_Lit (C.Ctype, False, Get_String (C.E_Name));
when OC_Sizeof_Lit =>
Disp_Tnode_Name (C.Ctype);
Put ("'sizeof (");
@@ -465,25 +481,34 @@ package body Ortho_Debug.Disp is
when OC_Aggregate =>
declare
El : O_Cnode;
+ El_Type : O_Tnode;
Field : O_Fnode;
begin
Put ('{');
El := C.Aggr_Els;
- if C.Ctype.Kind = ON_Record_Type then
- Field := C.Ctype.Elements;
- else
- Field := null;
- end if;
+ case C.Ctype.Kind is
+ when ON_Record_Type =>
+ Field := C.Ctype.Elements;
+ El_Type := Field.Ftype;
+ when ON_Array_Sub_Type =>
+ Field := null;
+ El_Type := C.Ctype.Base_Type.El_Type;
+ when others =>
+ raise Program_Error;
+ end case;
if El /= null then
loop
Set_Mark;
if Field /= null then
- Put ('.');
- Disp_Ident (Field.Ident);
- Put (" = ");
+ if Disp_All_Types then
+ Put ('.');
+ Disp_Ident (Field.Ident);
+ Put (" = ");
+ end if;
+ El_Type := Field.Ftype;
Field := Field.Next;
end if;
- Disp_Cnode (El.Aggr_Value);
+ Disp_Cnode (El.Aggr_Value, El_Type);
El := El.Aggr_Next;
exit when El = null;
Put (", ");
@@ -492,13 +517,13 @@ package body Ortho_Debug.Disp is
Put ('}');
end;
when OC_Aggr_Element =>
- Disp_Cnode (C.Aggr_Value);
+ Disp_Cnode (C.Aggr_Value, Ctype);
when OC_Union_Aggr =>
Put ('{');
Put ('.');
Disp_Ident (C.Uaggr_Field.Ident);
Put (" = ");
- Disp_Cnode (C.Uaggr_Value);
+ Disp_Cnode (C.Uaggr_Value, C.Uaggr_Field.Ftype);
Put ('}');
when OC_Address =>
Disp_Tnode_Name (C.Ctype);
@@ -518,35 +543,36 @@ package body Ortho_Debug.Disp is
end case;
end Disp_Cnode;
- procedure Disp_Enode (E : O_Enode)
+ -- Disp E whose expected type is ETYPE (may not be set).
+ procedure Disp_Enode (E : O_Enode; Etype : O_Tnode)
is
begin
case E.Kind is
when OE_Lit =>
- Disp_Cnode (E.Lit);
+ Disp_Cnode (E.Lit, Etype);
when OE_Dyadic_Expr_Kind =>
Put ("(");
- Disp_Enode (E.Left);
+ Disp_Enode (E.Left, O_Tnode_Null);
Put (' ');
Disp_Enode_Name (E.Kind);
Put (' ');
- Disp_Enode (E.Right);
+ Disp_Enode (E.Right, E.Left.Rtype);
Put (')');
when OE_Compare_Expr_Kind =>
Disp_Tnode_Name (E.Rtype);
Put ("'(");
- Disp_Enode (E.Left);
+ Disp_Enode (E.Left, O_Tnode_Null);
Put (' ');
Disp_Enode_Name (E.Kind);
Put (' ');
- Disp_Enode (E.Right);
+ Disp_Enode (E.Right, E.Left.Rtype);
Put (')');
when OE_Monadic_Expr_Kind =>
Disp_Enode_Name (E.Kind);
if E.Kind /= OE_Neg_Ov then
Put (' ');
end if;
- Disp_Enode (E.Operand);
+ Disp_Enode (E.Operand, Etype);
when OE_Address =>
Disp_Tnode_Name (E.Rtype);
Put ("'address (");
@@ -560,7 +586,7 @@ package body Ortho_Debug.Disp is
when OE_Convert_Ov =>
Disp_Tnode_Name (E.Rtype);
Put ("'conv (");
- Disp_Enode (E.Conv);
+ Disp_Enode (E.Conv, O_Tnode_Null);
Put (')');
when OE_Function_Call =>
Disp_Dnode_Name (E.Func);
@@ -569,7 +595,7 @@ package body Ortho_Debug.Disp is
when OE_Alloca =>
Disp_Tnode_Name (E.Rtype);
Put ("'alloca (");
- Disp_Enode (E.A_Size);
+ Disp_Enode (E.A_Size, O_Tnode_Null);
Put (')');
when OE_Value =>
Disp_Lnode (E.Value);
@@ -584,17 +610,17 @@ package body Ortho_Debug.Disp is
when OL_Obj =>
Disp_Dnode_Name (Node.Obj);
when OL_Access_Element =>
- Disp_Enode (Node.Acc_Base);
+ Disp_Enode (Node.Acc_Base, O_Tnode_Null);
Put (".all");
when OL_Indexed_Element =>
Disp_Lnode (Node.Array_Base);
Put ('[');
- Disp_Enode (Node.Index);
+ Disp_Enode (Node.Index, O_Tnode_Null);
Put (']');
when OL_Slice =>
Disp_Lnode (Node.Slice_Base);
Put ('[');
- Disp_Enode (Node.Slice_Index);
+ Disp_Enode (Node.Slice_Index, O_Tnode_Null);
Put ("...]");
when OL_Selected_Element =>
Disp_Lnode (Node.Rec_Base);
@@ -685,7 +711,7 @@ package body Ortho_Debug.Disp is
Put ("subarray ");
Disp_Tnode_Name (Atype.Base_Type);
Put ("[");
- Disp_Cnode (Atype.Length);
+ Disp_Cnode (Atype.Length, Atype.Base_Type.Index_Type);
Put ("]");
end case;
end Disp_Tnode;
@@ -792,7 +818,7 @@ package body Ortho_Debug.Disp is
Put ("constant ");
Disp_Ident (Decl.Name);
Put (" := ");
- Disp_Cnode (Decl.Value);
+ Disp_Cnode (Decl.Value, Decl.Dtype);
Put_Line (";");
when ON_Var_Decl =>
Disp_Storage_Name (Decl.Storage);
@@ -851,12 +877,12 @@ package body Ortho_Debug.Disp is
when ON_Assign_Stmt =>
Disp_Lnode (Stmt.Target);
Put (" := ");
- Disp_Enode (Stmt.Value);
+ Disp_Enode (Stmt.Value, Stmt.Target.Rtype);
Put_Line (";");
when ON_Return_Stmt =>
Put ("return ");
if Stmt.Ret_Val /= null then
- Disp_Enode (Stmt.Ret_Val);
+ Disp_Enode (Stmt.Ret_Val, O_Tnode_Null);
end if;
Put_Line (";");
when ON_If_Stmt =>
@@ -875,7 +901,7 @@ package body Ortho_Debug.Disp is
else
Put ("elsif ");
end if;
- Disp_Enode (Stmt.Cond);
+ Disp_Enode (Stmt.Cond, O_Tnode_Null);
Put_Line (" then");
end if;
Add_Tab;
@@ -897,7 +923,7 @@ package body Ortho_Debug.Disp is
Put_Line (";");
when ON_Case_Stmt =>
Put ("case ");
- Disp_Enode (Stmt.Selector);
+ Disp_Enode (Stmt.Selector, O_Tnode_Null);
Put_Line (" is");
Add_Tab;
Disp_Snode (Stmt.Next, Stmt.Case_Last);
@@ -907,6 +933,8 @@ package body Ortho_Debug.Disp is
when ON_When_Stmt =>
declare
Choice: O_Choice;
+ Choice_Type : constant O_Tnode :=
+ Stmt.Branch_Parent.Selector.Rtype;
begin
Rem_Tab;
Choice := Stmt.Choice_List;
@@ -914,11 +942,11 @@ package body Ortho_Debug.Disp is
Put ("when ");
case Choice.Kind is
when ON_Choice_Expr =>
- Disp_Cnode (Choice.Expr);
+ Disp_Cnode (Choice.Expr, Choice_Type);
when ON_Choice_Range =>
- Disp_Cnode (Choice.Low);
+ Disp_Cnode (Choice.Low, Choice_Type);
Put (" ... ");
- Disp_Cnode (Choice.High);
+ Disp_Cnode (Choice.High, Choice_Type);
when ON_Choice_Default =>
Put ("default");
end case;
@@ -970,7 +998,7 @@ package body Ortho_Debug.Disp is
Ctx : Disp_Context;
begin
Push_Context (Interfaces.C_Streams.stdout, Ctx);
- Disp_Enode (N);
+ Disp_Enode (N, O_Tnode_Null);
Put (" : ");
Disp_Tnode_Decl (N.Rtype);
Pop_Context (Ctx);
diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb
index ba02904..a1ef7b8 100644
--- a/ortho/debug/ortho_debug.adb
+++ b/ortho/debug/ortho_debug.adb
@@ -1583,9 +1583,10 @@ package body Ortho_Debug is
N : O_Anode;
begin
Check_Type (Assocs.Interfaces.Dtype, Val.Rtype);
- Assocs.Interfaces := Assocs.Interfaces.Next;
Check_Ref (Val);
- N := new O_Anode_Type'(Next => null, Formal => null, Actual => Val);
+ N := new O_Anode_Type'(Next => null,
+ Formal => Assocs.Interfaces, Actual => Val);
+ Assocs.Interfaces := Assocs.Interfaces.Next;
if Assocs.Last = null then
Assocs.First := N;
else
@@ -1753,7 +1754,6 @@ package body Ortho_Debug is
procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode)
is
- pragma Unreferenced (Block);
subtype O_Snode_Case_Type is O_Snode_Type (ON_Case_Stmt);
N : O_Snode;
begin
@@ -1773,6 +1773,7 @@ package body Ortho_Debug is
Case_Last => null,
Selector => Value,
Branches => null);
+ Block.Case_Stmt := N;
Add_Stmt (N);
Push_Stmt_Scope (new Stmt_Case_Scope_Type'(Kind => Stmt_Case,
Parent => N,
@@ -1784,7 +1785,6 @@ package body Ortho_Debug is
procedure Start_Choice (Block : in out O_Case_Block)
is
- pragma Unreferenced (Block);
N : O_Snode;
begin
if Current_Stmt_Scope.Kind /= Stmt_Case then
@@ -1800,6 +1800,7 @@ package body Ortho_Debug is
N.all := O_Snode_Type'(Kind => ON_When_Stmt,
Next => null,
Lineno => 0,
+ Branch_Parent => Block.Case_Stmt,
Choice_List => null,
Next_Branch => null);
if Current_Stmt_Scope.Last_Branch = null then
diff --git a/ortho/debug/ortho_debug.private.ads b/ortho/debug/ortho_debug.private.ads
index 20bcae2..09d9b4c 100644
--- a/ortho/debug/ortho_debug.private.ads
+++ b/ortho/debug/ortho_debug.private.ads
@@ -390,9 +390,12 @@ private
Loop_Id : O_Snode;
when ON_Case_Stmt =>
Selector : O_Enode;
+ -- Simply linked list of branches
Branches : O_Snode;
Case_Last : O_Snode;
when ON_When_Stmt =>
+ -- The corresponding 'case'
+ Branch_Parent : O_Snode;
Choice_List : O_Choice;
Next_Branch : O_Snode;
when ON_Call_Stmt =>
@@ -443,7 +446,7 @@ private
Last : O_Cnode;
end record;
type O_Case_Block is record
- null;
+ Case_Stmt : O_Snode;
end record;
type O_If_Block is record
generated by cgit (git 2.34.1) at 2024-12-21 10:27:26 +0000