-- Display the code from the ortho debug tree. -- Copyright (C) 2005 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free -- Software Foundation; either version 2, or (at your option) any later -- version. -- -- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -- WARRANTY; without even the implied warranty of MERCHANTABILITY or -- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- for more details. -- -- You should have received a copy of the GNU General Public License -- along with GCC; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. package body Ortho_Debug.Disp is Disp_All_Types : constant Boolean := False; package Formated_Output is use Interfaces.C_Streams; type Disp_Context is limited private; procedure Init_Context (File : FILEs); -- Save the current context, and create a new one. procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context); -- Restore a previous context, saved by Push_Context. procedure Pop_Context (Prev_Ctx : Disp_Context); procedure Put (Str : String); procedure Put_Keyword (Str : String); procedure Put_Line (Str : String); -- Add a tabulation. -- Every new line will start at this tabulation. procedure Add_Tab; -- Removed a tabulation. -- The next new line will start at the previous tabulation. procedure Rem_Tab; -- Flush the current output. procedure Flush; -- Return TRUE if the ident level is nul. function Is_Top return Boolean; procedure Put_Tab; procedure New_Line; procedure Put (C : Character); procedure Put_Trim (Str : String); procedure Set_Mark; -- Flush to disk. Only for debugging in case of crash. procedure Flush_File; pragma Unreferenced (Flush_File); private type Disp_Context is record -- File where the info are written to. File : FILEs; -- Line number of the line to be written. Lineno : Natural; -- Buffer for the current line. Line : String (1 .. 256); -- Number of characters currently in the line. Line_Len : Natural; -- Current tabulation. Tab : Natural; -- Tabulation to be used for the next line. Next_Tab : Natural; Mark : Natural; end record; end Formated_Output; package body Formated_Output is -- The current context. Ctx : Disp_Context; procedure Init_Context (File : FILEs) is begin Ctx.File := File; Ctx.Lineno := 1; Ctx.Line_Len := 0; Ctx.Tab := 0; Ctx.Next_Tab := 0; Ctx.Mark := 0; end Init_Context; procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context) is begin Prev_Ctx := Ctx; Init_Context (File); end Push_Context; -- Restore a previous context, saved by Push_Context. procedure Pop_Context (Prev_Ctx : Disp_Context) is begin Flush; Ctx := Prev_Ctx; end Pop_Context; procedure Flush is Status : size_t; Res : int; pragma Unreferenced (Status, Res); begin if Ctx.Line_Len > 0 then Status := fwrite (Ctx.Line'Address, size_t (Ctx.Line_Len), 1, Ctx.File); Res := fputc (Character'Pos (ASCII.Lf), Ctx.File); Ctx.Line_Len := 0; end if; Ctx.Mark := 0; end Flush; function Is_Top return Boolean is begin return Ctx.Tab = 0; end Is_Top; procedure Put_Tab is Tab : Natural := Ctx.Next_Tab; Max_Tab : constant Natural := 40; begin if Tab > Max_Tab then -- Limit indentation length, to limit line length. Tab := Max_Tab; end if; Ctx.Line (1 .. Tab) := (others => ' '); Ctx.Line_Len := Tab; Ctx.Next_Tab := Ctx.Tab + 2; end Put_Tab; procedure Put (Str : String) is Saved : String (1 .. 80); Len : Natural; begin if Ctx.Line_Len + Str'Length >= 80 then if Ctx.Mark > 0 then Len := Ctx.Line_Len - Ctx.Mark + 1; Saved (1 .. Len) := Ctx.Line (Ctx.Mark .. Ctx.Line_Len); Ctx.Line_Len := Ctx.Mark - 1; Flush; Put_Tab; Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Len) := Saved (1 .. Len); Ctx.Line_Len := Ctx.Line_Len + Len; else Flush; end if; end if; if Ctx.Line_Len = 0 then Put_Tab; end if; Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Str'Length) := Str; Ctx.Line_Len := Ctx.Line_Len + Str'Length; end Put; procedure Put_Keyword (Str : String) is Kw : String (Str'Range); begin -- Convert to uppercase for I in Str'Range loop pragma Assert (Str (I) in 'a' .. 'z'); Kw (I) := Character'Val (Character'Pos ('A') + Character'Pos (Str (I)) - Character'Pos ('a')); end loop; Put (Kw); end Put_Keyword; procedure Put_Trim (Str : String) is begin for I in Str'Range loop if Str (I) /= ' ' then Put (Str (I .. Str'Last)); return; end if; end loop; end Put_Trim; procedure Put_Line (Str : String) is begin Put (Str); Flush; Ctx.Next_Tab := Ctx.Tab; end Put_Line; procedure New_Line is Status : int; pragma Unreferenced (Status); begin if Ctx.Line_Len > 0 then Flush; else Status := fputc (Character'Pos (ASCII.LF), Ctx.File); end if; Ctx.Next_Tab := Ctx.Tab; end New_Line; procedure Put (C : Character) is S : constant String (1 .. 1) := (1 => C); begin Put (S); end Put; -- Add a tabulation. -- Every new line will start at this tabulation. procedure Add_Tab is begin Ctx.Tab := Ctx.Tab + 2; Ctx.Next_Tab := Ctx.Tab; end Add_Tab; -- Removed a tabulation. -- The next new line will start at the previous tabulation. procedure Rem_Tab is begin Ctx.Tab := Ctx.Tab - 2; Ctx.Next_Tab := Ctx.Tab; end Rem_Tab; procedure Set_Mark is begin Ctx.Mark := Ctx.Line_Len; end Set_Mark; procedure Flush_File is Status : int; pragma Unreferenced (Status); begin Flush; Status := fflush (Ctx.File); end Flush_File; end Formated_Output; use Formated_Output; procedure Init_Context (File : Interfaces.C_Streams.FILEs) is begin Formated_Output.Init_Context (File); end Init_Context; procedure Disp_Enode (E : O_Enode; Etype : O_Tnode); procedure Disp_Lnode (Node : O_Lnode); procedure Disp_Gnode (Node : O_Gnode); procedure Disp_Snode (First, Last : O_Snode); procedure Disp_Dnode (Decl : O_Dnode); procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean); procedure Disp_Ident (Id : O_Ident) is begin Put (Get_String (Id)); end Disp_Ident; procedure Disp_Tnode_Name (Atype : O_Tnode) is begin Disp_Tnode (Atype, False); end Disp_Tnode_Name; procedure Disp_Dnode_Name (Decl : O_Dnode) is begin Disp_Ident (Decl.Name); end Disp_Dnode_Name; procedure Disp_Loop_Name (Stmt : O_Snode) is begin Put_Keyword ("loop"); Put (Natural'Image (Stmt.Loop_Level)); end Disp_Loop_Name; function Get_Enode_Name (Kind : OE_Kind) return String is begin case Kind is -- when OE_Boolean_Lit => -- return "boolean_lit"; -- when OE_Unsigned_Lit => -- return "unsigned_lit"; -- when OE_Signed_Lit => -- return "signed lit"; -- when OE_Float_Lit => -- return "float lit"; -- when OE_Null_Lit => -- return "null lit"; -- when OE_Enum_Lit => -- return "enum lit"; -- when OE_Sizeof_Lit => -- return "sizeof lit"; -- when OE_Offsetof_Lit => -- return "offsetof lit"; -- when OE_Aggregate => -- return "aggregate"; -- when OE_Aggr_Element => -- return "aggr_element"; -- when OE_Union_Aggr => -- return "union aggr"; when OE_Lit => return "lit"; when OE_Add_Ov => return "+#"; when OE_Sub_Ov => return "-#"; when OE_Mul_Ov => return "*#"; when OE_Div_Ov => return "/#"; when OE_Rem_Ov => return "rem#"; when OE_Mod_Ov => return "mod#"; when OE_Exp_Ov => return "**#"; when OE_And => return "and"; when OE_Or => return "or"; when OE_Xor => return "xor"; when OE_Not => return "not"; when OE_Neg_Ov => return "-"; when OE_Abs_Ov => return "abs"; when OE_Eq => return "="; when OE_Neq => return "/="; when OE_Le => return "<="; when OE_Lt => return "<"; when OE_Ge => return ">="; when OE_Gt => return ">"; when OE_Function_Call => return "function call"; when OE_Convert_Ov => return "convert_ov"; when OE_Convert => return "convert"; when OE_Address => return "address"; when OE_Unchecked_Address => return "unchecked_address"; -- when OE_Subprogram_Address => -- return "subprg_address"; when OE_Alloca => return "alloca"; when OE_Value => return "value"; when OE_Nil => return "??"; end case; end Get_Enode_Name; function Get_Lnode_Name (Kind : OL_Kind) return String is begin case Kind is when OL_Obj => return "obj"; when OL_Indexed_Element => return "indexed_element"; when OL_Slice => return "slice"; when OL_Selected_Element => return "selected_element"; when OL_Access_Element => return "access_element"; -- when OL_Param_Ref => -- return "param_ref"; -- when OL_Var_Ref => -- return "var_ref"; -- when OL_Const_Ref => -- return "const_ref"; end case; end Get_Lnode_Name; pragma Unreferenced (Get_Lnode_Name); procedure Disp_Enode_Name (Kind : OE_Kind) is begin Put (Get_Enode_Name (Kind)); end Disp_Enode_Name; procedure Disp_Assoc_List (Head : O_Anode) is El : O_Anode; begin El := Head; Put ("("); if El /= null then loop Disp_Enode (El.Actual, El.Formal.Dtype); El := El.Next; exit when El = null; Put (", "); end loop; end if; Put (")"); end Disp_Assoc_List; function Image (Lit : Integer) return String is S : constant String := Integer'Image (Lit); begin if S (1) = ' ' then return S (2 .. S'Length); else return S; end if; end Image; -- Disp STR as a literal for scalar type LIT_TYPE. procedure Disp_Lit (Lit_Type : O_Tnode; Known : Boolean; Str : String) is begin if Known and not Disp_All_Types then Put_Trim (Str); else Disp_Tnode_Name (Lit_Type); Put ("'["); Put_Trim (Str); Put (']'); end if; end Disp_Lit; Xdigit : constant array (0 .. 15) of Character := "0123456789abcdef"; procedure Disp_Float_Lit (Lit_Type : O_Tnode; Known : Boolean; Val : IEEE_Float_64) is pragma Assert (IEEE_Float_64'Machine_Radix = 2); pragma Assert (IEEE_Float_64'Machine_Mantissa = 53); Exp : Integer; Man : Unsigned_64; -- Res: sign(1) + 0x(2) + Man(53 / 3 ~= 18) + p(1) + sing(1) + exp(4) Str : String (1 .. 1 + 2 + 18 + 1 + 1 + 4); P : Natural; Neg : Boolean; begin Exp := IEEE_Float_64'Exponent (Val) - 1; Man := Unsigned_64 (abs (IEEE_Float_64'Fraction (Val)) * 2.0 ** 53); -- Use decimal representation if there is no digit after the dot. if Man = 0 then Disp_Lit (Lit_Type, Known, "0.0"); else pragma Assert (Shift_Right (Man, 52) = 1); -- Remove hidden 1. Man := Man and (2**52 - 1); -- Remove trailing hex 0. while Man /= 0 and (Man rem 16) = 0 loop Man := Man / 16; end loop; -- Exponent. P := Str'Last; if Exp < 0 then Neg := True; Exp := -Exp; else Neg := False; end if; loop Str (P) := Xdigit (Exp rem 10); P := P - 1; Exp := Exp / 10; exit when Exp = 0; end loop; if Neg then Str (P) := '-'; P := P - 1; end if; Str (P) := 'p'; P := P - 1; -- Mantissa. loop Str (P) := Xdigit (Natural (Man and 15)); P := P - 1; Man := Man / 16; exit when Man = 0; end loop; P := P - 4; Str (P + 1) := '0'; Str (P + 2) := 'x'; Str (P + 3) := '1'; Str (P + 4) := '.'; if Val < 0.0 then Str (P) := '-'; P := P - 1; end if; Disp_Lit (Lit_Type, Known, Str (P + 1 .. Str'Last)); end if; end Disp_Float_Lit; -- 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 case C.Kind is when OC_Unsigned_Lit => if False and then (C.U_Val >= Character'Pos(' ') and C.U_Val <= Character'Pos ('~')) then Put ('''); Put (Character'Val (C.U_Val)); Put ('''); else Disp_Lit (C.Ctype, Known, Unsigned_64'Image (C.U_Val)); end if; when OC_Signed_Lit => Disp_Lit (C.Ctype, Known, Integer_64'Image (C.S_Val)); when OC_Float_Lit => Disp_Float_Lit (C.Ctype, Known, C.F_Val); when OC_Boolean_Lit => -- Always disp the type of boolean literals. Disp_Lit (C.Ctype, False, Get_String (C.B_Id)); when OC_Null_Lit => -- Always disp the type of null literals. Disp_Tnode_Name (C.Ctype); Put ("'["); Put_Keyword ("null"); Put (']'); when OC_Default_Lit => -- Always disp the type of default literals. Disp_Tnode_Name (C.Ctype); Put ("'["); Put_Keyword ("default"); Put (']'); when OC_Enum_Lit => -- 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 ("); 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 ("); Disp_Tnode_Name (C.S_Type); Put (")"); when OC_Offsetof_Lit => Disp_Tnode_Name (C.Ctype); Put ("'offsetof ("); Disp_Tnode_Name (C.Off_Field.Parent); Put ("."); Disp_Ident (C.Off_Field.Ident); Put (")"); when OC_Array_Aggregate => declare El : O_Cnode; El_Type : O_Tnode; begin El := C.Arr_Els; El_Type := Get_Array_El_Type (C.Ctype); Put ('['); Put_Trim (Unsigned_32'Image (C.Arr_Len)); Put (']'); Put ('{'); if El /= null then loop Set_Mark; Disp_Cnode (El.Aggr_Value, El_Type); El := El.Aggr_Next; exit when El = null; Put (", "); end loop; end if; Put ('}'); end; when OC_Record_Aggregate => declare El : O_Cnode; El_Type : O_Tnode; Field : O_Fnode; begin Put ('{'); El := C.Rec_Els; pragma Assert (C.Ctype.Kind = ON_Record_Type); Field := C.Ctype.Rec_Elements; if El /= null then loop Set_Mark; if Disp_All_Types then Put ('.'); Disp_Ident (Field.Ident); Put (" = "); end if; El_Type := Field.Ftype; Field := Field.Next; Disp_Cnode (El.Aggr_Value, El_Type); El := El.Aggr_Next; exit when El = null; Put (", "); end loop; end if; Put ('}'); end; when OC_Aggr_Element => Disp_Cnode (C.Aggr_Value, Ctype); when OC_Union_Aggr => Put ('{'); Put ('.'); Disp_Ident (C.Uaggr_Field.Ident); Put (" = "); Disp_Cnode (C.Uaggr_Value, C.Uaggr_Field.Ftype); Put ('}'); when OC_Address => Disp_Tnode_Name (C.Ctype); Put ("'address ("); Disp_Gnode (C.Addr_Global); Put (")"); when OC_Unchecked_Address => Disp_Tnode_Name (C.Ctype); Put ("'unchecked_address ("); Disp_Gnode (C.Addr_Global); Put (")"); when OC_Subprogram_Address => Disp_Tnode_Name (C.Ctype); Put ("'subprg_addr ("); Disp_Dnode_Name (C.Addr_Decl); Put (")"); end case; end Disp_Cnode; function Is_Neg_Neg (E : O_Enode) return Boolean is Lit : O_Cnode; begin pragma Assert (E.Kind = OE_Neg_Ov); case E.Operand.Kind is when OE_Neg_Ov => return True; when OE_Lit => Lit := E.Operand.Lit; case Lit.Kind is when OC_Signed_Lit => return Lit.S_Val < 0; when OC_Float_Lit => return Lit.F_Val < 0.0; when others => null; end case; when others => null; end case; return False; end Is_Neg_Neg; -- 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, Etype); when OE_Dyadic_Expr_Kind => Put ("("); Disp_Enode (E.Left, O_Tnode_Null); Put (' '); case E.Kind is when OE_Rem_Ov => Put_Keyword ("rem"); Put ('#'); when OE_Mod_Ov => Put_Keyword ("mod"); Put ('#'); when OE_And => Put_Keyword ("and"); when OE_Or => Put_Keyword ("or"); when OE_Xor => Put_Keyword ("xor"); when others => Disp_Enode_Name (E.Kind); end case; Put (' '); Disp_Enode (E.Right, E.Left.Rtype); Put (')'); when OE_Compare_Expr_Kind => Disp_Tnode_Name (E.Rtype); Put ("'("); Disp_Enode (E.Left, O_Tnode_Null); Put (' '); Disp_Enode_Name (E.Kind); Put (' '); Disp_Enode (E.Right, E.Left.Rtype); Put (')'); when OE_Monadic_Expr_Kind => case E.Kind is when OE_Not => Put_Keyword ("not"); when OE_Abs_Ov => Put_Keyword ("abs"); when others => Disp_Enode_Name (E.Kind); end case; -- Don't print space after '-' unless the operand is also '-'. -- (avoid to print --, which is a comment). if E.Kind /= OE_Neg_Ov or else Is_Neg_Neg (E) then Put (' '); end if; Disp_Enode (E.Operand, Etype); when OE_Address => Disp_Tnode_Name (E.Rtype); Put ("'address ("); Disp_Lnode (E.Lvalue); Put (")"); when OE_Unchecked_Address => Disp_Tnode_Name (E.Rtype); Put ("'unchecked_address ("); Disp_Lnode (E.Lvalue); Put (")"); when OE_Convert_Ov => Disp_Tnode_Name (E.Rtype); Put ("'conv# ("); Disp_Enode (E.Conv, O_Tnode_Null); Put (')'); when OE_Convert => Disp_Tnode_Name (E.Rtype); Put ("'conv ("); Disp_Enode (E.Conv, O_Tnode_Null); Put (')'); when OE_Function_Call => Disp_Dnode_Name (E.Func); Put (' '); Disp_Assoc_List (E.Assoc); when OE_Alloca => Disp_Tnode_Name (E.Rtype); Put ("'alloca ("); Disp_Enode (E.A_Size, O_Tnode_Null); Put (')'); when OE_Value => Disp_Lnode (E.Value); when OE_Nil => null; end case; end Disp_Enode; procedure Disp_Lnode (Node : O_Lnode) is begin case Node.Kind is when OL_Obj => Disp_Dnode_Name (Node.Obj); when OL_Access_Element => Disp_Enode (Node.Acc_Base, O_Tnode_Null); Put ("."); Put_Keyword ("all"); when OL_Indexed_Element => Disp_Lnode (Node.Array_Base); Put ('['); Disp_Enode (Node.Index, O_Tnode_Null); Put (']'); when OL_Slice => Disp_Lnode (Node.Slice_Base); Put ('['); Disp_Enode (Node.Slice_Index, O_Tnode_Null); Put ("...]"); when OL_Selected_Element => Disp_Lnode (Node.Rec_Base); Put ('.'); Disp_Ident (Node.Rec_El.Ident); end case; end Disp_Lnode; procedure Disp_Gnode (Node : O_Gnode) is begin case Node.Kind is when OG_Decl => Disp_Dnode_Name (Node.Decl); when OG_Selected_Element => Disp_Gnode (Node.Rec_Base); Put ('.'); Disp_Ident (Node.Rec_El.Ident); end case; end Disp_Gnode; procedure Disp_Fnodes (First : O_Fnode) is El : O_Fnode; begin Add_Tab; El := First; while El /= null loop Disp_Ident (El.Ident); Put (": "); Disp_Tnode (El.Ftype, False); Put_Line (";"); El := El.Next; end loop; Rem_Tab; end Disp_Fnodes; procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean) is begin if not Full and Atype.Decl /= null then Disp_Ident (Atype.Decl.Name); return; end if; case Atype.Kind is when ON_Boolean_Type => Put_Keyword ("boolean"); Put (" {"); Disp_Ident (Atype.False_N.B_Id); Put (", "); Disp_Ident (Atype.True_N.B_Id); Put ("}"); when ON_Unsigned_Type => Put_Keyword ("unsigned"); Put (" ("); Put_Trim (Natural'Image (Atype.Int_Size)); Put (")"); when ON_Signed_Type => Put_Keyword ("signed"); Put (" ("); Put_Trim (Natural'Image (Atype.Int_Size)); Put (")"); when ON_Float_Type => Put_Keyword ("float"); when ON_Enum_Type => declare El : O_Cnode; begin Put_Keyword ("enum"); Put (" {"); El := Atype.Literals; while El /= O_Cnode_Null loop Set_Mark; Disp_Ident (El.E_Name); if False then Put (" = "); Put (Image (El.E_Val)); end if; El := El.E_Next; exit when El = O_Cnode_Null; Put (", "); end loop; Put ("}"); end; when ON_Array_Type => Put_Keyword ("array"); Put (" ["); Disp_Tnode (Atype.Index_Type, False); Put ("] "); Put_Keyword ("of"); Put (" "); Disp_Tnode (Atype.El_Type, False); when ON_Access_Type => Put_Keyword ("access"); Put (" "); if Atype.D_Type /= O_Tnode_Null then Disp_Tnode (Atype.D_Type, False); end if; when ON_Record_Type => Put_Keyword ("record"); New_Line; 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.Rec_Elements); Put_Keyword ("end"); Put (" "); Put_Keyword ("union"); 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; procedure Disp_Storage_Name (Storage : O_Storage) is begin case Storage is when O_Storage_External => Put_Keyword ("external"); when O_Storage_Public => Put_Keyword ("public"); when O_Storage_Private => Put_Keyword ("private"); when O_Storage_Local => Put_Keyword ("local"); end case; end Disp_Storage_Name; procedure Disp_Decls (Decls : O_Dnode) is El : O_Dnode; begin El := Decls; while El /= null loop Disp_Dnode (El); El := El.Next; if Is_Top then -- NOTE: some declaration does not disp anything, so there may be -- double new line. New_Line; end if; end loop; end Disp_Decls; procedure Disp_Function_Decl (Decl : O_Dnode) is begin Disp_Storage_Name (Decl.Storage); Put (" "); if Decl.Dtype = null then Put_Keyword ("procedure"); else Put_Keyword ("function"); end if; Put (" "); Disp_Ident (Decl.Name); Put_Line (" ("); Add_Tab; declare El : O_Dnode; begin El := Decl.Interfaces; if El /= null then loop Disp_Dnode (El); El := El.Next; exit when El = null; Put_Line (";"); end loop; end if; Put (")"); end; if Decl.Dtype /= null then New_Line; Put_Keyword ("return"); Put (" "); Disp_Tnode (Decl.Dtype, False); end if; Rem_Tab; end Disp_Function_Decl; procedure Disp_Dnode (Decl : O_Dnode) is begin case Decl.Kind is when ON_Type_Decl => Put_Keyword ("type"); Put (" "); Disp_Ident (Decl.Name); Put (" "); Put_Keyword ("is"); Put (" "); if not Decl.Dtype.Uncomplete then Disp_Tnode (Decl.Dtype, True); else case Decl.Dtype.Kind is when ON_Record_Type => Put_Keyword ("record"); when ON_Access_Type => Put_Keyword ("access"); when others => raise Program_Error; end case; end if; Put_Line (";"); when ON_Completed_Type_Decl => Put_Keyword ("type"); Put (" "); Disp_Ident (Decl.Name); Put (" "); Put_Keyword ("is"); Put (" "); Disp_Tnode (Decl.Dtype, True); Put_Line (";"); when ON_Const_Decl => Disp_Storage_Name (Decl.Storage); Put (" "); Put_Keyword ("constant"); Put (" "); Disp_Ident (Decl.Name); Put (" : "); Disp_Tnode_Name (Decl.Dtype); Put_Line (";"); when ON_Init_Value => Put_Keyword ("constant"); Put (" "); Disp_Ident (Decl.Name); Put (" := "); Disp_Cnode (Decl.Value, Decl.Dtype); Put_Line (";"); when ON_Var_Decl => Disp_Storage_Name (Decl.Storage); Put (" "); Put_Keyword ("var"); Put (" "); Disp_Ident (Decl.Name); Put (" : "); Disp_Tnode_Name (Decl.Dtype); Put_Line (";"); when ON_Function_Decl => if Decl.Next = null or Decl.Next /= Decl.Func_Body then -- This is a forward/external declaration. Disp_Function_Decl (Decl); Put_Line (";"); end if; when ON_Function_Body => Disp_Function_Decl (Decl.Func_Decl); New_Line; Disp_Snode (Decl.Func_Stmt, Decl.Func_Stmt); when ON_Interface_Decl => Disp_Ident (Decl.Name); Put (": "); Disp_Tnode (Decl.Dtype, False); when ON_Debug_Line_Decl => Put_Line ("--#" & Natural'Image (Decl.Line)); when ON_Debug_Comment_Decl => Put_Line ("-- " & Decl.Comment.all); when ON_Debug_Filename_Decl => Put_Line ("--F " & Decl.Filename.all); end case; end Disp_Dnode; procedure Disp_Snode (First : O_Snode; Last : O_Snode) is Stmt : O_Snode; begin Stmt := First; loop --if Stmt.Kind = ON_Elsif_Stmt or Stmt.Kind = ON_When_Stmt then -- Put_Indent (Tab - 1); --else -- Put_Indent (Tab); --end if; case Stmt.Kind is when ON_Declare_Stmt => Put_Keyword ("declare"); New_Line; Add_Tab; Disp_Decls (Stmt.Decls); Rem_Tab; Put_Keyword ("begin"); New_Line; Add_Tab; if Stmt.Stmts /= null then Disp_Snode (Stmt.Stmts, null); end if; Rem_Tab; Put_Keyword ("end"); Put_Line (";"); when ON_Assign_Stmt => Disp_Lnode (Stmt.Target); Put (" := "); Disp_Enode (Stmt.Value, Stmt.Target.Rtype); Put_Line (";"); when ON_Return_Stmt => Put_Keyword ("return"); Put (" "); if Stmt.Ret_Val /= null then Disp_Enode (Stmt.Ret_Val, O_Tnode_Null); end if; Put_Line (";"); when ON_If_Stmt => Add_Tab; Disp_Snode (Stmt.Next, Stmt.If_Last); Stmt := Stmt.If_Last; Rem_Tab; Put_Keyword ("end"); Put (" "); Put_Keyword ("if"); Put_Line (";"); when ON_Elsif_Stmt => Rem_Tab; if Stmt.Cond = null then Put_Keyword ("else"); New_Line; else if First = Stmt then Put_Keyword ("if"); else Put_Keyword ("elsif"); end if; Put (" "); Disp_Enode (Stmt.Cond, O_Tnode_Null); Put (" "); Put_Keyword ("then"); New_Line; end if; Add_Tab; when ON_Loop_Stmt => Disp_Loop_Name (Stmt); Put_Line (":"); Add_Tab; if Stmt.Loop_Last /= Stmt then -- Only if the loop is not empty. Disp_Snode (Stmt.Next, Stmt.Loop_Last); end if; Stmt := Stmt.Loop_Last; Rem_Tab; Put_Keyword ("end"); Put (" "); Put_Keyword ("loop"); Put_Line (";"); when ON_Exit_Stmt => Put_Keyword ("exit"); Put (" "); Disp_Loop_Name (Stmt.Loop_Id); Put_Line (";"); when ON_Next_Stmt => Put_Keyword ("next"); Put (" "); Disp_Loop_Name (Stmt.Loop_Id); Put_Line (";"); when ON_Case_Stmt => Put_Keyword ("case"); Put (" "); Disp_Enode (Stmt.Selector, O_Tnode_Null); Put (" "); Put_Keyword ("is"); Put_Line (""); Add_Tab; Disp_Snode (Stmt.Next, Stmt.Case_Last); Stmt := Stmt.Case_Last; Rem_Tab; Put_Keyword ("end"); Put (" "); Put_Keyword ("case"); Put_Line (";"); 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; Put_Keyword ("when"); Put (" "); loop case Choice.Kind is when ON_Choice_Expr => Disp_Cnode (Choice.Expr, Choice_Type); when ON_Choice_Range => Disp_Cnode (Choice.Low, Choice_Type); Put (" ... "); Disp_Cnode (Choice.High, Choice_Type); when ON_Choice_Default => Put_Keyword ("default"); end case; Choice := Choice.Next; exit when Choice = null; Put_Line (","); Put (" "); end loop; Put_Line (" =>"); Add_Tab; end; when ON_Call_Stmt => Disp_Dnode_Name (Stmt.Proc); Put (' '); Disp_Assoc_List (Stmt.Assoc); Put_Line (";"); when ON_Debug_Line_Stmt => Put_Line ("--#" & Natural'Image (Stmt.Line)); when ON_Debug_Comment_Stmt => Put_Line ("-- " & Stmt.Comment.all); end case; exit when Stmt = Last; Stmt := Stmt.Next; exit when Stmt = null and Last = null; end loop; end Disp_Snode; procedure Disp_Ortho (Decls : O_Snode) is begin Disp_Decls (Decls.Decls); Flush; end Disp_Ortho; procedure Disp_Tnode_Decl (N : O_Tnode) is begin if N.Decl /= O_Dnode_Null then Disp_Ident (N.Decl.Name); Put (" : "); end if; Disp_Tnode (N, True); end Disp_Tnode_Decl; procedure Debug_Tnode (N : O_Tnode) is Ctx : Disp_Context; begin Push_Context (Interfaces.C_Streams.stdout, Ctx); Disp_Tnode_Decl (N); Pop_Context (Ctx); end Debug_Tnode; procedure Debug_Enode (N : O_Enode) is Ctx : Disp_Context; begin Push_Context (Interfaces.C_Streams.stdout, Ctx); Disp_Enode (N, O_Tnode_Null); Put (" : "); Disp_Tnode_Decl (N.Rtype); Pop_Context (Ctx); end Debug_Enode; procedure Debug_Fnode (N : O_Fnode) is Ctx : Disp_Context; begin Push_Context (Interfaces.C_Streams.stdout, Ctx); Disp_Ident (N.Ident); Put (": "); Disp_Tnode (N.Ftype, False); Pop_Context (Ctx); end Debug_Fnode; procedure Debug_Dnode (N : O_Dnode) is Ctx : Disp_Context; begin Push_Context (Interfaces.C_Streams.stdout, Ctx); Disp_Dnode (N); Pop_Context (Ctx); end Debug_Dnode; procedure Debug_Lnode (N : O_Lnode) is Ctx : Disp_Context; begin Push_Context (Interfaces.C_Streams.stdout, Ctx); Disp_Lnode (N); Put (" : "); Disp_Tnode_Decl (N.Rtype); Pop_Context (Ctx); end Debug_Lnode; procedure Debug_Snode (N : O_Snode) is Ctx : Disp_Context; begin Push_Context (Interfaces.C_Streams.stdout, Ctx); Disp_Snode (N, null); Pop_Context (Ctx); end Debug_Snode; pragma Unreferenced (Debug_Tnode, Debug_Enode, Debug_Fnode, Debug_Dnode, Debug_Lnode, Debug_Snode); end Ortho_Debug.Disp;