-- 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 -- Metrics: -- Alignment and size for an address. Metric_Access_Align : constant Natural := 2; Metric_Access_Size : constant Unsigned_32 := 4; 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, ON_And_Then => OE_And_Then, ON_Or_Else => OE_Or_Else, -- 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 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_Offsetof (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 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, Align => 0, Size => 0, 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, Align => 0, Size => 0, Uncomplete => False, Complete => False, Elements => O_Fnode_Null); Elements.Last := null; end Start_Record_Type; function Align_Size (Size : Unsigned_32; Align : Natural) return Unsigned_32 is M : Unsigned_32; begin M := (2 ** Align) - 1; return (Size + M) and (not M); end Align_Size; 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); -- The alignment of a structure is the max alignment of its field. if Etype.Align > Elements.Res.Align then Elements.Res.Align := Etype.Align; end if; -- Align the current size for the new field. Elements.Res.Size := Align_Size (Elements.Res.Size, Etype.Align); El := new O_Fnode_Type'(Parent => Elements.Res, Next => null, Ident => Ident, Ftype => Etype, Offset => Elements.Res.Size); -- Add the size of the field. Elements.Res.Size := Elements.Res.Size + Etype.Size; 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; Res.Size := Align_Size (Res.Size, Res.Align); 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, Align => 0, Size => 0, 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 -- Align the structure. Res := Elements.Res; Res.Size := Align_Size (Res.Size, Res.Align); 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, Align => Metric_Access_Align, Size => Metric_Access_Size, 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, Align => El_Type.Align, Size => 0, 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); Size : Unsigned_32; begin if Atype.Kind /= ON_Array_Type then raise Type_Error; end if; Size := Unsigned_32 (Length.U_Val) * Atype.El_Type.Size; return new O_Tnode_Sub_Array'(Kind => ON_Array_Sub_Type, Decl => O_Dnode_Null, Align => Atype.Align, Size => Size, Uncomplete => False, Complete => True, Base_Type => Atype, Length => Length); end New_Constrained_Array_Type; function Get_Scalar_Pow (Bit_Size : Natural) return Natural is begin if Bit_Size <= 8 then return 0; elsif Bit_Size <= 32 then return 2; elsif Bit_Size <= 64 then return 3; else raise Type_Error; end if; end Get_Scalar_Pow; function New_Unsigned_Type (Size : Natural) return O_Tnode is subtype O_Tnode_Unsigned is O_Tnode_Type (ON_Unsigned_Type); Align : Natural; begin Align := Get_Scalar_Pow (Size); return new O_Tnode_Unsigned'(Kind => ON_Unsigned_Type, Decl => O_Dnode_Null, Align => Align, Size => 2 ** Align, Uncomplete => False, Complete => True); 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); Align : Natural; begin Align := Get_Scalar_Pow (Size); return new O_Tnode_Signed'(Kind => ON_Signed_Type, Decl => O_Dnode_Null, Align => Align, Size => 2 ** Align, Uncomplete => False, Complete => True); 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, Align => 0, Size => 1, 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, Align => 0, Size => 1, 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 subtype O_Tnode_Enum is O_Tnode_Type (ON_Enum_Type); Res : O_Tnode; Align : Natural; begin Align := Get_Scalar_Pow (Size); Res := new O_Tnode_Enum'(Kind => ON_Enum_Type, Decl => O_Dnode_Null, Align => Align, Size => 2 ** Align, 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; Rtype : O_Tnode; begin case Arr.Rtype.Kind is when ON_Array_Type => Rtype := Arr.Rtype.El_Type; when ON_Array_Sub_Type => Rtype := Arr.Rtype.Base_Type.El_Type; when others => raise Type_Error; end case; 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 raise Type_Error; 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 (ON_Debug_Line_Decl); N : O_Dnode_Line_Decl; begin N := new O_Dnode_Type (ON_Debug_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 (ON_Debug_Comment_Decl); N : O_Dnode_Comment_Decl; begin N := new O_Dnode_Type (ON_Debug_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); Assocs.Interfaces := Assocs.Interfaces.Next; Check_Ref (Val); N := new O_Anode_Type'(Next => null, Formal => null, Actual => Val); 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 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 pragma Unreferenced (Block); 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); 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 pragma Unreferenced (Block); 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, 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;