diff options
Diffstat (limited to 'ortho/debug')
| -rw-r--r-- | ortho/debug/Makefile | 47 | ||||
| -rw-r--r-- | ortho/debug/ortho_debug-disp.adb | 1064 | ||||
| -rw-r--r-- | ortho/debug/ortho_debug-disp.ads | 29 | ||||
| -rw-r--r-- | ortho/debug/ortho_debug-main.adb | 151 | ||||
| -rw-r--r-- | ortho/debug/ortho_debug.adb | 1931 | ||||
| -rw-r--r-- | ortho/debug/ortho_debug.private.ads | 467 | ||||
| -rw-r--r-- | ortho/debug/ortho_debug_front.ads | 20 | ||||
| -rw-r--r-- | ortho/debug/ortho_ident.ads | 20 | ||||
| -rw-r--r-- | ortho/debug/ortho_ident_hash.adb | 72 | ||||
| -rw-r--r-- | ortho/debug/ortho_ident_hash.ads | 46 | ||||
| -rw-r--r-- | ortho/debug/ortho_ident_simple.adb | 44 | ||||
| -rw-r--r-- | ortho/debug/ortho_ident_simple.ads | 31 | ||||
| -rw-r--r-- | ortho/debug/ortho_nodes.ads | 21 |
13 files changed, 0 insertions, 3943 deletions
diff --git a/ortho/debug/Makefile b/ortho/debug/Makefile deleted file mode 100644 index 0c15111..0000000 --- a/ortho/debug/Makefile +++ /dev/null @@ -1,47 +0,0 @@ -# -*- Makefile -*- for the ortho-code back-end -# 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. -BE=debug -ortho_srcdir=.. - -orthobe_srcdir=$(ortho_srcdir)/$(BE) - -GNATMAKE=gnatmake -CC=gcc -CFLAGS=-g -ALL_GNAT_FLAGS=-pipe -g -gnato -gnatwl -gnatf -gnaty3befhkmr -gnatwu -GNATMAKE_FLAGS=-m $(ALL_GNAT_FLAGS) $(GNAT_FLAGS) -aI$(ortho_srcdir) -aI$(orthobe_srcdir) -aI. -#LARGS=-largs -static -SED=sed - -all: $(ortho_exec) - - -$(ortho_exec): force $(ortho_srcdir)/$(BE)/ortho_debug.ads - gnatmake -o $@ $(GNATMAKE_FLAGS) ortho_debug-main -bargs -E $(LARGS) - -clean: - $(RM) -f *.o *.ali *~ b~*.ad? ortho_nodes-main - $(RM) ortho_debug.ads - -force: - -ORTHO_BASENAME=ortho_debug - -# Automatically build ortho_debug.ads from ortho_node.common.ads and -# ortho_debug.private.ads -include $(ortho_srcdir)/Makefile.inc diff --git a/ortho/debug/ortho_debug-disp.adb b/ortho/debug/ortho_debug-disp.adb deleted file mode 100644 index 2725668..0000000 --- a/ortho/debug/ortho_debug-disp.adb +++ /dev/null @@ -1,1064 +0,0 @@ --- 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_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_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_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 ("loop" & 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_And_Then => - return "and_then"; - when OE_Or_Else => - return "or_else"; - - 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_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; - - -- 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(' ') - 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_Lit (C.Ctype, Known, IEEE_Float_64'Image (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_Lit (C.Ctype, False, "null"); - 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_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_Aggregate => - declare - El : O_Cnode; - El_Type : O_Tnode; - Field : O_Fnode; - begin - Put ('{'); - El := C.Aggr_Els; - 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 - 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, 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_Dnode_Name (C.Decl); - Put (")"); - when OC_Unchecked_Address => - Disp_Tnode_Name (C.Ctype); - Put ("'unchecked_address ("); - Disp_Dnode_Name (C.Decl); - Put (")"); - when OC_Subprogram_Address => - Disp_Tnode_Name (C.Ctype); - Put ("'subprg_addr ("); - Disp_Dnode_Name (C.Decl); - Put (")"); - end case; - end Disp_Cnode; - - -- 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 (' '); - Disp_Enode_Name (E.Kind); - 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 => - Disp_Enode_Name (E.Kind); - if E.Kind /= OE_Neg_Ov 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_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 (".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); --- when OL_Var_Ref --- | OL_Const_Ref --- | OL_Param_Ref => --- Disp_Dnode_Name (Node.Decl); - end case; - end Disp_Lnode; - - 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 ("boolean {"); - Disp_Ident (Atype.False_N.B_Id); - Put (", "); - Disp_Ident (Atype.True_N.B_Id); - Put ("}"); - when ON_Unsigned_Type => - Put ("unsigned ("); - Put_Trim (Natural'Image (Atype.Int_Size)); - Put (")"); - when ON_Signed_Type => - Put ("signed ("); - Put_Trim (Natural'Image (Atype.Int_Size)); - Put (")"); - when ON_Float_Type => - Put ("float"); - when ON_Enum_Type => - declare - El : O_Cnode; - begin - Put ("enum {"); - El := Atype.Literals; - while El /= O_Cnode_Null loop - Set_Mark; - Disp_Ident (El.E_Name); - Put (" = "); - Put (Image (El.E_Val)); - El := El.E_Next; - exit when El = O_Cnode_Null; - Put (", "); - end loop; - Put ("}"); - end; - when ON_Array_Type => - Put ("array ["); - Disp_Tnode (Atype.Index_Type, False); - Put ("] of "); - Disp_Tnode (Atype.El_Type, False); - when ON_Access_Type => - Put ("access "); - if Atype.D_Type /= O_Tnode_Null then - Disp_Tnode (Atype.D_Type, False); - end if; - when ON_Record_Type => - Put_Line ("record "); - Disp_Fnodes (Atype.Elements); - Put ("end record"); - when ON_Union_Type => - Put_Line ("union "); - Disp_Fnodes (Atype.Elements); - Put ("end union"); - when ON_Array_Sub_Type => - Put ("subarray "); - Disp_Tnode_Name (Atype.Base_Type); - Put ("["); - Disp_Cnode (Atype.Length, Atype.Base_Type.Index_Type); - Put ("]"); - end case; - end Disp_Tnode; - - procedure Disp_Storage_Name (Storage : O_Storage) is - begin - case Storage is - when O_Storage_External => - Put ("external"); - when O_Storage_Public => - Put ("public"); - when O_Storage_Private => - Put ("private"); - when O_Storage_Local => - Put ("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 ("procedure "); - else - Put ("function "); - end if; - 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 ("return "); - 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 ("type "); - Disp_Ident (Decl.Name); - Put (" is "); - if not Decl.Dtype.Uncomplete then - Disp_Tnode (Decl.Dtype, True); - else - case Decl.Dtype.Kind is - when ON_Record_Type => - Put ("record"); - when ON_Access_Type => - Put ("access"); - when others => - raise Program_Error; - end case; - end if; - Put_Line (";"); - when ON_Completed_Type_Decl => - Put ("type "); - Disp_Ident (Decl.Name); - Put (" is "); - Disp_Tnode (Decl.Dtype, True); - Put_Line (";"); - when ON_Const_Decl => - Disp_Storage_Name (Decl.Storage); - Put (" "); - Put ("constant "); - Disp_Ident (Decl.Name); - Put (" : "); - Disp_Tnode_Name (Decl.Dtype); - Put_Line (";"); - when ON_Const_Value => - Put ("constant "); - Disp_Ident (Decl.Name); - Put (" := "); - Disp_Cnode (Decl.Value, Decl.Dtype); - Put_Line (";"); - when ON_Var_Decl => - Disp_Storage_Name (Decl.Storage); - Put (" "); - Put ("var "); - 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_Line ("declare"); - Add_Tab; - Disp_Decls (Stmt.Decls); - Rem_Tab; - Put_Line ("begin"); - Add_Tab; - if Stmt.Stmts /= null then - Disp_Snode (Stmt.Stmts, null); - end if; - Rem_Tab; - Put_Line ("end;"); - when ON_Assign_Stmt => - Disp_Lnode (Stmt.Target); - Put (" := "); - 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, 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_Line ("end if;"); - when ON_Elsif_Stmt => - Rem_Tab; - if Stmt.Cond = null then - Put_Line ("else"); - else - if First = Stmt then - Put ("if "); - else - Put ("elsif "); - end if; - Disp_Enode (Stmt.Cond, O_Tnode_Null); - Put_Line (" then"); - end if; - Add_Tab; - when ON_Loop_Stmt => - Disp_Loop_Name (Stmt); - Put_Line (":"); - Add_Tab; - Disp_Snode (Stmt.Next, Stmt.Loop_Last); - Stmt := Stmt.Loop_Last; - Rem_Tab; - Put_Line ("end loop;"); - when ON_Exit_Stmt => - Put ("exit "); - Disp_Loop_Name (Stmt.Loop_Id); - Put_Line (";"); - when ON_Next_Stmt => - Put ("next "); - Disp_Loop_Name (Stmt.Loop_Id); - Put_Line (";"); - when ON_Case_Stmt => - Put ("case "); - Disp_Enode (Stmt.Selector, O_Tnode_Null); - Put_Line (" is"); - Add_Tab; - Disp_Snode (Stmt.Next, Stmt.Case_Last); - Stmt := Stmt.Case_Last; - Rem_Tab; - Put_Line ("end case;"); - 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 ("when "); - 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 ("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 - Disp_Ident (N.Decl.Name); - Put (" : "); - 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; diff --git a/ortho/debug/ortho_debug-disp.ads b/ortho/debug/ortho_debug-disp.ads deleted file mode 100644 index c365a35..0000000 --- a/ortho/debug/ortho_debug-disp.ads +++ /dev/null @@ -1,29 +0,0 @@ --- Display the ortho codes from a 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. -with Interfaces.C_Streams; - -package Ortho_Debug.Disp is - -- Initialize the current context. - -- Must be called before any use of the DISP_* subprograms. - procedure Init_Context (File : Interfaces.C_Streams.FILEs); - - -- Disp nodes in a pseudo-language. - procedure Disp_Ortho (Decls : O_Snode); - -private -end Ortho_Debug.Disp; diff --git a/ortho/debug/ortho_debug-main.adb b/ortho/debug/ortho_debug-main.adb deleted file mode 100644 index b470dea..0000000 --- a/ortho/debug/ortho_debug-main.adb +++ /dev/null @@ -1,151 +0,0 @@ --- Main procedure of ortho debug back-end. --- 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. -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Unchecked_Deallocation; -with Ada.Text_IO; use Ada.Text_IO; -with Ortho_Debug; use Ortho_Debug; -with Ortho_Debug_Front; use Ortho_Debug_Front; -with Ortho_Debug.Disp; -with System; use System; -with Interfaces.C_Streams; use Interfaces.C_Streams; - -procedure Ortho_Debug.Main is - -- Do not output the ortho code. - Flag_Silent : Boolean := False; - - -- Force output, even in case of crash. - Flag_Force : Boolean := False; - - I : Natural; - Argc : Natural; - Arg : String_Acc; - Opt : String_Acc; - Res : Natural; - File : String_Acc; - Output : FILEs; - R : Boolean; - - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Name => String_Acc, Object => String); -begin - Ortho_Debug_Front.Init; - Output := NULL_Stream; - - Set_Exit_Status (Failure); - - -- Decode options. - Argc := Argument_Count; - I := 1; - loop - exit when I > Argc; - exit when Argument (I) (1) /= '-'; - if Argument (I) = "--silent" or else Argument (I) = "-quiet" then - Flag_Silent := True; - I := I + 1; - elsif Argument (I) = "--force" then - Flag_Force := True; - I := I + 1; - elsif Argument (I)'Length >= 2 and then Argument (I)(2) = 'g' then - -- Skip -g[XXX] flags. - I := I + 1; - elsif Argument (I) = "-o" and then I + 1 <= Argc then - -- TODO: write the output to the file ? - if Output /= NULL_Stream then - Put_Line (Command_Name & ": only one output allowed"); - return; - end if; - declare - Name : String := Argument (I + 1) & ASCII.Nul; - Mode : String := 'w' & ASCII.Nul; - begin - Output := fopen (Name'Address, Mode'Address); - if Output = NULL_Stream then - Put_Line (Command_Name & ": cannot open " & Argument (I + 1)); - return; - end if; - end; - I := I + 2; - else - Opt := new String'(Argument (I)); - if I < Argc then - Arg := new String'(Argument (I + 1)); - else - Arg := null; - end if; - Res := Ortho_Debug_Front.Decode_Option (Opt, Arg); - Unchecked_Deallocation (Opt); - Unchecked_Deallocation (Arg); - if Res = 0 then - Put_Line (Argument (I) & ": unknown option"); - return; - else - I := I + Res; - end if; - end if; - end loop; - - -- Initialize tree. - begin - Ortho_Debug.Init; - - if I <= Argc then - R := True; - for J in I .. Argc loop - File := new String'(Argument (J)); - R := R and Ortho_Debug_Front.Parse (File); - Unchecked_Deallocation (File); - end loop; - else - R := Ortho_Debug_Front.Parse (null); - end if; - Ortho_Debug.Finish; - exception - when others => - if not Flag_Force then - raise; - else - R := False; - end if; - end; - - -- Write down the result. - if (R and (Output /= NULL_Stream or not Flag_Silent)) - or Flag_Force - then - if Output = NULL_Stream then - Ortho_Debug.Disp.Init_Context (stdout); - else - Ortho_Debug.Disp.Init_Context (Output); - end if; - Ortho_Debug.Disp.Disp_Ortho (Ortho_Debug.Top); - if Output /= NULL_Stream then - declare - Status : int; - pragma Unreferenced (Status); - begin - Status := fclose (Output); - end; - end if; - end if; - - if R then - Set_Exit_Status (Success); - else - Set_Exit_Status (Failure); - end if; -end Ortho_Debug.Main; diff --git a/ortho/debug/ortho_debug.adb b/ortho/debug/ortho_debug.adb deleted file mode 100644 index 8285a64..0000000 --- a/ortho/debug/ortho_debug.adb +++ /dev/null @@ -1,1931 +0,0 @@ --- Ortho debug back-end. --- 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. - -with Ada.Unchecked_Deallocation; - -package body Ortho_Debug is - -- If True, disable some checks so that the output can be generated. - Disable_Checks : constant Boolean := False; - - type ON_Op_To_OE_Type is array (ON_Op_Kind) of OE_Kind; - ON_Op_To_OE : constant ON_Op_To_OE_Type := - ( - ON_Nil => OE_Nil, - - -- Dyadic operations. - ON_Add_Ov => OE_Add_Ov, - ON_Sub_Ov => OE_Sub_Ov, - ON_Mul_Ov => OE_Mul_Ov, - ON_Div_Ov => OE_Div_Ov, - ON_Rem_Ov => OE_Rem_Ov, - ON_Mod_Ov => OE_Mod_Ov, - - -- Binary operations. - ON_And => OE_And, - ON_Or => OE_Or, - ON_Xor => OE_Xor, - - -- Monadic operations. - ON_Not => OE_Not, - ON_Neg_Ov => OE_Neg_Ov, - ON_Abs_Ov => OE_Abs_Ov, - - -- Comparaisons - ON_Eq => OE_Eq, - ON_Neq => OE_Neq, - ON_Le => OE_Le, - ON_Lt => OE_Lt, - ON_Ge => OE_Ge, - ON_Gt => OE_Gt - ); - - type Decl_Scope_Type is record - -- Declarations are chained. - Parent : O_Snode; - Last_Decl : O_Dnode; - Last_Stmt : O_Snode; - - -- If this scope corresponds to a function, PREV_FUNCTION contains - -- the previous function. - Prev_Function : O_Dnode; - - -- Declaration scopes are chained. - Prev : Decl_Scope_Acc; - end record; - - type Stmt_Kind is - (Stmt_Function, Stmt_Declare, Stmt_If, Stmt_Loop, Stmt_Case); - type Stmt_Scope_Type (Kind : Stmt_Kind); - type Stmt_Scope_Acc is access Stmt_Scope_Type; - type Stmt_Scope_Type (Kind : Stmt_Kind) is record - -- Statement which created this scope. - Parent : O_Snode; - -- Previous (parent) scope. - Prev : Stmt_Scope_Acc; - case Kind is - when Stmt_Function => - Prev_Function : Stmt_Scope_Acc; - -- Declaration for the function. - Decl : O_Dnode; - when Stmt_Declare => - null; - when Stmt_If => - Last_Elsif : O_Snode; - when Stmt_Loop => - null; - when Stmt_Case => - Last_Branch : O_Snode; - Last_Choice : O_Choice; - Case_Type : O_Tnode; - end case; - end record; - subtype Stmt_Function_Scope_Type is Stmt_Scope_Type (Stmt_Function); - subtype Stmt_Declare_Scope_Type is Stmt_Scope_Type (Stmt_Declare); - subtype Stmt_If_Scope_Type is Stmt_Scope_Type (Stmt_If); - subtype Stmt_Loop_Scope_Type is Stmt_Scope_Type (Stmt_Loop); - subtype Stmt_Case_Scope_Type is Stmt_Scope_Type (Stmt_Case); - - Current_Stmt_Scope : Stmt_Scope_Acc := null; - Current_Function : Stmt_Scope_Acc := null; - Current_Decl_Scope : Decl_Scope_Acc := null; - Current_Loop_Level : Natural := 0; - - procedure Push_Decl_Scope (Parent : O_Snode) - is - Res : Decl_Scope_Acc; - begin - Res := new Decl_Scope_Type'(Parent => Parent, - Last_Decl => null, - Last_Stmt => null, - Prev_Function => null, - Prev => Current_Decl_Scope); - Parent.Alive := True; - Current_Decl_Scope := Res; - end Push_Decl_Scope; - - procedure Pop_Decl_Scope - is - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Object => Decl_Scope_Type, Name => Decl_Scope_Acc); - Old : Decl_Scope_Acc; - begin - Old := Current_Decl_Scope; - Old.Parent.Alive := False; - Current_Decl_Scope := Old.Prev; - Unchecked_Deallocation (Old); - end Pop_Decl_Scope; - - procedure Add_Decl (El : O_Dnode; Check_Dup : Boolean := True) is - begin - if Current_Decl_Scope = null then - -- Not yet initialized, or after compilation. - raise Program_Error; - end if; - - -- Note: this requires an hashed ident table. - -- Use ortho_ident_hash. - if False and then Check_Dup - and then not Is_Nul (El.Name) - then - -- Check the name is not already defined. - declare - E : O_Dnode; - begin - E := Current_Decl_Scope.Parent.Decls; - while E /= O_Dnode_Null loop - if Is_Equal (E.Name, El.Name) then - raise Syntax_Error; - end if; - E := E.Next; - end loop; - end; - end if; - - if Current_Decl_Scope.Last_Decl = null then - if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then - Current_Decl_Scope.Parent.Decls := El; - else - raise Type_Error; - end if; - else - Current_Decl_Scope.Last_Decl.Next := El; - end if; - El.Next := null; - Current_Decl_Scope.Last_Decl := El; - end Add_Decl; - - procedure Add_Stmt (Stmt : O_Snode) - is - begin - if Current_Decl_Scope = null or Current_Function = null then - -- You are adding a statement at the global level, ie not inside - -- a function. - raise Syntax_Error; - end if; - - Stmt.Next := null; - if Current_Decl_Scope.Last_Stmt = null then - if Current_Decl_Scope.Parent.Kind = ON_Declare_Stmt then - Current_Decl_Scope.Parent.Stmts := Stmt; - else - raise Syntax_Error; - end if; - else - Current_Decl_Scope.Last_Stmt.Next := Stmt; - end if; - Current_Decl_Scope.Last_Stmt := Stmt; - end Add_Stmt; - - procedure Push_Stmt_Scope (Scope : Stmt_Scope_Acc) - is - begin - if Scope.Prev /= Current_Stmt_Scope then - -- SCOPE was badly initialized. - raise Program_Error; - end if; - Current_Stmt_Scope := Scope; - end Push_Stmt_Scope; - - procedure Pop_Stmt_Scope (Kind : Stmt_Kind) - is - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Object => Stmt_Scope_Type, Name => Stmt_Scope_Acc); - Old : Stmt_Scope_Acc; - begin - Old := Current_Stmt_Scope; - if Old.Kind /= Kind then - raise Syntax_Error; - end if; - --Old.Parent.Last_Stmt := Current_Decl_Scope.Last_Stmt; - Current_Stmt_Scope := Old.Prev; - Unchecked_Deallocation (Old); - end Pop_Stmt_Scope; - - -- Check declaration DECL is reachable, ie its scope is in the current - -- stack of scopes. - procedure Check_Scope (Decl : O_Dnode) - is - Res : Boolean; - begin - case Decl.Kind is - when ON_Interface_Decl => - Res := Decl.Func_Scope.Alive; - when others => - Res := Decl.Scope.Alive; - end case; - if not Res then - raise Syntax_Error; - end if; - end Check_Scope; - - -- Raise SYNTAX_ERROR if OBJ is not at a constant address. --- procedure Check_Const_Address (Obj : O_Lnode) is --- begin --- case Obj.Kind is --- when OL_Const_Ref --- | OL_Var_Ref => --- case Obj.Decl.Storage is --- when O_Storage_External --- | O_Storage_Public --- | O_Storage_Private => --- null; --- when O_Storage_Local => --- raise Syntax_Error; --- end case; --- when others => --- -- FIXME: constant indexed element, selected element maybe --- -- of const address. --- raise Syntax_Error; --- end case; --- end Check_Const_Address; - - procedure Check_Type (T1, T2 : O_Tnode) is - begin - 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 - and then T1.Length.all = T2.Length.all - then - return; - end if; - raise Type_Error; - end Check_Type; - - procedure Check_Ref (N : O_Enode) is - begin - if N.Ref then - -- Already referenced. - raise Syntax_Error; - end if; - N.Ref := True; - end Check_Ref; - - procedure Check_Ref (N : O_Lnode) is - begin - if N.Ref then - raise Syntax_Error; - end if; - N.Ref := True; - end Check_Ref; - - procedure Check_Complete_Type (T : O_Tnode) is - begin - if not T.Complete then - -- Uncomplete type cannot be used here (since its size is required, - -- for example). - raise Syntax_Error; - end if; - end Check_Complete_Type; - - function New_Dyadic_Op (Kind : ON_Dyadic_Op_Kind; Left, Right : O_Enode) - return O_Enode - is - K : constant OE_Kind := ON_Op_To_OE (Kind); - Res : O_Enode; - begin - Check_Type (Left.Rtype, Right.Rtype); - Check_Ref (Left); - Check_Ref (Right); - Res := new O_Enode_Type (K); - Res.Rtype := Left.Rtype; - Res.Ref := False; - Res.Left := Left; - Res.Right := Right; - return Res; - end New_Dyadic_Op; - - function New_Monadic_Op (Kind : ON_Monadic_Op_Kind; Operand : O_Enode) - return O_Enode - is - Res : O_Enode; - begin - Check_Ref (Operand); - Res := new O_Enode_Type (ON_Op_To_OE (Kind)); - Res.Ref := False; - Res.Operand := Operand; - Res.Rtype := Operand.Rtype; - return Res; - end New_Monadic_Op; - - function New_Compare_Op - (Kind : ON_Compare_Op_Kind; Left, Right : O_Enode; Ntype : O_Tnode) - return O_Enode - is - Res : O_Enode; - begin - if Ntype.Kind /= ON_Boolean_Type then - raise Type_Error; - end if; - if Left.Rtype /= Right.Rtype then - raise Type_Error; - end if; - Check_Ref (Left); - Check_Ref (Right); - Res := new O_Enode_Type (ON_Op_To_OE (Kind)); - Res.Ref := False; - Res.Left := Left; - Res.Right := Right; - Res.Rtype := Ntype; - return Res; - end New_Compare_Op; - - - function New_Signed_Literal (Ltype : O_Tnode; Value : Integer_64) - return O_Cnode - is - subtype O_Cnode_Signed_Lit is O_Cnode_Type (OC_Signed_Lit); - begin - if Ltype.Kind = ON_Signed_Type then - return new O_Cnode_Signed_Lit'(Kind => OC_Signed_Lit, - Ctype => Ltype, - Ref => False, - S_Val => Value); - else - raise Type_Error; - end if; - end New_Signed_Literal; - - function New_Unsigned_Literal (Ltype : O_Tnode; Value : Unsigned_64) - return O_Cnode - is - subtype O_Cnode_Unsigned_Lit is O_Cnode_Type (OC_Unsigned_Lit); - begin - if Ltype.Kind = ON_Unsigned_Type then - return new O_Cnode_Unsigned_Lit'(Kind => OC_Unsigned_Lit, - Ctype => Ltype, - Ref => False, - U_Val => Value); - else - raise Type_Error; - end if; - end New_Unsigned_Literal; - - function New_Float_Literal (Ltype : O_Tnode; Value : IEEE_Float_64) - return O_Cnode - is - subtype O_Cnode_Float_Lit is O_Cnode_Type (OC_Float_Lit); - begin - if Ltype.Kind = ON_Float_Type then - return new O_Cnode_Float_Lit'(Kind => OC_Float_Lit, - Ctype => Ltype, - Ref => False, - F_Val => Value); - else - raise Type_Error; - end if; - end New_Float_Literal; - - function New_Null_Access (Ltype : O_Tnode) return O_Cnode - is - subtype O_Cnode_Null_Lit_Type is O_Cnode_Type (OC_Null_Lit); - begin - if Ltype.Kind /= ON_Access_Type then - raise Type_Error; - end if; - return new O_Cnode_Null_Lit_Type'(Kind => OC_Null_Lit, - Ctype => Ltype, - Ref => False); - end New_Null_Access; - - 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); - begin - if Rtype.Kind /= ON_Unsigned_Type - and then Rtype.Kind /= ON_Access_Type - then - raise Type_Error; - end if; - Check_Complete_Type (Atype); - if Atype.Kind = ON_Array_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; - - function New_Alignof (Atype : O_Tnode; Rtype : O_Tnode) return O_Cnode - is - subtype O_Cnode_Alignof_Type is O_Cnode_Type (OC_Alignof_Lit); - begin - if Rtype.Kind /= ON_Unsigned_Type then - raise Type_Error; - end if; - Check_Complete_Type (Atype); - return new O_Cnode_Alignof_Type'(Kind => OC_Alignof_Lit, - Ctype => Rtype, - Ref => False, - S_Type => Atype); - end New_Alignof; - - function New_Offsetof (Atype : O_Tnode; Field : O_Fnode; Rtype : O_Tnode) - return O_Cnode - is - subtype O_Cnode_Offsetof_Type is O_Cnode_Type (OC_Offsetof_Lit); - begin - if Rtype.Kind /= ON_Unsigned_Type - and then Rtype.Kind /= ON_Access_Type - then - raise Type_Error; - end if; - if Field.Parent /= Atype then - raise Type_Error; - end if; - return new O_Cnode_Offsetof_Type'(Kind => OC_Offsetof_Lit, - Ctype => Rtype, - Ref => False, - Off_Field => Field); - end New_Offsetof; - - function New_Alloca (Rtype : O_Tnode; Size : O_Enode) return O_Enode - is - subtype O_Enode_Alloca_Type is O_Enode_Type (OE_Alloca); - Res : O_Enode; - begin - if Rtype.Kind /= ON_Access_Type then - raise Type_Error; - end if; - if Size.Rtype.Kind /= ON_Unsigned_Type then - raise Type_Error; - end if; - Res := new O_Enode_Alloca_Type'(Kind => OE_Alloca, - Rtype => Rtype, - Ref => False, - A_Size => Size); - return Res; - end New_Alloca; - - procedure Check_Constrained_Type (Atype : 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; - end case; - end Check_Constrained_Type; - - procedure New_Completed_Type_Decl (Atype : O_Tnode) - is - N : O_Dnode; - begin - if Atype.Decl = null then - -- The uncompleted type must have been declared. - raise Type_Error; - end if; - N := new O_Dnode_Type (ON_Completed_Type_Decl); - N.Name := Atype.Decl.Name; - N.Dtype := Atype; - 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); - begin - Res := new O_Tnode_Record_Type'(Kind => ON_Record_Type, - Decl => O_Dnode_Null, - Uncomplete => True, - Complete => False, - Elements => O_Fnode_Null); - end New_Uncomplete_Record_Type; - - procedure Start_Uncomplete_Record_Type (Res : O_Tnode; - Elements : out O_Element_List) is - begin - if not Res.Uncomplete then - -- RES record type is not an uncomplete record type. - raise Syntax_Error; - end if; - if Res.Elements /= O_Fnode_Null then - -- RES record type already has elements... - raise Syntax_Error; - end if; - Elements.Res := Res; - Elements.Last := null; - end Start_Uncomplete_Record_Type; - - procedure Start_Record_Type (Elements : out O_Element_List) - is - subtype O_Tnode_Record_Type is O_Tnode_Type (ON_Record_Type); - 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; - 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 - Check_Complete_Type (Etype); - Check_Constrained_Type (Etype); - El := new O_Fnode_Type'(Parent => Elements.Res, - Next => null, - Ident => Ident, - Ftype => Etype, - Offset => 0); - -- Append EL. - if Elements.Last = null then - Elements.Res.Elements := El; - else - Elements.Last.Next := El; - end if; - Elements.Last := El; - end New_Record_Field; - - procedure Finish_Record_Type - (Elements : in out O_Element_List; Res : out O_Tnode) is - begin - -- Align the structure. - Res := Elements.Res; - if Res.Uncomplete then - New_Completed_Type_Decl (Res); - end if; - Res.Complete := True; - end Finish_Record_Type; - - procedure Start_Union_Type (Elements : out O_Element_List) - is - subtype O_Tnode_Union_Type is O_Tnode_Type (ON_Union_Type); - begin - Elements.Res := new O_Tnode_Union_Type'(Kind => ON_Union_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => False, - Elements => O_Fnode_Null); - Elements.Last := null; - end Start_Union_Type; - - procedure New_Union_Field - (Elements : in out O_Element_List; - El : out O_Fnode; - Ident : O_Ident; Etype : O_Tnode) - is - begin - New_Record_Field (Elements, El, Ident, Etype); - end New_Union_Field; - - procedure Finish_Union_Type - (Elements : in out O_Element_List; Res : out O_Tnode) is - begin - Res := Elements.Res; - Res.Complete := True; - end Finish_Union_Type; - - 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, - D_Type => Dtype); - return Res; - end New_Access_Type; - - procedure Finish_Access_Type (Atype : O_Tnode; Dtype : O_Tnode) - is - begin - if Dtype.Kind = ON_Array_Sub_Type then - -- Access to sub array are not allowed, use access to array. - raise Type_Error; - end if; - if Atype.D_Type /= O_Tnode_Null - or Atype.Uncomplete = False - then - -- Type already completed. - raise Syntax_Error; - end if; - Atype.D_Type := Dtype; - New_Completed_Type_Decl (Atype); - end Finish_Access_Type; - - function New_Array_Type (El_Type : O_Tnode; Index_Type : O_Tnode) - return O_Tnode - 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, - 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 - is - subtype O_Tnode_Sub_Array is O_Tnode_Type (ON_Array_Sub_Type); - begin - if Atype.Kind /= ON_Array_Type then - raise Type_Error; - end if; - return new O_Tnode_Sub_Array'(Kind => ON_Array_Sub_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True, - Base_Type => Atype, - Length => Length); - end New_Constrained_Array_Type; - - function New_Unsigned_Type (Size : Natural) return O_Tnode - is - subtype O_Tnode_Unsigned is O_Tnode_Type (ON_Unsigned_Type); - begin - return new O_Tnode_Unsigned'(Kind => ON_Unsigned_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True, - Int_Size => Size); - end New_Unsigned_Type; - - function New_Signed_Type (Size : Natural) return O_Tnode - is - subtype O_Tnode_Signed is O_Tnode_Type (ON_Signed_Type); - begin - return new O_Tnode_Signed'(Kind => ON_Signed_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True, - Int_Size => Size); - end New_Signed_Type; - - function New_Float_Type return O_Tnode - is - subtype O_Tnode_Float is O_Tnode_Type (ON_Float_Type); - begin - return new O_Tnode_Float'(Kind => ON_Float_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True); - end New_Float_Type; - - procedure New_Boolean_Type (Res : out O_Tnode; - False_Id : O_Ident; - False_E : out O_Cnode; - True_Id : O_Ident; - True_E : out O_Cnode) - is - subtype O_Tnode_Boolean is O_Tnode_Type (ON_Boolean_Type); - subtype O_Cnode_Boolean_Lit is O_Cnode_Type (OC_Boolean_Lit); - begin - Res := new O_Tnode_Boolean'(Kind => ON_Boolean_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => True, - True_N => O_Cnode_Null, - False_N => O_Cnode_Null); - True_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit, - Ctype => Res, - Ref => False, - B_Val => True, - B_Id => True_Id); - False_E := new O_Cnode_Boolean_Lit'(Kind => OC_Boolean_Lit, - Ctype => Res, - Ref => False, - B_Val => False, - B_Id => False_Id); - Res.True_N := True_E; - Res.False_N := False_E; - end New_Boolean_Type; - - procedure Start_Enum_Type (List : out O_Enum_List; Size : Natural) - is - pragma Unreferenced (Size); - subtype O_Tnode_Enum is O_Tnode_Type (ON_Enum_Type); - Res : O_Tnode; - begin - Res := new O_Tnode_Enum'(Kind => ON_Enum_Type, - Decl => O_Dnode_Null, - Uncomplete => False, - Complete => False, - Nbr => 0, - Literals => O_Cnode_Null); - List.Res := Res; - List.Last := O_Cnode_Null; - end Start_Enum_Type; - - procedure New_Enum_Literal (List : in out O_Enum_List; - Ident : O_Ident; - Res : out O_Cnode) - is - subtype O_Cnode_Enum_Lit is O_Cnode_Type (OC_Enum_Lit); - begin - Res := new O_Cnode_Enum_Lit'(Kind => OC_Enum_Lit, - Ctype => List.Res, - Ref => False, - E_Val => List.Res.Nbr, - E_Name => Ident, - E_Next => O_Cnode_Null); - -- Link it. - if List.Last = O_Cnode_Null then - List.Res.Literals := Res; - else - List.Last.E_Next := Res; - end if; - List.Last := Res; - - List.Res.Nbr := List.Res.Nbr + 1; - end New_Enum_Literal; - - procedure Finish_Enum_Type (List : in out O_Enum_List; Res : out O_Tnode) is - begin - Res := List.Res; - Res.Complete := True; - end Finish_Enum_Type; - - function Get_Base_Type (Atype : O_Tnode) return O_Tnode - is - begin - case Atype.Kind is - when ON_Array_Sub_Type => - return Atype.Base_Type; - when others => - return Atype; - end case; - end Get_Base_Type; - - procedure Start_Record_Aggr (List : out O_Record_Aggr_List; Atype : O_Tnode) - is - subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate); - Res : O_Cnode; - begin - if Atype.Kind /= ON_Record_Type then - raise Type_Error; - end if; - Check_Complete_Type (Atype); - Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate, - Ctype => Atype, - Ref => False, - Aggr_Els => null); - List.Res := Res; - List.Last := null; - List.Field := Atype.Elements; - end Start_Record_Aggr; - - procedure New_Record_Aggr_El (List : in out O_Record_Aggr_List; - Value : O_Cnode) - is - subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element); - El : O_Cnode; - begin - if List.Field = O_Fnode_Null then - -- No more element in the aggregate. - raise Syntax_Error; - end if; - Check_Type (Value.Ctype, List.Field.Ftype); - El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element, - Ctype => Value.Ctype, - Ref => False, - Aggr_Value => Value, - Aggr_Next => null); - if List.Last = null then - List.Res.Aggr_Els := El; - else - List.Last.Aggr_Next := El; - end if; - List.Last := El; - List.Field := List.Field.Next; - end New_Record_Aggr_El; - - procedure Finish_Record_Aggr - (List : in out O_Record_Aggr_List; Res : out O_Cnode) - is - begin - if List.Field /= null then - -- Not enough elements in aggregate. - raise Type_Error; - end if; - Res := List.Res; - end Finish_Record_Aggr; - - procedure Start_Array_Aggr (List : out O_Array_Aggr_List; Atype : O_Tnode) - is - subtype O_Cnode_Aggregate is O_Cnode_Type (OC_Aggregate); - Res : O_Cnode; - begin - if Atype.Kind /= ON_Array_Sub_Type then - raise Type_Error; - end if; - Check_Complete_Type (Atype); - Res := new O_Cnode_Aggregate'(Kind => OC_Aggregate, - Ctype => Atype, - Ref => False, - Aggr_Els => null); - List.Res := Res; - List.Last := null; - List.El_Type := Atype.Base_Type.El_Type; - end Start_Array_Aggr; - - procedure New_Array_Aggr_El (List : in out O_Array_Aggr_List; - Value : O_Cnode) - is - subtype O_Cnode_Aggrel_Type is O_Cnode_Type (OC_Aggr_Element); - El : O_Cnode; - begin - Check_Type (Value.Ctype, List.El_Type); - El := new O_Cnode_Aggrel_Type'(Kind => OC_Aggr_Element, - Ctype => Value.Ctype, - Ref => False, - Aggr_Value => Value, - Aggr_Next => null); - if List.Last = null then - List.Res.Aggr_Els := El; - else - List.Last.Aggr_Next := El; - end if; - List.Last := El; - end New_Array_Aggr_El; - - procedure Finish_Array_Aggr - (List : in out O_Array_Aggr_List; Res : out O_Cnode) is - begin - Res := List.Res; - end Finish_Array_Aggr; - - function New_Union_Aggr (Atype : O_Tnode; Field : O_Fnode; Value : O_Cnode) - return O_Cnode - is - subtype O_Cnode_Union_Aggr is O_Cnode_Type (OC_Union_Aggr); - Res : O_Cnode; - begin - if Atype.Kind /= ON_Union_Type then - raise Type_Error; - end if; - Check_Type (Value.Ctype, Field.Ftype); - - Res := new O_Cnode_Union_Aggr'(Kind => OC_Union_Aggr, - Ctype => Atype, - Ref => False, - Uaggr_Field => Field, - Uaggr_Value => Value); - return Res; - end New_Union_Aggr; - - function New_Obj (Obj : O_Dnode) return O_Lnode - is - subtype O_Lnode_Obj is O_Lnode_Type (OL_Obj); - begin - case Obj.Kind is - when ON_Const_Decl - | ON_Var_Decl - | ON_Interface_Decl => - null; - when others => - raise Program_Error; - end case; - Check_Scope (Obj); - return new O_Lnode_Obj'(Kind => OL_Obj, - Rtype => Obj.Dtype, - Ref => False, - Obj => Obj); - end New_Obj; - - function New_Indexed_Element (Arr : O_Lnode; Index : O_Enode) - return O_Lnode - is - subtype O_Lnode_Indexed is O_Lnode_Type (OL_Indexed_Element); - Res : O_Lnode; - begin - Check_Ref (Arr); - Res := new O_Lnode_Indexed'(Kind => OL_Indexed_Element, - Rtype => Get_Base_Type (Arr.Rtype).El_Type, - Ref => False, - Array_Base => Arr, - Index => Index); - return Res; - end New_Indexed_Element; - - function New_Slice (Arr : O_Lnode; Res_Type : O_Tnode; Index : O_Enode) - return O_Lnode - 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 - raise Type_Error; - end if; - Check_Ref (Arr); - Check_Ref (Index); - -- FIXME: check type. - Res := new O_Lnode_Slice'(Kind => OL_Slice, - Rtype => Res_Type, - Ref => False, - Slice_Base => Arr, - Slice_Index => Index); - return Res; - end New_Slice; - - function New_Selected_Element (Rec : O_Lnode; El : O_Fnode) - return O_Lnode - is - subtype O_Lnode_Selected_Element is O_Lnode_Type (OL_Selected_Element); - begin - if Rec.Rtype.Kind /= ON_Record_Type then - raise Type_Error; - end if; - if Rec.Rtype /= El.Parent then - raise Type_Error; - end if; - Check_Ref (Rec); - return new O_Lnode_Selected_Element'(Kind => OL_Selected_Element, - Rtype => El.Ftype, - Ref => False, - Rec_Base => Rec, - Rec_El => El); - end New_Selected_Element; - - function New_Access_Element (Acc : O_Enode) return O_Lnode - is - subtype O_Lnode_Access_Element is O_Lnode_Type (OL_Access_Element); - begin - if Acc.Rtype.Kind /= ON_Access_Type then - raise Type_Error; - end if; - Check_Ref (Acc); - return new O_Lnode_Access_Element'(Kind => OL_Access_Element, - Rtype => Acc.Rtype.D_Type, - Ref => False, - Acc_Base => Acc); - end New_Access_Element; - - function Check_Conv (Source : ON_Type_Kind; Target : ON_Type_Kind) - return Boolean - is - type Conv_Array is array (ON_Type_Kind, ON_Type_Kind) of Boolean; - 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)); - begin - if Source = Target then - return True; - else - return Conv_Allowed (Source, Target); - end if; - end Check_Conv; - - function New_Convert_Ov (Val : O_Enode; Rtype : O_Tnode) return O_Enode - is - subtype O_Enode_Convert is O_Enode_Type (OE_Convert_Ov); - Res : O_Enode; - begin - Check_Ref (Val); - if not Check_Conv (Val.Rtype.Kind, Rtype.Kind) then - raise Type_Error; - end if; - Res := new O_Enode_Convert'(Kind => OE_Convert_Ov, - Rtype => Rtype, - Ref => False, - Conv => Val); - return Res; - end New_Convert_Ov; - - function New_Unchecked_Address (Lvalue : O_Lnode; Atype : O_Tnode) - return O_Enode - is - subtype O_Enode_Address is O_Enode_Type (OE_Unchecked_Address); - begin - Check_Ref (Lvalue); - if Atype.Kind /= ON_Access_Type then - -- An address is of type access. - raise Type_Error; - end if; - return new O_Enode_Address'(Kind => OE_Unchecked_Address, - Rtype => Atype, - Ref => False, - Lvalue => Lvalue); - end New_Unchecked_Address; - - function New_Address (Lvalue : O_Lnode; Atype : O_Tnode) return O_Enode - is - subtype O_Enode_Address is O_Enode_Type (OE_Address); - begin - Check_Ref (Lvalue); - if Atype.Kind /= ON_Access_Type then - -- 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; - return new O_Enode_Address'(Kind => OE_Address, - Rtype => Atype, - Ref => False, - Lvalue => Lvalue); - end New_Address; - - function New_Global_Unchecked_Address (Decl : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - subtype O_Cnode_Address is O_Cnode_Type (OC_Unchecked_Address); - begin - Check_Scope (Decl); - if Atype.Kind /= ON_Access_Type then - -- An address is of type access. - raise Type_Error; - end if; - return new O_Cnode_Address'(Kind => OC_Unchecked_Address, - Ctype => Atype, - Ref => False, - Decl => Decl); - end New_Global_Unchecked_Address; - - function New_Global_Address (Decl : O_Dnode; Atype : O_Tnode) return O_Cnode - is - subtype O_Cnode_Address is O_Cnode_Type (OC_Address); - begin - Check_Scope (Decl); - if Atype.Kind /= ON_Access_Type then - -- An address is of type access. - raise Type_Error; - end if; - if Get_Base_Type (Decl.Dtype) /= Get_Base_Type (Atype.D_Type) then - raise Type_Error; - end if; - return new O_Cnode_Address'(Kind => OC_Address, - Ctype => Atype, - Ref => False, - Decl => Decl); - end New_Global_Address; - - function New_Subprogram_Address (Subprg : O_Dnode; Atype : O_Tnode) - return O_Cnode - is - subtype O_Cnode_Subprg_Address is O_Cnode_Type (OC_Subprogram_Address); - begin - if Atype.Kind /= ON_Access_Type then - -- An address is of type access. - raise Type_Error; - end if; - return new O_Cnode_Subprg_Address'(Kind => OC_Subprogram_Address, - Ctype => Atype, - Ref => False, - Decl => Subprg); - end New_Subprogram_Address; - - -- Raise TYPE_ERROR is ATYPE is a composite type. - procedure Check_Not_Composite (Atype : O_Tnode) is - begin - case Atype.Kind is - when ON_Boolean_Type - | ON_Unsigned_Type - | ON_Signed_Type - | ON_Float_Type - | ON_Enum_Type - | ON_Access_Type=> - return; - when ON_Array_Type - | ON_Record_Type - | ON_Union_Type - | ON_Array_Sub_Type => - raise Type_Error; - end case; - end Check_Not_Composite; - - function New_Value (Lvalue : O_Lnode) return O_Enode is - subtype O_Enode_Value is O_Enode_Type (OE_Value); - begin - Check_Not_Composite (Lvalue.Rtype); - Check_Ref (Lvalue); - return new O_Enode_Value'(Kind => OE_Value, - Rtype => Lvalue.Rtype, - Ref => False, - Value => Lvalue); - end New_Value; - - function New_Obj_Value (Obj : O_Dnode) return O_Enode is - begin - return New_Value (New_Obj (Obj)); - end New_Obj_Value; - - function New_Lit (Lit : O_Cnode) return O_Enode is - subtype O_Enode_Lit is O_Enode_Type (OE_Lit); - begin - Check_Not_Composite (Lit.Ctype); - return new O_Enode_Lit'(Kind => OE_Lit, - Rtype => Lit.Ctype, - Ref => False, - Lit => Lit); - end New_Lit; - - --------------------- - -- Declarations. -- - --------------------- - - procedure New_Debug_Filename_Decl (Filename : String) - is - subtype O_Dnode_Filename_Decl is O_Dnode_Type (ON_Debug_Filename_Decl); - N : O_Dnode; - begin - N := new O_Dnode_Filename_Decl; - N.Filename := new String'(Filename); - Add_Decl (N, False); - end New_Debug_Filename_Decl; - - procedure New_Debug_Line_Decl (Line : Natural) - is - subtype O_Dnode_Line_Decl is O_Dnode_Type (ON_Debug_Line_Decl); - N : O_Dnode; - begin - N := new O_Dnode_Line_Decl; - N.Line := Line; - Add_Decl (N, False); - end New_Debug_Line_Decl; - - procedure New_Debug_Comment_Decl (Comment : String) - is - subtype O_Dnode_Comment_Decl is O_Dnode_Type (ON_Debug_Comment_Decl); - N : O_Dnode; - begin - N := new O_Dnode_Comment_Decl; - N.Comment := new String'(Comment); - Add_Decl (N, False); - end New_Debug_Comment_Decl; - - procedure New_Type_Decl (Ident : O_Ident; Atype : O_Tnode) - is - N : O_Dnode; - begin - if Atype.Decl /= null then - -- Type was already declared. - raise Type_Error; - end if; - N := new O_Dnode_Type (ON_Type_Decl); - N.Name := Ident; - N.Dtype := Atype; - Atype.Decl := N; - Add_Decl (N); - end New_Type_Decl; - - procedure Check_Object_Storage (Storage : O_Storage) is - begin - if Current_Function /= null then - -- Inside a subprogram. - case Storage is - when O_Storage_Public => - -- Cannot create public variables inside a subprogram. - raise Syntax_Error; - when O_Storage_Private - | O_Storage_Local - | O_Storage_External => - null; - end case; - else - -- Global scope. - case Storage is - when O_Storage_Public - | O_Storage_Private - | O_Storage_External => - null; - when O_Storage_Local => - -- Cannot create a local variables outside a subprogram. - raise Syntax_Error; - end case; - end if; - end Check_Object_Storage; - - procedure New_Const_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) - is - subtype O_Dnode_Const is O_Dnode_Type (ON_Const_Decl); - begin - Check_Complete_Type (Atype); - if Storage = O_Storage_Local then - -- A constant cannot be local. - raise Syntax_Error; - end if; - Check_Object_Storage (Storage); - Res := new O_Dnode_Const'(Kind => ON_Const_Decl, - Name => Ident, - Next => null, - Dtype => Atype, - Storage => Storage, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Const_Value => O_Dnode_Null); - Add_Decl (Res); - end New_Const_Decl; - - procedure Start_Const_Value (Const : in out O_Dnode) - is - subtype O_Dnode_Const_Value is O_Dnode_Type (ON_Const_Value); - N : O_Dnode; - begin - if Const.Const_Value /= O_Dnode_Null then - -- Constant already has a value. - raise Syntax_Error; - end if; - - if Const.Storage = O_Storage_External then - -- An external constant must not have a value. - raise Syntax_Error; - end if; - - -- FIXME: check scope is the same. - - N := new O_Dnode_Const_Value'(Kind => ON_Const_Value, - Name => Const.Name, - Next => null, - Dtype => Const.Dtype, - Storage => Const.Storage, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Const_Decl => Const, - Value => O_Cnode_Null); - Const.Const_Value := N; - Add_Decl (N, False); - end Start_Const_Value; - - procedure Finish_Const_Value (Const : in out O_Dnode; Val : O_Cnode) - is - begin - if Const.Const_Value = O_Dnode_Null then - -- Start_Const_Value not called. - raise Syntax_Error; - end if; - if Const.Const_Value.Value /= O_Cnode_Null then - -- Finish_Const_Value already called. - raise Syntax_Error; - end if; - if Val = O_Cnode_Null then - -- No value or bad type. - raise Type_Error; - end if; - Check_Type (Val.Ctype, Const.Dtype); - Const.Const_Value.Value := Val; - end Finish_Const_Value; - - procedure New_Var_Decl - (Res : out O_Dnode; - Ident : O_Ident; - Storage : O_Storage; - Atype : O_Tnode) - is - subtype O_Dnode_Var is O_Dnode_Type (ON_Var_Decl); - begin - Check_Complete_Type (Atype); - Check_Object_Storage (Storage); - Res := new O_Dnode_Var'(Kind => ON_Var_Decl, - Name => Ident, - Next => null, - Dtype => Atype, - Storage => Storage, - Lineno => 0, - Scope => Current_Decl_Scope.Parent); - Add_Decl (Res); - end New_Var_Decl; - - procedure Start_Subprogram_Decl_1 - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode) - is - subtype O_Dnode_Function is O_Dnode_Type (ON_Function_Decl); - N : O_Dnode; - begin - N := new O_Dnode_Function'(Kind => ON_Function_Decl, - Next => null, - Name => Ident, - Dtype => Rtype, - Storage => Storage, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Interfaces => null, - Func_Body => null, - Alive => False); - Add_Decl (N); - Interfaces.Func := N; - Interfaces.Last := null; - end Start_Subprogram_Decl_1; - - procedure Start_Function_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage; - Rtype : O_Tnode) - is - begin - Check_Not_Composite (Rtype); - Check_Complete_Type (Rtype); - Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, Rtype); - end Start_Function_Decl; - - procedure Start_Procedure_Decl - (Interfaces : out O_Inter_List; - Ident : O_Ident; - Storage : O_Storage) is - begin - Start_Subprogram_Decl_1 (Interfaces, Ident, Storage, null); - end Start_Procedure_Decl; - - procedure New_Interface_Decl - (Interfaces : in out O_Inter_List; - Res : out O_Dnode; - Ident : O_Ident; - Atype : O_Tnode) - is - subtype O_Dnode_Interface is O_Dnode_Type (ON_Interface_Decl); - begin - Check_Not_Composite (Atype); - Check_Complete_Type (Atype); - Res := new O_Dnode_Interface'(Kind => ON_Interface_Decl, - Next => null, - Name => Ident, - Dtype => Atype, - Storage => O_Storage_Private, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Func_Scope => Interfaces.Func); - if Interfaces.Last = null then - Interfaces.Func.Interfaces := Res; - else - Interfaces.Last.Next := Res; - end if; - Interfaces.Last := Res; - end New_Interface_Decl; - - procedure Finish_Subprogram_Decl - (Interfaces : in out O_Inter_List; Res : out O_Dnode) - is - begin - Res := Interfaces.Func; - end Finish_Subprogram_Decl; - - procedure Start_Subprogram_Body (Func : O_Dnode) - is - B : O_Dnode; - S : O_Snode; - begin - if Func.Func_Body /= null then - -- Function was already declared. - raise Syntax_Error; - end if; - S := new O_Snode_Type (ON_Declare_Stmt); - S.all := O_Snode_Type'(Kind => ON_Declare_Stmt, - Next => null, - Decls => null, - Stmts => null, - Lineno => 0, - Alive => True); - B := new O_Dnode_Type (ON_Function_Body); - B.all := O_Dnode_Type'(ON_Function_Body, - Name => Func.Name, - Dtype => Func.Dtype, - Storage => Func.Storage, - Scope => Current_Decl_Scope.Parent, - Lineno => 0, - Func_Decl => Func, - Func_Stmt => S, - Next => null); - Add_Decl (B, False); - Func.Func_Body := B; - Push_Decl_Scope (S); - Push_Stmt_Scope - (new Stmt_Function_Scope_Type'(Kind => Stmt_Function, - Parent => S, - Prev => Current_Stmt_Scope, - Prev_Function => Current_Function, - Decl => Func)); - Current_Function := Current_Stmt_Scope; - Func.Alive := True; - end Start_Subprogram_Body; - - procedure Finish_Subprogram_Body is - begin - Pop_Decl_Scope; - if Current_Function.Kind /= Stmt_Function then - -- Internal error. - raise Syntax_Error; - end if; - Current_Function.Decl.Alive := False; - Current_Function := Current_Function.Prev_Function; - Pop_Stmt_Scope (Stmt_Function); - end Finish_Subprogram_Body; - - ------------------- - -- Statements. -- - ------------------- - - procedure New_Debug_Line_Stmt (Line : Natural) - is - subtype O_Snode_Line_Stmt is O_Snode_Type (ON_Debug_Line_Stmt); - begin - Add_Stmt (new O_Snode_Line_Stmt'(Kind => ON_Debug_Line_Stmt, - Next => null, - Lineno => 0, - Line => Line)); - end New_Debug_Line_Stmt; - - procedure New_Debug_Comment_Stmt (Comment : String) - is - subtype O_Snode_Comment_Stmt is O_Snode_Type (ON_Debug_Comment_Stmt); - begin - Add_Stmt (new O_Snode_Comment_Stmt'(Kind => ON_Debug_Comment_Stmt, - Next => null, - Lineno => 0, - Comment => new String'(Comment))); - end New_Debug_Comment_Stmt; - - procedure Start_Declare_Stmt - is - N : O_Snode; - begin - N := new O_Snode_Type (ON_Declare_Stmt); - Add_Stmt (N); - Push_Decl_Scope (N); - Push_Stmt_Scope - (new Stmt_Declare_Scope_Type'(Kind => Stmt_Declare, - Parent => N, - Prev => Current_Stmt_Scope)); - end Start_Declare_Stmt; - - procedure Finish_Declare_Stmt is - begin - Pop_Decl_Scope; - Pop_Stmt_Scope (Stmt_Declare); - end Finish_Declare_Stmt; - - procedure New_Assign_Stmt (Target : O_Lnode; Value : O_Enode) - is - N : O_Snode; - begin - Check_Type (Target.Rtype, Value.Rtype); - Check_Not_Composite (Target.Rtype); - Check_Ref (Target); - Check_Ref (Value); - N := new O_Snode_Type (ON_Assign_Stmt); - N.all := O_Snode_Type'(Kind => ON_Assign_Stmt, - Next => null, - Lineno => 0, - Target => Target, - Value => Value); - Add_Stmt (N); - end New_Assign_Stmt; - - procedure New_Return_Stmt_1 (Value : O_Enode) - is - subtype O_Snode_Return_Stmt is O_Snode_Type (ON_Return_Stmt); - N : O_Snode; - begin - N := new O_Snode_Return_Stmt'(Kind => ON_Return_Stmt, - Next => null, - Lineno => 0, - Ret_Val => Value); - Add_Stmt (N); - end New_Return_Stmt_1; - - procedure New_Return_Stmt (Value : O_Enode) - is - begin - if Current_Function = null - or else Current_Function.Decl.Dtype = O_Tnode_Null - then - -- Either not in a function or in a procedure. - raise Syntax_Error; - end if; - Check_Type (Value.Rtype, Current_Function.Decl.Dtype); - Check_Ref (Value); - New_Return_Stmt_1 (Value); - end New_Return_Stmt; - - procedure New_Return_Stmt is - begin - if Current_Function = null - or else Current_Function.Decl.Dtype /= O_Tnode_Null - then - -- Not in a procedure. - raise Syntax_Error; - end if; - New_Return_Stmt_1 (null); - end New_Return_Stmt; - - procedure Start_Association (Assocs : out O_Assoc_List; Subprg : O_Dnode) - is - begin - Check_Scope (Subprg); - Assocs.Subprg := Subprg; - Assocs.Interfaces := Subprg.Interfaces; - Assocs.First := null; - Assocs.Last := null; - end Start_Association; - - procedure New_Association (Assocs : in out O_Assoc_List; Val : O_Enode) - is - N : O_Anode; - begin - Check_Type (Assocs.Interfaces.Dtype, Val.Rtype); - Check_Ref (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 - Assocs.Last.Next := N; - end if; - Assocs.Last := N; - end New_Association; - - function New_Function_Call (Assocs : O_Assoc_List) return O_Enode - is - subtype O_Enode_Call is O_Enode_Type (OE_Function_Call); - Res : O_Enode; - begin - if Assocs.Interfaces /= null then - -- Not enough arguments. - raise Syntax_Error; - end if; - if Assocs.Subprg.Dtype = null then - -- This is a procedure. - raise Syntax_Error; - end if; - - Res := new O_Enode_Call'(Kind => OE_Function_Call, - Rtype => Assocs.Subprg.Dtype, - Ref => False, - Func => Assocs.Subprg, - Assoc => Assocs.First); - return Res; - end New_Function_Call; - - procedure New_Procedure_Call (Assocs : in out O_Assoc_List) - is - N : O_Snode; - begin - if Assocs.Interfaces /= null then - -- Not enough arguments. - raise Syntax_Error; - end if; - if Assocs.Subprg.Dtype /= null then - -- This is a function. - raise Syntax_Error; - end if; - N := new O_Snode_Type (ON_Call_Stmt); - N.Proc := Assocs.Subprg; - N.Assoc := Assocs.First; - Add_Stmt (N); - end New_Procedure_Call; - - procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode); - - procedure Start_If_Stmt (Block : in out O_If_Block; Cond : O_Enode) - is - subtype O_Snode_If is O_Snode_Type (ON_If_Stmt); - N : O_Snode; - begin - -- Note: no checks are performed here, since they are done in - -- new_elsif_stmt. - N := new O_Snode_If'(Kind => ON_If_Stmt, - Next => null, - Lineno => 0, - Elsifs => null, - If_Last => null); - Add_Stmt (N); - Push_Stmt_Scope (new Stmt_If_Scope_Type'(Kind => Stmt_If, - Parent => N, - Prev => Current_Stmt_Scope, - Last_Elsif => null)); - New_Elsif_Stmt (Block, Cond); - end Start_If_Stmt; - - procedure New_Elsif_Stmt (Block : in out O_If_Block; Cond : O_Enode) - is - pragma Unreferenced (Block); - N : O_Snode; - begin - if Cond /= null then - if Cond.Rtype.Kind /= ON_Boolean_Type then - raise Type_Error; - end if; - Check_Ref (Cond); - end if; - N := new O_Snode_Type (ON_Elsif_Stmt); - N.all := O_Snode_Type'(Kind => ON_Elsif_Stmt, - Next => null, - Lineno => 0, - Cond => Cond, - Next_Elsif => null); - if Current_Stmt_Scope.Kind /= Stmt_If then - raise Syntax_Error; - end if; - Add_Stmt (N); - if Current_Stmt_Scope.Last_Elsif = null then - Current_Stmt_Scope.Parent.Elsifs := N; - else - -- Check for double 'else' - if Current_Stmt_Scope.Last_Elsif.Cond = null then - raise Syntax_Error; - end if; - Current_Stmt_Scope.Last_Elsif.Next_Elsif := N; - end if; - Current_Stmt_Scope.Last_Elsif := N; - end New_Elsif_Stmt; - - procedure New_Else_Stmt (Block : in out O_If_Block) is - begin - New_Elsif_Stmt (Block, null); - end New_Else_Stmt; - - procedure Finish_If_Stmt (Block : in out O_If_Block) - is - pragma Unreferenced (Block); - Parent : O_Snode; - begin - Parent := Current_Stmt_Scope.Parent; - Pop_Stmt_Scope (Stmt_If); - Parent.If_Last := Current_Decl_Scope.Last_Stmt; - end Finish_If_Stmt; - - procedure Start_Loop_Stmt (Label : out O_Snode) - is - subtype O_Snode_Loop_Type is O_Snode_Type (ON_Loop_Stmt); - begin - Current_Loop_Level := Current_Loop_Level + 1; - Label := new O_Snode_Loop_Type'(Kind => ON_Loop_Stmt, - Next => null, - Lineno => 0, - Loop_Last => null, - Loop_Level => Current_Loop_Level); - Add_Stmt (Label); - Push_Stmt_Scope (new Stmt_Loop_Scope_Type'(Kind => Stmt_Loop, - Parent => Label, - Prev => Current_Stmt_Scope)); - end Start_Loop_Stmt; - - procedure Finish_Loop_Stmt (Label : in out O_Snode) - is - pragma Unreferenced (Label); - Parent : O_Snode; - begin - Parent := Current_Stmt_Scope.Parent; - Pop_Stmt_Scope (Stmt_Loop); - Parent.Loop_Last := Current_Decl_Scope.Last_Stmt; - Current_Loop_Level := Current_Loop_Level - 1; - end Finish_Loop_Stmt; - - procedure New_Exit_Next_Stmt (Kind : ON_Stmt_Kind; L : O_Snode) - is - N : O_Snode; - begin - N := new O_Snode_Type (Kind); - N.Next := null; - N.Loop_Id := L; - Add_Stmt (N); - end New_Exit_Next_Stmt; - - procedure New_Exit_Stmt (L : O_Snode) is - begin - New_Exit_Next_Stmt (ON_Exit_Stmt, L); - end New_Exit_Stmt; - - procedure New_Next_Stmt (L : O_Snode) is - begin - New_Exit_Next_Stmt (ON_Next_Stmt, L); - end New_Next_Stmt; - - procedure Start_Case_Stmt (Block : in out O_Case_Block; Value : O_Enode) - is - subtype O_Snode_Case_Type is O_Snode_Type (ON_Case_Stmt); - N : O_Snode; - begin - case Value.Rtype.Kind is - when ON_Boolean_Type - | ON_Unsigned_Type - | ON_Signed_Type - | ON_Enum_Type => - null; - when others => - raise Type_Error; - end case; - Check_Ref (Value); - N := new O_Snode_Case_Type'(Kind => ON_Case_Stmt, - Next => null, - Lineno => 0, - 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, - Prev => Current_Stmt_Scope, - Last_Branch => null, - Last_Choice => null, - Case_Type => Value.Rtype)); - end Start_Case_Stmt; - - procedure Start_Choice (Block : in out O_Case_Block) - is - N : O_Snode; - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are adding a branch outside a case statment. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Choice /= null then - -- You are creating branch while the previous one was not finished. - raise Syntax_Error; - end if; - - N := new O_Snode_Type (ON_When_Stmt); - 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 - Current_Stmt_Scope.Parent.Branches := N; - else - Current_Stmt_Scope.Last_Branch.Next_Branch := N; - end if; - Current_Stmt_Scope.Last_Branch := N; - Current_Stmt_Scope.Last_Choice := null; - Add_Stmt (N); - end Start_Choice; - - procedure Add_Choice (Block : in out O_Case_Block; Choice : O_Choice) - is - pragma Unreferenced (Block); - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are adding a choice not inside a case statement. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Branch = null then - -- You are not inside a branch. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Choice = null then - if Current_Stmt_Scope.Last_Branch.Choice_List /= null then - -- The branch was already closed. - raise Syntax_Error; - end if; - Current_Stmt_Scope.Last_Branch.Choice_List := Choice; - else - Current_Stmt_Scope.Last_Choice.Next := Choice; - end if; - Current_Stmt_Scope.Last_Choice := Choice; - end Add_Choice; - - procedure New_Expr_Choice (Block : in out O_Case_Block; Expr : O_Cnode) - is - N : O_Choice; - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are creating a choice not inside a case statement. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Case_Type /= Expr.Ctype then - -- Expr type is not the same as choice type. - raise Type_Error; - end if; - - N := new O_Choice_Type (ON_Choice_Expr); - N.all := O_Choice_Type'(Kind => ON_Choice_Expr, - Next => null, - Expr => Expr); - Add_Choice (Block, N); - end New_Expr_Choice; - - procedure New_Range_Choice (Block : in out O_Case_Block; - Low, High : O_Cnode) - is - N : O_Choice; - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are creating a choice not inside a case statement. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Case_Type /= Low.Ctype - or Current_Stmt_Scope.Case_Type /= High.Ctype - then - -- Low/High type is not the same as choice type. - raise Type_Error; - end if; - - N := new O_Choice_Type (ON_Choice_Range); - N.all := O_Choice_Type'(Kind => ON_Choice_Range, - Next => null, - Low => Low, - High => High); - Add_Choice (Block, N); - end New_Range_Choice; - - procedure New_Default_Choice (Block : in out O_Case_Block) - is - N : O_Choice; - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are creating a choice not inside a case statement. - raise Syntax_Error; - end if; - - N := new O_Choice_Type (ON_Choice_Default); - N.all := O_Choice_Type'(Kind => ON_Choice_Default, - Next => null); - Add_Choice (Block, N); - end New_Default_Choice; - - procedure Finish_Choice (Block : in out O_Case_Block) - is - pragma Unreferenced (Block); - begin - if Current_Stmt_Scope.Kind /= Stmt_Case then - -- You are adding a choice not inside a case statement. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Branch = null then - -- You are not inside a branch. - raise Syntax_Error; - end if; - if Current_Stmt_Scope.Last_Choice = null then - -- The branch is empty or you are not inside a branch. - raise Syntax_Error; - end if; - Current_Stmt_Scope.Last_Choice := null; - end Finish_Choice; - - procedure Finish_Case_Stmt (Block : in out O_Case_Block) - is - pragma Unreferenced (Block); - Parent : O_Snode; - begin - Parent := Current_Stmt_Scope.Parent; - Pop_Stmt_Scope (Stmt_Case); - Parent.Case_Last := Current_Decl_Scope.Last_Stmt; - end Finish_Case_Stmt; - - procedure Init is - begin - Top := new O_Snode_Type (ON_Declare_Stmt); - Push_Decl_Scope (Top); - end Init; - - procedure Finish is - begin - Pop_Decl_Scope; - end Finish; -end Ortho_Debug; diff --git a/ortho/debug/ortho_debug.private.ads b/ortho/debug/ortho_debug.private.ads deleted file mode 100644 index 69ee16c..0000000 --- a/ortho/debug/ortho_debug.private.ads +++ /dev/null @@ -1,467 +0,0 @@ --- Ortho debug back-end declarations. --- Copyright (C) 2005-2014 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. - -with Interfaces; use Interfaces; -with Ortho_Ident; -use Ortho_Ident; - --- Interface to create nodes. -package Ortho_Debug is - procedure Init; - procedure Finish; - -private - -- This back-end supports nested subprograms. - Has_Nested_Subprograms : constant Boolean := True; - - -- A node for a type. - type O_Tnode_Type (<>); - type O_Tnode is access O_Tnode_Type; - - -- A node for a statement. - type O_Snode_Type (<>); - type O_Snode is access O_Snode_Type; - - Top : O_Snode; - - type Str_Acc is access String; - - type Decl_Scope_Type; - type Decl_Scope_Acc is access Decl_Scope_Type; - - type On_Decl_Kind is - (ON_Type_Decl, ON_Completed_Type_Decl, - ON_Const_Decl, ON_Var_Decl, ON_Interface_Decl, - ON_Function_Decl, ON_Function_Body, - ON_Const_Value, - ON_Debug_Line_Decl, ON_Debug_Comment_Decl, ON_Debug_Filename_Decl); - - type O_Dnode_Type (<>); - type O_Dnode is access O_Dnode_Type; - - O_Dnode_Null : constant O_Dnode := null; - - type O_Dnode_Type (Kind : On_Decl_Kind) is record - Next : O_Dnode; - Name : O_Ident; - Dtype : O_Tnode; - Storage : O_Storage; - -- Declare statement in which the declaration appears. - Scope : O_Snode; - -- Line number, for regen. - Lineno : Natural; - case Kind is - when ON_Type_Decl => - null; - when ON_Completed_Type_Decl => - null; - when ON_Const_Decl => - Const_Value : O_Dnode; - when ON_Const_Value => - Const_Decl : O_Dnode; - Value : O_Cnode; - when ON_Var_Decl => - null; - when ON_Function_Decl => - Interfaces : O_Dnode; - Func_Body : O_Dnode; - Alive : Boolean; - when ON_Function_Body => - Func_Decl : O_Dnode; - Func_Stmt : O_Snode; - when ON_Interface_Decl => - Func_Scope : O_Dnode; - when ON_Debug_Line_Decl => - Line : Natural; - when ON_Debug_Comment_Decl => - Comment : Str_Acc; - when ON_Debug_Filename_Decl => - Filename : Str_Acc; - end case; - end record; - - -- A node for a record element. - type O_Fnode_Type; - type O_Fnode is access O_Fnode_Type; - - O_Fnode_Null : constant O_Fnode := null; - - type O_Fnode_Type is record - -- Record type. - Parent : O_Tnode; - -- Next field in the record. - Next : O_Fnode; - -- Name of the record field. - Ident : O_Ident; - -- Type of the record field. - Ftype : O_Tnode; - -- Offset in the field. - Offset : Unsigned_32; - end record; - - type O_Anode_Type; - type O_Anode is access O_Anode_Type; - type O_Anode_Type is record - Next : O_Anode; - Formal : O_Dnode; - Actual : O_Enode; - end record; - - type OC_Kind is - ( - OC_Boolean_Lit, - OC_Unsigned_Lit, - OC_Signed_Lit, - OC_Float_Lit, - OC_Enum_Lit, - OC_Null_Lit, - OC_Sizeof_Lit, - OC_Alignof_Lit, - OC_Offsetof_Lit, - OC_Aggregate, - OC_Aggr_Element, - OC_Union_Aggr, - OC_Address, - OC_Unchecked_Address, - OC_Subprogram_Address - ); - type O_Cnode_Type (Kind : OC_Kind) is record - -- Type of the constant. - Ctype : O_Tnode; - -- True if referenced. - Ref : Boolean; - case Kind is - when OC_Unsigned_Lit => - U_Val : Unsigned_64; - when OC_Signed_Lit => - S_Val : Integer_64; - when OC_Float_Lit => - F_Val : IEEE_Float_64; - when OC_Boolean_Lit => - B_Val : Boolean; - B_Id : O_Ident; - when OC_Enum_Lit => - E_Val : Integer; - E_Next : O_Cnode; - E_Name : O_Ident; - when OC_Null_Lit => - null; - when OC_Sizeof_Lit - | OC_Alignof_Lit => - S_Type : O_Tnode; - when OC_Offsetof_Lit => - Off_Field : O_Fnode; - when OC_Aggregate => - Aggr_Els : O_Cnode; - when OC_Union_Aggr => - Uaggr_Field : O_Fnode; - Uaggr_Value : O_Cnode; - when OC_Aggr_Element => - Aggr_Value : O_Cnode; - Aggr_Next : O_Cnode; - when OC_Address - | OC_Unchecked_Address - | OC_Subprogram_Address => - Decl : O_Dnode; - end case; - end record; - - type O_Cnode is access O_Cnode_Type; - O_Cnode_Null : constant O_Cnode := null; - - type OE_Kind is - ( - -- Literals. - OE_Lit, - - -- Dyadic operations. - OE_Add_Ov, -- OE_Dyadic_Op_Kind - OE_Sub_Ov, -- OE_Dyadic_Op_Kind - OE_Mul_Ov, -- OE_Dyadic_Op_Kind - OE_Div_Ov, -- OE_Dyadic_Op_Kind - OE_Rem_Ov, -- OE_Dyadic_Op_Kind - OE_Mod_Ov, -- OE_Dyadic_Op_Kind - OE_Exp_Ov, -- OE_Dyadic_Op_Kind - - -- Binary operations. - OE_And, -- OE_Dyadic_Op_Kind - OE_Or, -- OE_Dyadic_Op_Kind - OE_Xor, -- OE_Dyadic_Op_Kind - OE_And_Then, -- OE_Dyadic_Op_Kind - OE_Or_Else, -- OE_Dyadic_Op_Kind - - -- Monadic operations. - OE_Not, -- OE_Monadic_Op_Kind - OE_Neg_Ov, -- OE_Monadic_Op_Kind - OE_Abs_Ov, -- OE_Monadic_Op_Kind - - -- Comparaisons - OE_Eq, -- OE_Compare_Op_Kind - OE_Neq, -- OE_Compare_Op_Kind - OE_Le, -- OE_Compare_Op_Kind - OE_Lt, -- OE_Compare_Op_Kind - OE_Ge, -- OE_Compare_Op_Kind - OE_Gt, -- OE_Compare_Op_Kind - - -- Misc. - OE_Convert_Ov, - OE_Address, - OE_Unchecked_Address, - OE_Alloca, - OE_Function_Call, - - OE_Value, - OE_Nil - ); - - subtype OE_Dyadic_Expr_Kind is OE_Kind range OE_Add_Ov .. OE_Or_Else; - subtype OE_Monadic_Expr_Kind is OE_Kind range OE_Not .. OE_Abs_Ov; - subtype OE_Compare_Expr_Kind is OE_Kind range OE_Eq .. OE_Gt; - - type O_Enode_Type (Kind : OE_Kind); - type O_Enode is access O_Enode_Type; - O_Enode_Null : constant O_Enode := null; - - type O_Enode_Type (Kind : OE_Kind) is record - -- Type of the result. - Rtype : O_Tnode; - -- True if referenced. - Ref : Boolean; - case Kind is - when OE_Dyadic_Expr_Kind - | OE_Compare_Expr_Kind => - Left : O_Enode; - Right : O_Enode; - when OE_Monadic_Expr_Kind => - Operand : O_Enode; - when OE_Lit => - Lit : O_Cnode; - when OE_Address - | OE_Unchecked_Address => - Lvalue : O_Lnode; - when OE_Convert_Ov => - Conv : O_Enode; - when OE_Function_Call => - Func : O_Dnode; - Assoc : O_Anode; - when OE_Value => - Value : O_Lnode; - when OE_Alloca => - A_Size : O_Enode; - when OE_Nil => - null; - end case; - end record; - type O_Enode_Array is array (Natural range <>) of O_Enode; - type O_Enode_Array_Acc is access O_Enode_Array; - - type OL_Kind is - ( - -- Name. - OL_Obj, - OL_Indexed_Element, - OL_Slice, - OL_Selected_Element, - OL_Access_Element - - -- Variable, constant, parameter reference. - -- This allows to read/write a declaration. - --OL_Var_Ref, - --OL_Const_Ref, - --OL_Param_Ref - ); - - type O_Lnode_Type (Kind : OL_Kind); - type O_Lnode is access O_Lnode_Type; - O_Lnode_Null : constant O_Lnode := null; - - type O_Lnode_Type (Kind : OL_Kind) is record - -- Type of the result. - Rtype : O_Tnode; - -- True if referenced. - Ref : Boolean; - case Kind is - when OL_Obj => - Obj : O_Dnode; - when OL_Indexed_Element => - Array_Base : O_Lnode; - Index : O_Enode; - when OL_Slice => - Slice_Base : O_Lnode; - Slice_Index : O_Enode; - when OL_Selected_Element => - Rec_Base : O_Lnode; - Rec_El : O_Fnode; - when OL_Access_Element => - Acc_Base : O_Enode; --- when OL_Var_Ref --- | OL_Const_Ref --- | OL_Param_Ref => --- Decl : O_Dnode; - end case; - end record; - - 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); - 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; - case Kind is - when ON_Boolean_Type => - True_N : O_Cnode; - False_N : O_Cnode; - when ON_Unsigned_Type - | ON_Signed_Type => - Int_Size : Natural; - when ON_Float_Type => - null; - when ON_Enum_Type => - Nbr : Natural; - Literals: O_Cnode; - when ON_Array_Type => - El_Type : O_Tnode; - Index_Type : O_Tnode; - when ON_Access_Type => - D_Type : O_Tnode; - when ON_Record_Type - | ON_Union_Type => - Elements : O_Fnode; - when ON_Array_Sub_Type => - Length : O_Cnode; - Base_Type : O_Tnode; - end case; - end record; - - type ON_Choice_Kind is (ON_Choice_Expr, ON_Choice_Range, ON_Choice_Default); - type O_Choice_Type (Kind : ON_Choice_Kind); - type O_Choice is access O_Choice_Type; - type O_Choice_Type (Kind : ON_Choice_Kind) is record - Next : O_Choice; - case Kind is - when ON_Choice_Expr => - Expr : O_Cnode; - when ON_Choice_Range => - Low, High : O_Cnode; - when ON_Choice_Default => - null; - end case; - end record; - - O_Snode_Null : constant O_Snode := null; - type ON_Stmt_Kind is - (ON_Declare_Stmt, ON_Assign_Stmt, ON_Return_Stmt, ON_If_Stmt, - ON_Elsif_Stmt, ON_Loop_Stmt, ON_Exit_Stmt, ON_Next_Stmt, - ON_Case_Stmt, ON_When_Stmt, ON_Call_Stmt, - ON_Debug_Line_Stmt, ON_Debug_Comment_Stmt); - type O_Snode_Type (Kind : ON_Stmt_Kind) is record - Next : O_Snode; - Lineno : Natural; - case Kind is - when ON_Declare_Stmt => - Decls : O_Dnode; - Stmts : O_Snode; - -- True if the statement is currently open. - Alive : Boolean; - when ON_Assign_Stmt => - Target : O_Lnode; - Value : O_Enode; - when ON_Return_Stmt => - Ret_Val : O_Enode; - when ON_If_Stmt => - Elsifs : O_Snode; - If_Last : O_Snode; - when ON_Elsif_Stmt => - Cond : O_Enode; - Next_Elsif : O_Snode; - when ON_Loop_Stmt => - Loop_Last : O_Snode; - Loop_Level : Natural; - when ON_Exit_Stmt - | ON_Next_Stmt => - 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 => - Proc : O_Dnode; - Assoc : O_Anode; - when ON_Debug_Line_Stmt => - Line : Natural; - when ON_Debug_Comment_Stmt => - Comment : Str_Acc; - end case; - end record; - - type O_Inter_List is record - Func : O_Dnode; - Last : O_Dnode; - end record; - - type O_Element_List is record - -- The type definition. - Res : O_Tnode; - -- The last element added. - Last : O_Fnode; - end record; - - type O_Record_Aggr_List is record - Res : O_Cnode; - Last : O_Cnode; - Field : O_Fnode; - end record; - - type O_Array_Aggr_List is record - Res : O_Cnode; - Last : O_Cnode; - El_Type : O_Tnode; - end record; - - type O_Assoc_List is record - Subprg : O_Dnode; - Interfaces : O_Dnode; - First, Last : O_Anode; - end record; - - type O_Enum_List is record - -- The type built. - Res : O_Tnode; - - -- the chain of declarations. - Last : O_Cnode; - end record; - type O_Case_Block is record - Case_Stmt : O_Snode; - end record; - - type O_If_Block is record - null; - end record; -end Ortho_Debug; diff --git a/ortho/debug/ortho_debug_front.ads b/ortho/debug/ortho_debug_front.ads deleted file mode 100644 index 17e32c9..0000000 --- a/ortho/debug/ortho_debug_front.ads +++ /dev/null @@ -1,20 +0,0 @@ --- Ortho debug interface with front-end. --- 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. - -with Ortho_Front; -package Ortho_Debug_Front renames Ortho_Front; diff --git a/ortho/debug/ortho_ident.ads b/ortho/debug/ortho_ident.ads deleted file mode 100644 index 46aa885..0000000 --- a/ortho/debug/ortho_ident.ads +++ /dev/null @@ -1,20 +0,0 @@ --- Ortho debug back-end interface with identifiers package. --- 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. - -with Ortho_Ident_Simple; -package Ortho_Ident renames Ortho_Ident_Simple; diff --git a/ortho/debug/ortho_ident_hash.adb b/ortho/debug/ortho_ident_hash.adb deleted file mode 100644 index 60ab895..0000000 --- a/ortho/debug/ortho_ident_hash.adb +++ /dev/null @@ -1,72 +0,0 @@ --- Ortho debug hashed identifiers implementation. --- 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_Ident_Hash is - type O_Ident_Array is array (Hash_Type range <>) of O_Ident; - Hash_Max : constant Hash_Type := 511; - Symtable : O_Ident_Array (0 .. Hash_Max - 1) := (others => null); - - function Get_Identifier (Str : String) return O_Ident - is - Hash : Hash_Type; - Ent : Hash_Type; - Res : O_Ident; - begin - -- 1. Compute Hash. - Hash := 0; - for I in Str'Range loop - Hash := Hash * 31 + Character'Pos (Str (I)); - end loop; - - -- 2. Search. - Ent := Hash mod Hash_Max; - Res := Symtable (Ent); - while Res /= null loop - if Res.Hash = Hash and then Res.Ident.all = Str then - return Res; - end if; - Res := Res.Next; - end loop; - - -- Not found: add. - Res := new Ident_Type'(Hash => Hash, - Ident => new String'(Str), - Next => Symtable (Ent)); - Symtable (Ent) := Res; - return Res; - end Get_Identifier; - - function Get_String (Id : O_Ident) return String is - begin - if Id = null then - return "?ANON?"; - else - return Id.Ident.all; - end if; - end Get_String; - - function Is_Nul (Id : O_Ident) return Boolean is - begin - return Id = null; - end Is_Nul; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean is - begin - return Id.Ident.all = Str; - end Is_Equal; -end Ortho_Ident_Hash; diff --git a/ortho/debug/ortho_ident_hash.ads b/ortho/debug/ortho_ident_hash.ads deleted file mode 100644 index a6e4a56..0000000 --- a/ortho/debug/ortho_ident_hash.ads +++ /dev/null @@ -1,46 +0,0 @@ --- Ortho debug hashed identifiers implementation. --- 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 Ortho_Ident_Hash is - type O_Ident is private; - O_Ident_Nul : constant O_Ident; - - function Get_Identifier (Str : String) return O_Ident; - function Get_String (Id : O_Ident) return String; - function Is_Equal (L, R : O_Ident) return Boolean renames "="; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - function Is_Nul (Id : O_Ident) return Boolean; -private - type Hash_Type is mod 2**32; - - type String_Acc is access constant String; - - -- Symbol table. - type Ident_Type; - type O_Ident is access Ident_Type; - type Ident_type is record - -- The hash for the symbol. - Hash : Hash_Type; - -- Identification of the symbol. - Ident : String_Acc; - -- Next symbol with the same collision. - Next : O_Ident; - end record; - - O_Ident_Nul : constant O_Ident := null; -end Ortho_Ident_Hash; diff --git a/ortho/debug/ortho_ident_simple.adb b/ortho/debug/ortho_ident_simple.adb deleted file mode 100644 index 83b9756..0000000 --- a/ortho/debug/ortho_ident_simple.adb +++ /dev/null @@ -1,44 +0,0 @@ --- Ortho debug identifiers simple implementation. --- 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_Ident_Simple is - function Get_Identifier (Str : String) return O_Ident - is - begin - return new String'(Str); - end Get_Identifier; - - function Get_String (Id : O_Ident) return String is - begin - if Id = null then - return "?ANON?"; - else - return Id.all; - end if; - end Get_String; - - function Is_Nul (Id : O_Ident) return Boolean is - begin - return Id = null; - end Is_Nul; - - function Is_Equal (Id : O_Ident; Str : String) return Boolean is - begin - return Id.all = Str; - end Is_Equal; -end Ortho_Ident_Simple; diff --git a/ortho/debug/ortho_ident_simple.ads b/ortho/debug/ortho_ident_simple.ads deleted file mode 100644 index f94fe19..0000000 --- a/ortho/debug/ortho_ident_simple.ads +++ /dev/null @@ -1,31 +0,0 @@ --- Ortho debug identifiers simple implementation. --- 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 Ortho_Ident_Simple is - type O_Ident is private; - O_Ident_Nul : constant O_Ident; - - function Get_Identifier (Str : String) return O_Ident; - function Get_String (Id : O_Ident) return String; - function Is_Equal (L, R : O_Ident) return Boolean renames "="; - function Is_Equal (Id : O_Ident; Str : String) return Boolean; - function Is_Nul (Id : O_Ident) return Boolean; -private - type O_Ident is access String; - O_Ident_Nul : constant O_Ident := null; -end Ortho_Ident_Simple; diff --git a/ortho/debug/ortho_nodes.ads b/ortho/debug/ortho_nodes.ads deleted file mode 100644 index 8ade667..0000000 --- a/ortho/debug/ortho_nodes.ads +++ /dev/null @@ -1,21 +0,0 @@ --- Ortho debug back-end interface with front-end. --- 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. - -with Ortho_Debug; - -package Ortho_Nodes renames Ortho_Debug; |