diff options
Diffstat (limited to 'src/ortho/debug/ortho_debug.adb')
| -rw-r--r-- | src/ortho/debug/ortho_debug.adb | 1931 |
1 files changed, 1931 insertions, 0 deletions
diff --git a/src/ortho/debug/ortho_debug.adb b/src/ortho/debug/ortho_debug.adb new file mode 100644 index 0000000..8285a64 --- /dev/null +++ b/src/ortho/debug/ortho_debug.adb @@ -0,0 +1,1931 @@ +-- 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; |