-- Iir to ortho translator. -- Copyright (C) 2002-2014 Tristan Gingold -- -- GHDL is free software; you can redistribute it and/or modify it under -- the terms of the GNU General Public License as published by the Free -- Software Foundation; either version 2, or (at your option) any later -- version. -- -- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY -- WARRANTY; without even the implied warranty of MERCHANTABILITY or -- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- for more details. -- -- You should have received a copy of the GNU General Public License -- along with GCC; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Name_Table; -- use Name_Table; with Nodes; with GNAT.Table; with Trans_Decls; use Trans_Decls; package body Trans is use Trans.Helpers; package body Subprgs is procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack) is begin Prev := Current_Subprg_Instance; Current_Subprg_Instance := Null_Subprg_Instance_Stack; end Clear_Subprg_Instance; procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; Ptr_Type : O_Tnode; Ident : O_Ident; Prev : out Subprg_Instance_Stack) is begin Prev := Current_Subprg_Instance; Current_Subprg_Instance := (Scope => Scope, Ptr_Type => Ptr_Type, Ident => Ident); end Push_Subprg_Instance; function Has_Current_Subprg_Instance return Boolean is begin return Current_Subprg_Instance.Ptr_Type /= O_Tnode_Null; end Has_Current_Subprg_Instance; procedure Pop_Subprg_Instance (Ident : O_Ident; Prev : Subprg_Instance_Stack) is begin if Is_Equal (Current_Subprg_Instance.Ident, Ident) then Current_Subprg_Instance := Prev; else -- POP does not match with a push. raise Internal_Error; end if; end Pop_Subprg_Instance; procedure Add_Subprg_Instance_Interfaces (Interfaces : in out O_Inter_List; Vars : out Subprg_Instance_Type) is begin if Has_Current_Subprg_Instance then Vars.Scope := Current_Subprg_Instance.Scope; Vars.Inter_Type := Current_Subprg_Instance.Ptr_Type; New_Interface_Decl (Interfaces, Vars.Inter, Current_Subprg_Instance.Ident, Current_Subprg_Instance.Ptr_Type); else Vars := Null_Subprg_Instance; end if; end Add_Subprg_Instance_Interfaces; procedure Add_Subprg_Instance_Field (Field : out O_Fnode) is begin if Has_Current_Subprg_Instance then Field := Add_Instance_Factory_Field (Current_Subprg_Instance.Ident, Current_Subprg_Instance.Ptr_Type); else Field := O_Fnode_Null; end if; end Add_Subprg_Instance_Field; function Has_Subprg_Instance (Vars : Subprg_Instance_Type) return Boolean is begin return Vars.Inter /= O_Dnode_Null; end Has_Subprg_Instance; function Get_Subprg_Instance (Vars : Subprg_Instance_Type) return O_Enode is begin pragma Assert (Has_Subprg_Instance (Vars)); return New_Address (Get_Instance_Ref (Vars.Scope.all), Vars.Inter_Type); end Get_Subprg_Instance; procedure Add_Subprg_Instance_Assoc (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type) is begin if Has_Subprg_Instance (Vars) then New_Association (Assocs, Get_Subprg_Instance (Vars)); end if; end Add_Subprg_Instance_Assoc; procedure Set_Subprg_Instance_Field (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type) is begin if Has_Subprg_Instance (Vars) then New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Var), Field), New_Obj_Value (Vars.Inter)); end if; end Set_Subprg_Instance_Field; procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is begin if Has_Subprg_Instance (Vars) then Set_Scope_Via_Param_Ptr (Vars.Scope.all, Vars.Inter); end if; end Start_Subprg_Instance_Use; procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is begin if Has_Subprg_Instance (Vars) then Clear_Scope (Vars.Scope.all); end if; end Finish_Subprg_Instance_Use; procedure Start_Prev_Subprg_Instance_Use_Via_Field (Prev : Subprg_Instance_Stack; Field : O_Fnode) is begin if Field /= O_Fnode_Null then Set_Scope_Via_Field_Ptr (Prev.Scope.all, Field, Current_Subprg_Instance.Scope); end if; end Start_Prev_Subprg_Instance_Use_Via_Field; procedure Finish_Prev_Subprg_Instance_Use_Via_Field (Prev : Subprg_Instance_Stack; Field : O_Fnode) is begin if Field /= O_Fnode_Null then Clear_Scope (Prev.Scope.all); end if; end Finish_Prev_Subprg_Instance_Use_Via_Field; procedure Create_Subprg_Instance (Interfaces : in out O_Inter_List; Subprg : Iir) is begin Add_Subprg_Instance_Interfaces (Interfaces, Get_Info (Subprg).Subprg_Instance); end Create_Subprg_Instance; procedure Start_Subprg_Instance_Use (Subprg : Iir) is begin Start_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); end Start_Subprg_Instance_Use; procedure Finish_Subprg_Instance_Use (Subprg : Iir) is begin Finish_Subprg_Instance_Use (Get_Info (Subprg).Subprg_Instance); end Finish_Subprg_Instance_Use; function Instantiate_Subprg_Instance (Inst : Subprg_Instance_Type) return Subprg_Instance_Type is begin return Subprg_Instance_Type' (Inter => Inst.Inter, Inter_Type => Inst.Inter_Type, Scope => Instantiated_Var_Scope (Inst.Scope)); end Instantiate_Subprg_Instance; end Subprgs; package body Chap10 is -- Identifiers. -- The following functions are helpers to create ortho identifiers. Identifier_Buffer : String (1 .. 512); Identifier_Len : Natural := 0; Identifier_Start : Natural := 1; Identifier_Local : Local_Identifier_Type := 0; Inst_Build : Inst_Build_Acc := null; procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation (Object => Inst_Build_Type, Name => Inst_Build_Acc); procedure Set_Global_Storage (Storage : O_Storage) is begin Global_Storage := Storage; end Set_Global_Storage; procedure Pop_Build_Instance is Old : Inst_Build_Acc; begin Old := Inst_Build; Identifier_Start := Old.Prev_Id_Start; Inst_Build := Old.Prev; Unchecked_Deallocation (Old); end Pop_Build_Instance; function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode is begin pragma Assert (Scope.Scope_Type /= O_Tnode_Null); return Scope.Scope_Type; end Get_Scope_Type; function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode is begin pragma Assert (Scope.Scope_Type /= O_Tnode_Null); return New_Sizeof (Scope.Scope_Type, Ghdl_Index_Type); end Get_Scope_Size; function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean is begin return Scope.Scope_Type /= O_Tnode_Null; end Has_Scope_Type; procedure Predeclare_Scope_Type (Scope : in out Var_Scope_Type; Name : O_Ident) is begin pragma Assert (Scope.Scope_Type = O_Tnode_Null); New_Uncomplete_Record_Type (Scope.Scope_Type); New_Type_Decl (Name, Scope.Scope_Type); end Predeclare_Scope_Type; procedure Declare_Scope_Acc (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode) is begin Ptr_Type := New_Access_Type (Get_Scope_Type (Scope)); New_Type_Decl (Name, Ptr_Type); end Declare_Scope_Acc; procedure Push_Instance_Factory (Scope : Var_Scope_Acc) is Inst : Inst_Build_Acc; begin if Inst_Build /= null and then Inst_Build.Kind /= Instance then raise Internal_Error; end if; Inst := new Inst_Build_Type (Instance); Inst.Prev := Inst_Build; Inst.Prev_Id_Start := Identifier_Start; Inst.Scope := Scope; Identifier_Start := Identifier_Len + 1; if Scope.Scope_Type /= O_Tnode_Null then Start_Uncomplete_Record_Type (Scope.Scope_Type, Inst.Elements); else Start_Record_Type (Inst.Elements); end if; Inst_Build := Inst; end Push_Instance_Factory; function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) return O_Fnode is Res : O_Fnode; begin New_Record_Field (Inst_Build.Elements, Res, Name, Ftype); return Res; end Add_Instance_Factory_Field; procedure Add_Scope_Field (Name : O_Ident; Child : in out Var_Scope_Type) is Field : O_Fnode; begin Field := Add_Instance_Factory_Field (Name, Get_Scope_Type (Child)); Set_Scope_Via_Field (Child, Field, Inst_Build.Scope); end Add_Scope_Field; function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) return O_Cnode is begin return New_Offsetof (Get_Scope_Type (Child.Up_Link.all), Child.Field, Otype); end Get_Scope_Offset; procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc) is Res : O_Tnode; begin if Inst_Build.Kind /= Instance then -- Not matching. raise Internal_Error; end if; Finish_Record_Type (Inst_Build.Elements, Res); Pop_Build_Instance; Scope.Scope_Type := Res; end Pop_Instance_Factory; procedure Push_Local_Factory is Inst : Inst_Build_Acc; begin if Inst_Build /= null and then (Inst_Build.Kind /= Global and Inst_Build.Kind /= Local) then -- Cannot create a local factory on an instance. raise Internal_Error; end if; Inst := new Inst_Build_Type (Kind => Local); Inst.Prev := Inst_Build; Inst.Prev_Global_Storage := Global_Storage; Inst.Prev_Id_Start := Identifier_Start; Identifier_Start := Identifier_Len + 1; Inst_Build := Inst; case Global_Storage is when O_Storage_Public => Global_Storage := O_Storage_Private; when O_Storage_Private | O_Storage_External => null; when O_Storage_Local => raise Internal_Error; end case; end Push_Local_Factory; -- Return TRUE is the current scope is local. function Is_Local_Scope return Boolean is begin if Inst_Build = null then return False; end if; case Inst_Build.Kind is when Local | Instance => return True; when Global => return False; end case; end Is_Local_Scope; procedure Pop_Local_Factory is begin if Inst_Build.Kind /= Local then -- Not matching. raise Internal_Error; end if; Global_Storage := Inst_Build.Prev_Global_Storage; Pop_Build_Instance; end Pop_Local_Factory; procedure Set_Scope_Via_Field (Scope : in out Var_Scope_Type; Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is begin pragma Assert (Scope.Kind = Var_Scope_None); Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_Field, Field => Scope_Field, Up_Link => Scope_Parent); end Set_Scope_Via_Field; procedure Set_Scope_Via_Field_Ptr (Scope : in out Var_Scope_Type; Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is begin pragma Assert (Scope.Kind = Var_Scope_None); Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_Field_Ptr, Field => Scope_Field, Up_Link => Scope_Parent); end Set_Scope_Via_Field_Ptr; procedure Set_Scope_Via_Var_Ptr (Scope : in out Var_Scope_Type; Var : Var_Type) is begin pragma Assert (Scope.Kind = Var_Scope_None); pragma Assert (Var.Kind = Var_Scope); Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_Field_Ptr, Field => Var.I_Field, Up_Link => Var.I_Scope); end Set_Scope_Via_Var_Ptr; procedure Set_Scope_Via_Param_Ptr (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode) is begin pragma Assert (Scope.Kind = Var_Scope_None); Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_Ptr, D => Scope_Param); end Set_Scope_Via_Param_Ptr; procedure Set_Scope_Via_Decl (Scope : in out Var_Scope_Type; Decl : O_Dnode) is begin pragma Assert (Scope.Kind = Var_Scope_None); Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_Decl, D => Decl); end Set_Scope_Via_Decl; procedure Clear_Scope (Scope : in out Var_Scope_Type) is begin pragma Assert (Scope.Kind /= Var_Scope_None); Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_None); end Clear_Scope; function Create_Global_Var (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) return Var_Type is Var : O_Dnode; begin New_Var_Decl (Var, Name, Storage, Vtype); return Var_Type'(Kind => Var_Global, E => Var); end Create_Global_Var; function Create_Global_Const (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage; Initial_Value : O_Cnode) return Var_Type is Res : O_Dnode; begin New_Const_Decl (Res, Name, Storage, Vtype); if Storage /= O_Storage_External and then Initial_Value /= O_Cnode_Null then Start_Const_Value (Res); Finish_Const_Value (Res, Initial_Value); end if; return Var_Type'(Kind => Var_Global, E => Res); end Create_Global_Const; procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode) is begin Start_Const_Value (Const.E); Finish_Const_Value (Const.E, Val); end Define_Global_Const; function Create_Var (Name : Var_Ident_Type; Vtype : O_Tnode; Storage : O_Storage := Global_Storage) return Var_Type is Res : O_Dnode; Field : O_Fnode; K : Inst_Build_Kind_Type; begin if Inst_Build = null then K := Global; else K := Inst_Build.Kind; end if; case K is when Global => -- The global scope is in use... return Create_Global_Var (Name.Id, Vtype, Storage); when Local => -- It is always possible to create a variable in a local scope. -- Create a var. New_Var_Decl (Res, Name.Id, O_Storage_Local, Vtype); return Var_Type'(Kind => Var_Local, E => Res); when Instance => -- Create a field. New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype); return Var_Type'(Kind => Var_Scope, I_Field => Field, I_Scope => Inst_Build.Scope); end case; end Create_Var; -- Get a reference to scope STYPE. If IS_PTR is set, RES is an access -- to the scope, otherwise RES directly designates the scope. procedure Find_Scope (Scope : Var_Scope_Type; Res : out O_Lnode; Is_Ptr : out Boolean) is begin case Scope.Kind is when Var_Scope_None => raise Internal_Error; when Var_Scope_Ptr | Var_Scope_Decl => Res := New_Obj (Scope.D); Is_Ptr := Scope.Kind = Var_Scope_Ptr; when Var_Scope_Field | Var_Scope_Field_Ptr => declare Parent : O_Lnode; Parent_Ptr : Boolean; begin Find_Scope (Scope.Up_Link.all, Parent, Parent_Ptr); if Parent_Ptr then Parent := New_Acc_Value (Parent); end if; Res := New_Selected_Element (Parent, Scope.Field); Is_Ptr := Scope.Kind = Var_Scope_Field_Ptr; end; end case; end Find_Scope; procedure Check_Not_Building is begin -- Variables cannot be referenced if there is an instance being -- built. if Inst_Build /= null and then Inst_Build.Kind = Instance then raise Internal_Error; end if; end Check_Not_Building; function Get_Instance_Access (Block : Iir) return O_Enode is Info : constant Block_Info_Acc := Get_Info (Block); Res : O_Lnode; Is_Ptr : Boolean; begin Check_Not_Building; Find_Scope (Info.Block_Scope, Res, Is_Ptr); if Is_Ptr then return New_Value (Res); else return New_Address (Res, Info.Block_Decls_Ptr_Type); end if; end Get_Instance_Access; function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode is Res : O_Lnode; Is_Ptr : Boolean; begin Check_Not_Building; Find_Scope (Scope, Res, Is_Ptr); if Is_Ptr then return New_Acc_Value (Res); else return Res; end if; end Get_Instance_Ref; function Get_Var (Var : Var_Type) return O_Lnode is begin case Var.Kind is when Var_None => raise Internal_Error; when Var_Local | Var_Global => return New_Obj (Var.E); when Var_Scope => return New_Selected_Element (Get_Instance_Ref (Var.I_Scope.all), Var.I_Field); end case; end Get_Var; function Get_Alloc_Kind_For_Var (Var : Var_Type) return Allocation_Kind is begin case Var.Kind is when Var_Local => return Alloc_Stack; when Var_Global | Var_Scope => return Alloc_System; when Var_None => raise Internal_Error; end case; end Get_Alloc_Kind_For_Var; function Is_Var_Stable (Var : Var_Type) return Boolean is begin case Var.Kind is when Var_Local | Var_Global => return True; when Var_Scope => return False; when Var_None => raise Internal_Error; end case; end Is_Var_Stable; function Is_Var_Field (Var : Var_Type) return Boolean is begin case Var.Kind is when Var_Local | Var_Global => return False; when Var_Scope => return True; when Var_None => raise Internal_Error; end case; end Is_Var_Field; function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode is begin return New_Offsetof (Get_Scope_Type (Var.I_Scope.all), Var.I_Field, Otype); end Get_Var_Offset; function Get_Var_Label (Var : Var_Type) return O_Dnode is begin case Var.Kind is when Var_Local | Var_Global => return Var.E; when Var_Scope | Var_None => raise Internal_Error; end case; end Get_Var_Label; procedure Save_Local_Identifier (Id : out Local_Identifier_Type) is begin Id := Identifier_Local; end Save_Local_Identifier; procedure Restore_Local_Identifier (Id : Local_Identifier_Type) is begin if Identifier_Local > Id then -- If the value is restored with a smaller value, some identifiers -- will be reused. This is certainly an internal error. raise Internal_Error; end if; Identifier_Local := Id; end Restore_Local_Identifier; -- Reset the identifier. procedure Reset_Identifier_Prefix is begin if Identifier_Len /= 0 or else Identifier_Local /= 0 then raise Internal_Error; end if; end Reset_Identifier_Prefix; procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type) is begin Identifier_Len := Mark.Len; Identifier_Local := Mark.Local_Id; end Pop_Identifier_Prefix; procedure Add_String (Len : in out Natural; Str : String) is begin Identifier_Buffer (Len + 1 .. Len + Str'Length) := Str; Len := Len + Str'Length; end Add_String; procedure Add_Nat (Len : in out Natural; Val : Natural) is Num : String (1 .. 10); V : Natural; P : Natural; begin P := Num'Last; V := Val; loop Num (P) := Character'Val (Character'Pos ('0') + V mod 10); V := V / 10; exit when V = 0; P := P - 1; end loop; Add_String (Len, Num (P .. Num'Last)); end Add_Nat; -- Convert name_id NAME to a string stored to -- NAME_BUFFER (1 .. NAME_LENGTH). -- -- This encodes extended identifiers. -- -- Extended identifier encoding: -- They start with 'X'. -- Non extended character [0-9a-zA-Z] are left as is, -- others are encoded to _XX, where XX is the character position in hex. -- They finish with "__". procedure Name_Id_To_String (Name : Name_Id) is use Name_Table; type Bool_Array_Type is array (Character) of Boolean; pragma Pack (Bool_Array_Type); Is_Extended_Char : constant Bool_Array_Type := ('0' .. '9' | 'A' .. 'Z' | 'a' .. 'z' => False, others => True); N_Len : Natural; P : Natural; C : Character; begin if Is_Character (Name) then P := Character'Pos (Name_Table.Get_Character (Name)); Name_Buffer (1) := 'C'; Name_Buffer (2) := N2hex (P / 16); Name_Buffer (3) := N2hex (P mod 16); Name_Length := 3; return; else Image (Name); end if; if Name_Buffer (1) /= '\' then return; end if; -- Extended identifier. -- Supress trailing backslash. Name_Length := Name_Length - 1; -- Count number of characters in the extended string. N_Len := Name_Length; for I in 2 .. Name_Length loop if Is_Extended_Char (Name_Buffer (I)) then N_Len := N_Len + 2; end if; end loop; -- Convert. Name_Buffer (1) := 'X'; P := N_Len; for J in reverse 2 .. Name_Length loop C := Name_Buffer (J); if Is_Extended_Char (C) then Name_Buffer (P - 0) := N2hex (Character'Pos (C) mod 16); Name_Buffer (P - 1) := N2hex (Character'Pos (C) / 16); Name_Buffer (P - 2) := '_'; P := P - 3; else Name_Buffer (P) := C; P := P - 1; end if; end loop; Name_Buffer (N_Len + 1) := '_'; Name_Buffer (N_Len + 2) := '_'; Name_Length := N_Len + 2; end Name_Id_To_String; procedure Add_Name (Len : in out Natural; Name : Name_Id) is use Name_Table; begin Name_Id_To_String (Name); Add_String (Len, Name_Buffer (1 .. Name_Length)); end Add_Name; procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; Name : String; Val : Iir_Int32 := 0) is P : Natural; begin Mark.Len := Identifier_Len; Mark.Local_Id := Identifier_Local; Identifier_Local := 0; P := Identifier_Len; Add_String (P, Name); if Val > 0 then Add_String (P, "O"); Add_Nat (P, Natural (Val)); end if; Add_String (P, "__"); Identifier_Len := P; end Push_Identifier_Prefix; -- Add a suffix to the prefix (!!!). procedure Push_Identifier_Prefix (Mark : out Id_Mark_Type; Name : Name_Id; Val : Iir_Int32 := 0) is use Name_Table; begin Name_Id_To_String (Name); Push_Identifier_Prefix (Mark, Name_Buffer (1 .. Name_Length), Val); end Push_Identifier_Prefix; procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type) is Str : String := Local_Identifier_Type'Image (Identifier_Local); begin Identifier_Local := Identifier_Local + 1; Str (1) := 'U'; Push_Identifier_Prefix (Mark, Str, 0); end Push_Identifier_Prefix_Uniq; procedure Add_Identifier (Len : in out Natural; Id : Name_Id) is begin if Id /= Null_Identifier then Add_Name (Len, Id); end if; end Add_Identifier; -- Create an identifier from IIR node ID without the prefix. function Create_Identifier_Without_Prefix (Id : Iir) return O_Ident is use Name_Table; begin Name_Id_To_String (Get_Identifier (Id)); return Get_Identifier (Name_Buffer (1 .. Name_Length)); end Create_Identifier_Without_Prefix; function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) return O_Ident is use Name_Table; begin Name_Id_To_String (Id); Name_Buffer (Name_Length + 1 .. Name_Length + Str'Length) := Str; return Get_Identifier (Name_Buffer (1 .. Name_Length + Str'Length)); end Create_Identifier_Without_Prefix; -- Create an identifier from IIR node ID with prefix. function Create_Id (Id : Name_Id; Str : String; Is_Local : Boolean) return O_Ident is L : Natural; begin L := Identifier_Len; Add_Identifier (L, Id); Add_String (L, Str); --Identifier_Buffer (L + Str'Length + 1) := Nul; if Is_Local then return Get_Identifier (Identifier_Buffer (Identifier_Start .. L)); else return Get_Identifier (Identifier_Buffer (1 .. L)); end if; end Create_Id; function Create_Identifier (Id : Name_Id; Str : String := "") return O_Ident is begin return Create_Id (Id, Str, False); end Create_Identifier; function Create_Identifier (Id : Iir; Str : String := "") return O_Ident is begin return Create_Id (Get_Identifier (Id), Str, False); end Create_Identifier; function Create_Identifier (Id : Iir; Val : Iir_Int32; Str : String := "") return O_Ident is Len : Natural; begin Len := Identifier_Len; Add_Identifier (Len, Get_Identifier (Id)); if Val > 0 then Add_String (Len, "O"); Add_Nat (Len, Natural (Val)); end if; Add_String (Len, Str); return Get_Identifier (Identifier_Buffer (1 .. Len)); end Create_Identifier; function Create_Identifier (Str : String) return O_Ident is Len : Natural; begin Len := Identifier_Len; Add_String (Len, Str); return Get_Identifier (Identifier_Buffer (1 .. Len)); end Create_Identifier; function Create_Identifier return O_Ident is begin return Get_Identifier (Identifier_Buffer (1 .. Identifier_Len - 2)); end Create_Identifier; function Create_Var_Identifier_From_Buffer (L : Natural) return Var_Ident_Type is Start : Natural; begin if Is_Local_Scope then Start := Identifier_Start; else Start := 1; end if; return (Id => Get_Identifier (Identifier_Buffer (Start .. L))); end Create_Var_Identifier_From_Buffer; function Create_Var_Identifier (Id : Iir) return Var_Ident_Type is L : Natural := Identifier_Len; begin Add_Identifier (L, Get_Identifier (Id)); return Create_Var_Identifier_From_Buffer (L); end Create_Var_Identifier; function Create_Var_Identifier (Id : String) return Var_Ident_Type is L : Natural := Identifier_Len; begin Add_String (L, Id); return Create_Var_Identifier_From_Buffer (L); end Create_Var_Identifier; function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural) return Var_Ident_Type is L : Natural := Identifier_Len; begin Add_Identifier (L, Get_Identifier (Id)); Add_String (L, Str); if Val > 0 then Add_String (L, "O"); Add_Nat (L, Val); end if; return Create_Var_Identifier_From_Buffer (L); end Create_Var_Identifier; function Create_Uniq_Identifier return Var_Ident_Type is Res : Var_Ident_Type; begin Res.Id := Create_Uniq_Identifier; return Res; end Create_Uniq_Identifier; type Instantiate_Var_Stack; type Instantiate_Var_Stack_Acc is access Instantiate_Var_Stack; type Instantiate_Var_Stack is record Orig_Scope : Var_Scope_Acc; Inst_Scope : Var_Scope_Acc; Prev : Instantiate_Var_Stack_Acc; end record; Top_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; Free_Instantiate_Var_Stack : Instantiate_Var_Stack_Acc := null; procedure Push_Instantiate_Var_Scope (Inst_Scope : Var_Scope_Acc; Orig_Scope : Var_Scope_Acc) is Inst : Instantiate_Var_Stack_Acc; begin if Free_Instantiate_Var_Stack = null then Inst := new Instantiate_Var_Stack; else Inst := Free_Instantiate_Var_Stack; Free_Instantiate_Var_Stack := Inst.Prev; end if; Inst.all := (Orig_Scope => Orig_Scope, Inst_Scope => Inst_Scope, Prev => Top_Instantiate_Var_Stack); Top_Instantiate_Var_Stack := Inst; end Push_Instantiate_Var_Scope; procedure Pop_Instantiate_Var_Scope (Inst_Scope : Var_Scope_Acc) is Item : constant Instantiate_Var_Stack_Acc := Top_Instantiate_Var_Stack; begin pragma Assert (Item /= null); pragma Assert (Item.Inst_Scope = Inst_Scope); Top_Instantiate_Var_Stack := Item.Prev; Item.all := (Orig_Scope => null, Inst_Scope => null, Prev => Free_Instantiate_Var_Stack); Free_Instantiate_Var_Stack := Item; end Pop_Instantiate_Var_Scope; function Instantiated_Var_Scope (Scope : Var_Scope_Acc) return Var_Scope_Acc is Item : Instantiate_Var_Stack_Acc; begin if Scope = null then return null; end if; Item := Top_Instantiate_Var_Stack; loop pragma Assert (Item /= null); if Item.Orig_Scope = Scope then return Item.Inst_Scope; end if; Item := Item.Prev; end loop; end Instantiated_Var_Scope; function Instantiate_Var (Var : Var_Type) return Var_Type is begin case Var.Kind is when Var_None | Var_Global | Var_Local => return Var; when Var_Scope => return Var_Type' (Kind => Var_Scope, I_Field => Var.I_Field, I_Scope => Instantiated_Var_Scope (Var.I_Scope)); end case; end Instantiate_Var; function Instantiate_Var_Scope (Scope : Var_Scope_Type) return Var_Scope_Type is begin case Scope.Kind is when Var_Scope_None | Var_Scope_Ptr | Var_Scope_Decl => return Scope; when Var_Scope_Field => return Var_Scope_Type' (Kind => Var_Scope_Field, Scope_Type => Scope.Scope_Type, Field => Scope.Field, Up_Link => Instantiated_Var_Scope (Scope.Up_Link)); when Var_Scope_Field_Ptr => return Var_Scope_Type' (Kind => Var_Scope_Field_Ptr, Scope_Type => Scope.Scope_Type, Field => Scope.Field, Up_Link => Instantiated_Var_Scope (Scope.Up_Link)); end case; end Instantiate_Var_Scope; end Chap10; function Get_Object_Kind (M : Mnode) return Object_Kind_Type is begin return M.M1.K; end Get_Object_Kind; function Get_Var (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) return Mnode is L : O_Lnode; D : O_Dnode; Stable : Boolean; begin -- FIXME: there may be Vv2M and Vp2M. Stable := Is_Var_Stable (Var); if Stable then D := Get_Var_Label (Var); else L := Get_Var (Var); end if; case Vtype.Type_Mode is when Type_Mode_Scalar | Type_Mode_Acc | Type_Mode_File | Type_Mode_Fat_Array | Type_Mode_Fat_Acc => if Stable then return Dv2M (D, Vtype, Mode); else return Lv2M (L, Vtype, Mode); end if; when Type_Mode_Array | Type_Mode_Record | Type_Mode_Protected => if Is_Complex_Type (Vtype) then if Stable then return Dp2M (D, Vtype, Mode); else return Lp2M (L, Vtype, Mode); end if; else if Stable then return Dv2M (D, Vtype, Mode); else return Lv2M (L, Vtype, Mode); end if; end if; when Type_Mode_Unknown => raise Internal_Error; end case; end Get_Var; function Stabilize (M : Mnode; Can_Copy : Boolean := False) return Mnode is K : constant Object_Kind_Type := M.M1.K; D : O_Dnode; begin case M.M1.State is when Mstate_E => if Is_Composite (M.M1.T) then -- Create a pointer variable. D := Create_Temp_Init (M.M1.Ptype, M.M1.E); return Mnode'(M1 => (State => Mstate_Dp, K => K, T => M.M1.T, Dp => D, Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); else -- Create a scalar variable. D := Create_Temp_Init (M.M1.Vtype, M.M1.E); return Mnode'(M1 => (State => Mstate_Dv, K => K, T => M.M1.T, Dv => D, Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); end if; when Mstate_Lp => D := Create_Temp_Init (M.M1.Ptype, New_Value (M.M1.Lp)); return Mnode'(M1 => (State => Mstate_Dp, K => K, T => M.M1.T, Dp => D, Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); when Mstate_Lv => if M.M1.Ptype = O_Tnode_Null then if not Can_Copy then raise Internal_Error; end if; D := Create_Temp_Init (M.M1.Vtype, New_Value (M.M1.Lv)); return Mnode'(M1 => (State => Mstate_Dv, K => K, T => M.M1.T, Dv => D, Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); else D := Create_Temp_Ptr (M.M1.Ptype, M.M1.Lv); return Mnode'(M1 => (State => Mstate_Dp, K => K, T => M.M1.T, Dp => D, Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); end if; when Mstate_Dp | Mstate_Dv => return M; when Mstate_Bad | Mstate_Null => raise Internal_Error; end case; end Stabilize; procedure Stabilize (M : in out Mnode) is begin M := Stabilize (M); end Stabilize; function Stabilize_Value (M : Mnode) return Mnode is D : O_Dnode; E : O_Enode; begin -- M must be scalar or access. pragma Assert (not Is_Composite (M.M1.T)); case M.M1.State is when Mstate_E => E := M.M1.E; when Mstate_Lp => E := New_Value (New_Acc_Value (M.M1.Lp)); when Mstate_Lv => E := New_Value (M.M1.Lv); when Mstate_Dp | Mstate_Dv => return M; when Mstate_Bad | Mstate_Null => raise Internal_Error; end case; D := Create_Temp_Init (M.M1.Vtype, E); return Mnode'(M1 => (State => Mstate_Dv, K => M.M1.K, T => M.M1.T, Dv => D, Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); end Stabilize_Value; function Create_Temp (Info : Type_Info_Acc; Kind : Object_Kind_Type := Mode_Value) return Mnode is begin if Is_Complex_Type (Info) and then Info.Type_Mode /= Type_Mode_Fat_Array then -- For a complex and constrained object, we just allocate -- a pointer to the object. return Dp2M (Create_Temp (Info.Ortho_Ptr_Type (Kind)), Info, Kind); else return Dv2M (Create_Temp (Info.Ortho_Type (Kind)), Info, Kind); end if; end Create_Temp; function New_Value_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) return O_Enode is begin return New_Value (New_Selected_Element (New_Access_Element (New_Value (L)), Field)); end New_Value_Selected_Acc_Value; function New_Selected_Acc_Value (L : O_Lnode; Field : O_Fnode) return O_Lnode is begin return New_Selected_Element (New_Access_Element (New_Value (L)), Field); end New_Selected_Acc_Value; function New_Indexed_Acc_Value (L : O_Lnode; I : O_Enode) return O_Lnode is begin return New_Indexed_Element (New_Access_Element (New_Value (L)), I); end New_Indexed_Acc_Value; function New_Acc_Value (L : O_Lnode) return O_Lnode is begin return New_Access_Element (New_Value (L)); end New_Acc_Value; package Node_Infos is new GNAT.Table (Table_Component_Type => Ortho_Info_Acc, Table_Index_Type => Iir, Table_Low_Bound => 0, Table_Initial => 1024, Table_Increment => 100); procedure Init_Node_Infos is begin -- Create the node extension for translate. Node_Infos.Init; Node_Infos.Set_Last (4); Node_Infos.Table (0 .. 4) := (others => null); end Init_Node_Infos; procedure Update_Node_Infos is use Nodes; F, L : Iir; begin F := Node_Infos.Last; L := Nodes.Get_Last_Node; Node_Infos.Set_Last (L); Node_Infos.Table (F + 1 .. L) := (others => null); end Update_Node_Infos; procedure Set_Info (Target : Iir; Info : Ortho_Info_Acc) is begin if Node_Infos.Table (Target) /= null then raise Internal_Error; end if; Node_Infos.Table (Target) := Info; end Set_Info; procedure Clear_Info (Target : Iir) is begin Node_Infos.Table (Target) := null; end Clear_Info; function Get_Info (Target : Iir) return Ortho_Info_Acc is begin return Node_Infos.Table (Target); end Get_Info; -- Create an ortho_info field of kind KIND for iir node TARGET, and -- return it. function Add_Info (Target : Iir; Kind : Ortho_Info_Kind) return Ortho_Info_Acc is Res : Ortho_Info_Acc; begin Res := new Ortho_Info_Type (Kind); Set_Info (Target, Res); return Res; end Add_Info; procedure Free_Info (Target : Iir) is Info : Ortho_Info_Acc; begin Info := Get_Info (Target); if Info /= null then Unchecked_Deallocation (Info); Clear_Info (Target); end if; end Free_Info; procedure Free_Type_Info (Info : in out Type_Info_Acc) is begin if Info.C /= null then Free_Complex_Type_Info (Info.C); end if; Unchecked_Deallocation (Info); end Free_Type_Info; procedure Set_Ortho_Expr (Target : Iir; Expr : O_Cnode) is Info : Ortho_Info_Acc; begin Info := Add_Info (Target, Kind_Expr); Info.Expr_Node := Expr; end Set_Ortho_Expr; function Get_Ortho_Expr (Target : Iir) return O_Cnode is begin return Get_Info (Target).Expr_Node; end Get_Ortho_Expr; function Get_Ortho_Type (Target : Iir; Is_Sig : Object_Kind_Type) return O_Tnode is begin return Get_Info (Target).Ortho_Type (Is_Sig); end Get_Ortho_Type; function Is_Composite (Info : Type_Info_Acc) return Boolean is begin return Info.Type_Mode in Type_Mode_Fat; end Is_Composite; function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is begin return Tinfo.C /= null; end Is_Complex_Type; procedure Free_Node_Infos is Info : Ortho_Info_Acc; Prev_Info : Ortho_Info_Acc; begin Prev_Info := null; for I in Node_Infos.First .. Node_Infos.Last loop Info := Get_Info (I); if Info /= null and then Info /= Prev_Info then case Get_Kind (I) is when Iir_Kind_Constant_Declaration => if Get_Deferred_Declaration_Flag (I) = False and then Get_Deferred_Declaration (I) /= Null_Iir then -- Info are copied from incomplete constant declaration -- to full constant declaration. Clear_Info (I); else Free_Info (I); end if; when Iir_Kind_Record_Subtype_Definition | Iir_Kind_Access_Subtype_Definition => null; when Iir_Kind_Enumeration_Type_Definition | Iir_Kind_Array_Type_Definition | Iir_Kind_Integer_Subtype_Definition | Iir_Kind_Floating_Subtype_Definition | Iir_Kind_Physical_Subtype_Definition | Iir_Kind_Enumeration_Subtype_Definition => Free_Type_Info (Info); when Iir_Kind_Array_Subtype_Definition => if Get_Index_Constraint_Flag (I) then Info.T := Ortho_Info_Type_Array_Init; Free_Type_Info (Info); end if; when Iir_Kind_Implicit_Function_Declaration => case Get_Implicit_Definition (I) is when Iir_Predefined_Bit_Array_Match_Equality | Iir_Predefined_Bit_Array_Match_Inequality => -- Not in sequence. null; when others => -- By default, info are not shared. -- The exception is infos for implicit subprograms, -- but they are always consecutive and not free twice -- due to prev_info mechanism. Free_Info (I); end case; when others => -- By default, info are not shared. Free_Info (I); end case; Prev_Info := Info; end if; end loop; Node_Infos.Free; end Free_Node_Infos; function Get_Type_Info (M : Mnode) return Type_Info_Acc is begin return M.M1.T; end Get_Type_Info; function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type) return Mnode is begin return Mnode'(M1 => (State => Mstate_E, K => Kind, T => T, E => E, Vtype => T.Ortho_Type (Kind), Ptype => T.Ortho_Ptr_Type (Kind))); end E2M; function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) return Mnode is begin return Mnode'(M1 => (State => Mstate_Lv, K => Kind, T => T, Lv => L, Vtype => T.Ortho_Type (Kind), Ptype => T.Ortho_Ptr_Type (Kind))); end Lv2M; function Lv2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) return Mnode is begin return Mnode'(M1 => (State => Mstate_Lv, K => Kind, T => T, Lv => L, Vtype => Vtype, Ptype => Ptype)); end Lv2M; function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type) return Mnode is begin return Mnode'(M1 => (State => Mstate_Lp, K => Kind, T => T, Lp => L, Vtype => T.Ortho_Type (Kind), Ptype => T.Ortho_Ptr_Type (Kind))); end Lp2M; function Lp2M (L : O_Lnode; T : Type_Info_Acc; Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) return Mnode is begin return Mnode'(M1 => (State => Mstate_Lp, K => Kind, T => T, Lp => L, Vtype => Vtype, Ptype => Ptype)); end Lp2M; function Dv2M (D : O_Dnode; T : Type_Info_Acc; Kind : Object_Kind_Type) return Mnode is begin return Mnode'(M1 => (State => Mstate_Dv, K => Kind, T => T, Dv => D, Vtype => T.Ortho_Type (Kind), Ptype => T.Ortho_Ptr_Type (Kind))); end Dv2M; function Dv2M (D : O_Dnode; T : Type_Info_Acc; Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) return Mnode is begin return Mnode'(M1 => (State => Mstate_Dv, K => Kind, T => T, Dv => D, Vtype => Vtype, Ptype => Ptype)); end Dv2M; function Dp2M (D : O_Dnode; T : Type_Info_Acc; Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) return Mnode is begin return Mnode'(M1 => (State => Mstate_Dp, K => Kind, T => T, Dp => D, Vtype => Vtype, Ptype => Ptype)); end Dp2M; function Dp2M (D : O_Dnode; T : Type_Info_Acc; Kind : Object_Kind_Type) return Mnode is begin return Mnode'(M1 => (State => Mstate_Dp, K => Kind, T => T, Dp => D, Vtype => T.Ortho_Type (Kind), Ptype => T.Ortho_Ptr_Type (Kind))); end Dp2M; function M2Lv (M : Mnode) return O_Lnode is begin case M.M1.State is when Mstate_E => case Get_Type_Info (M).Type_Mode is when Type_Mode_Thin => -- Scalar to var is not possible. -- FIXME: This is not coherent with the fact that this -- conversion is possible when M is stabilized. raise Internal_Error; when Type_Mode_Fat => return New_Access_Element (M.M1.E); when Type_Mode_Unknown => raise Internal_Error; end case; when Mstate_Lp => return New_Acc_Value (M.M1.Lp); when Mstate_Lv => return M.M1.Lv; when Mstate_Dp => return New_Acc_Value (New_Obj (M.M1.Dp)); when Mstate_Dv => return New_Obj (M.M1.Dv); when Mstate_Null | Mstate_Bad => raise Internal_Error; end case; end M2Lv; function M2Lp (M : Mnode) return O_Lnode is begin case M.M1.State is when Mstate_E => raise Internal_Error; when Mstate_Lp => return M.M1.Lp; when Mstate_Dp => return New_Obj (M.M1.Dp); when Mstate_Lv => if Get_Type_Info (M).Type_Mode in Type_Mode_Fat then return New_Obj (Create_Temp_Init (M.M1.Ptype, New_Address (M.M1.Lv, M.M1.Ptype))); else raise Internal_Error; end if; when Mstate_Dv | Mstate_Null | Mstate_Bad => raise Internal_Error; end case; end M2Lp; function M2Dp (M : Mnode) return O_Dnode is begin case M.M1.State is when Mstate_Dp => return M.M1.Dp; when Mstate_Dv => return Create_Temp_Init (M.M1.Ptype, New_Address (New_Obj (M.M1.Dv), M.M1.Ptype)); when others => raise Internal_Error; end case; end M2Dp; function M2Dv (M : Mnode) return O_Dnode is begin case M.M1.State is when Mstate_Dv => return M.M1.Dv; when others => raise Internal_Error; end case; end M2Dv; function T2M (Atype : Iir; Kind : Object_Kind_Type) return Mnode is T : Type_Info_Acc; begin T := Get_Info (Atype); return Mnode'(M1 => (State => Mstate_Null, K => Kind, T => T, Vtype => T.Ortho_Type (Kind), Ptype => T.Ortho_Ptr_Type (Kind))); end T2M; function M2E (M : Mnode) return O_Enode is begin case M.M1.State is when Mstate_E => return M.M1.E; when Mstate_Lp => case M.M1.T.Type_Mode is when Type_Mode_Unknown => raise Internal_Error; when Type_Mode_Thin => return New_Value (New_Acc_Value (M.M1.Lp)); when Type_Mode_Fat => return New_Value (M.M1.Lp); end case; when Mstate_Dp => case M.M1.T.Type_Mode is when Type_Mode_Unknown => raise Internal_Error; when Type_Mode_Thin => return New_Value (New_Acc_Value (New_Obj (M.M1.Dp))); when Type_Mode_Fat => return New_Value (New_Obj (M.M1.Dp)); end case; when Mstate_Lv => case M.M1.T.Type_Mode is when Type_Mode_Unknown => raise Internal_Error; when Type_Mode_Thin => return New_Value (M.M1.Lv); when Type_Mode_Fat => return New_Address (M.M1.Lv, M.M1.Ptype); end case; when Mstate_Dv => case M.M1.T.Type_Mode is when Type_Mode_Unknown => raise Internal_Error; when Type_Mode_Thin => return New_Value (New_Obj (M.M1.Dv)); when Type_Mode_Fat => return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); end case; when Mstate_Bad | Mstate_Null => raise Internal_Error; end case; end M2E; function M2Addr (M : Mnode) return O_Enode is begin case M.M1.State is when Mstate_Lp => return New_Value (M.M1.Lp); when Mstate_Dp => return New_Value (New_Obj (M.M1.Dp)); when Mstate_Lv => return New_Address (M.M1.Lv, M.M1.Ptype); when Mstate_Dv => return New_Address (New_Obj (M.M1.Dv), M.M1.Ptype); when Mstate_E => -- For scalar, M contains the value so there is no lvalue from -- which the address can be taken. pragma Assert (Is_Composite (M.M1.T)); return M.M1.E; when Mstate_Bad | Mstate_Null => raise Internal_Error; end case; end M2Addr; -- function Is_Null (M : Mnode) return Boolean is -- begin -- return M.M1.State = Mstate_Null; -- end Is_Null; function Is_Stable (M : Mnode) return Boolean is begin case M.M1.State is when Mstate_Dp | Mstate_Dv => return True; when others => return False; end case; end Is_Stable; -- function Varv2M -- (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) -- return Mnode is -- begin -- return Lv2M (Get_Var (Var), Vtype, Mode); -- end Varv2M; function Varv2M (Var : Var_Type; Var_Type : Type_Info_Acc; Mode : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) return Mnode is begin return Lv2M (Get_Var (Var), Var_Type, Mode, Vtype, Ptype); end Varv2M; -- Convert a Lnode for a sub object to an MNODE. function Lo2M (L : O_Lnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) return Mnode is begin case Vtype.Type_Mode is when Type_Mode_Scalar | Type_Mode_Acc | Type_Mode_File | Type_Mode_Fat_Array | Type_Mode_Fat_Acc => return Lv2M (L, Vtype, Mode); when Type_Mode_Array | Type_Mode_Record | Type_Mode_Protected => if Is_Complex_Type (Vtype) then return Lp2M (L, Vtype, Mode); else return Lv2M (L, Vtype, Mode); end if; when Type_Mode_Unknown => raise Internal_Error; end case; end Lo2M; function Lo2M (D : O_Dnode; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) return Mnode is begin case Vtype.Type_Mode is when Type_Mode_Scalar | Type_Mode_Acc | Type_Mode_File | Type_Mode_Fat_Array | Type_Mode_Fat_Acc => return Dv2M (D, Vtype, Mode); when Type_Mode_Array | Type_Mode_Record | Type_Mode_Protected => if Is_Complex_Type (Vtype) then return Dp2M (D, Vtype, Mode); else return Dv2M (D, Vtype, Mode); end if; when Type_Mode_Unknown => raise Internal_Error; end case; end Lo2M; package body Helpers is procedure Inc_Var (V : O_Dnode) is begin New_Assign_Stmt (New_Obj (V), New_Dyadic_Op (ON_Add_Ov, New_Obj_Value (V), New_Lit (Ghdl_Index_1))); end Inc_Var; procedure Dec_Var (V : O_Dnode) is begin New_Assign_Stmt (New_Obj (V), New_Dyadic_Op (ON_Sub_Ov, New_Obj_Value (V), New_Lit (Ghdl_Index_1))); end Dec_Var; procedure Init_Var (V : O_Dnode) is begin New_Assign_Stmt (New_Obj (V), New_Lit (Ghdl_Index_0)); end Init_Var; procedure Gen_Exit_When (Label : O_Snode; Cond : O_Enode) is If_Blk : O_If_Block; begin Start_If_Stmt (If_Blk, Cond); New_Exit_Stmt (Label); Finish_If_Stmt (If_Blk); end Gen_Exit_When; -- Create a temporary variable. type Temp_Level_Type; type Temp_Level_Acc is access Temp_Level_Type; type Temp_Level_Type is record Prev : Temp_Level_Acc; Level : Natural; Id : Natural; Emitted : Boolean; Stack2_Mark : O_Dnode; Transient_Types : Iir; end record; -- Current level. Temp_Level : Temp_Level_Acc := null; -- List of unused temp_level_type structures. To be faster, they are -- never deallocated. Old_Level : Temp_Level_Acc := null; -- If set, emit comments for open_temp/close_temp. Flag_Debug_Temp : constant Boolean := False; procedure Open_Temp is L : Temp_Level_Acc; begin if Old_Level /= null then L := Old_Level; Old_Level := L.Prev; else L := new Temp_Level_Type; end if; L.all := (Prev => Temp_Level, Level => 0, Id => 0, Emitted => False, Stack2_Mark => O_Dnode_Null, Transient_Types => Null_Iir); if Temp_Level /= null then L.Level := Temp_Level.Level + 1; end if; Temp_Level := L; if Flag_Debug_Temp then New_Debug_Comment_Stmt ("Open_Temp level " & Natural'Image (L.Level)); end if; end Open_Temp; procedure Open_Local_Temp is begin Open_Temp; Temp_Level.Emitted := True; end Open_Local_Temp; procedure Add_Transient_Type_In_Temp (Atype : Iir) is Type_Info : Type_Info_Acc; begin Type_Info := Get_Info (Atype); Type_Info.Type_Transient_Chain := Temp_Level.Transient_Types; Temp_Level.Transient_Types := Atype; end Add_Transient_Type_In_Temp; -- Some expressions may be evaluated several times in different -- contexts. Type info created for these expressions may not be -- shared between these contexts. procedure Destroy_Type_Info (Atype : Iir) is Type_Info : Type_Info_Acc; begin Type_Info := Get_Info (Atype); Free_Type_Info (Type_Info); Clear_Info (Atype); end Destroy_Type_Info; procedure Release_Transient_Types (Chain : in out Iir) is N_Atype : Iir; begin while Chain /= Null_Iir loop N_Atype := Get_Info (Chain).Type_Transient_Chain; Destroy_Type_Info (Chain); Chain := N_Atype; end loop; end Release_Transient_Types; procedure Destroy_Local_Transient_Types is begin Release_Transient_Types (Temp_Level.Transient_Types); end Destroy_Local_Transient_Types; function Has_Stack2_Mark return Boolean is begin return Temp_Level.Stack2_Mark /= O_Dnode_Null; end Has_Stack2_Mark; procedure Stack2_Release is Constr : O_Assoc_List; begin if Temp_Level.Stack2_Mark /= O_Dnode_Null then Start_Association (Constr, Ghdl_Stack2_Release); New_Association (Constr, New_Value (New_Obj (Temp_Level.Stack2_Mark))); New_Procedure_Call (Constr); Temp_Level.Stack2_Mark := O_Dnode_Null; end if; end Stack2_Release; procedure Close_Temp is L : Temp_Level_Acc; begin if Temp_Level = null then -- OPEN_TEMP was not called. raise Internal_Error; end if; if Flag_Debug_Temp then New_Debug_Comment_Stmt ("Close_Temp level " & Natural'Image (Temp_Level.Level)); end if; if Temp_Level.Stack2_Mark /= O_Dnode_Null then Stack2_Release; end if; if Temp_Level.Emitted then Finish_Declare_Stmt; end if; -- Destroy transcient types. Release_Transient_Types (Temp_Level.Transient_Types); -- Unlink temp_level. L := Temp_Level; Temp_Level := L.Prev; L.Prev := Old_Level; Old_Level := L; end Close_Temp; procedure Close_Local_Temp is begin Temp_Level.Emitted := False; Close_Temp; end Close_Local_Temp; procedure Free_Old_Temp is procedure Free is new Ada.Unchecked_Deallocation (Temp_Level_Type, Temp_Level_Acc); T : Temp_Level_Acc; begin if Temp_Level /= null then -- Missing Close_Temp. raise Internal_Error; end if; loop T := Old_Level; exit when T = null; Old_Level := Old_Level.Prev; Free (T); end loop; end Free_Old_Temp; procedure Create_Temp_Stack2_Mark is Constr : O_Assoc_List; begin if Temp_Level.Stack2_Mark /= O_Dnode_Null then -- Only the first mark in a region is registred. -- The release operation frees the memory allocated after the -- first mark. return; end if; Temp_Level.Stack2_Mark := Create_Temp (Ghdl_Ptr_Type); Start_Association (Constr, Ghdl_Stack2_Mark); New_Assign_Stmt (New_Obj (Temp_Level.Stack2_Mark), New_Function_Call (Constr)); end Create_Temp_Stack2_Mark; function Create_Temp (Atype : O_Tnode) return O_Dnode is Str : String (1 .. 12); Val : Natural; Res : O_Dnode; P : Natural; begin if Temp_Level = null then -- OPEN_TEMP was never called. raise Internal_Error; -- This is an hack, just to allow array subtype to array type -- conversion. --New_Var_Decl -- (Res, Create_Uniq_Identifier, O_Storage_Private, Atype); --return Res; else if not Temp_Level.Emitted then Temp_Level.Emitted := True; Start_Declare_Stmt; end if; end if; Val := Temp_Level.Id; Temp_Level.Id := Temp_Level.Id + 1; P := Str'Last; loop Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); Val := Val / 10; P := P - 1; exit when Val = 0; end loop; Str (P) := '_'; P := P - 1; Val := Temp_Level.Level; loop Str (P) := Character'Val (Val mod 10 + Character'Pos ('0')); Val := Val / 10; P := P - 1; exit when Val = 0; end loop; Str (P) := 'T'; --Str (12) := Nul; New_Var_Decl (Res, Get_Identifier (Str (P .. Str'Last)), O_Storage_Local, Atype); return Res; end Create_Temp; function Create_Temp_Init (Atype : O_Tnode; Value : O_Enode) return O_Dnode is Res : O_Dnode; begin Res := Create_Temp (Atype); New_Assign_Stmt (New_Obj (Res), Value); return Res; end Create_Temp_Init; function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) return O_Dnode is begin return Create_Temp_Init (Atype, New_Address (Name, Atype)); end Create_Temp_Ptr; -- Return a ghdl_index_type literal for NUM. function New_Index_Lit (Num : Unsigned_64) return O_Cnode is begin return New_Unsigned_Literal (Ghdl_Index_Type, Num); end New_Index_Lit; Uniq_Id : Natural := 0; function Create_Uniq_Identifier return Uniq_Identifier_String is Str : Uniq_Identifier_String; Val : Natural; begin Str (1 .. 3) := "_UI"; Val := Uniq_Id; Uniq_Id := Uniq_Id + 1; for I in reverse 4 .. 11 loop Str (I) := N2hex (Val mod 16); Val := Val / 16; end loop; return Str; end Create_Uniq_Identifier; function Create_Uniq_Identifier return O_Ident is begin return Get_Identifier (Create_Uniq_Identifier); end Create_Uniq_Identifier; end Helpers; end Trans;