-- Iir to ortho translator. -- Copyright (C) 2002-2014 Tristan Gingold -- -- This program 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 of the License, or -- (at your option) any later version. -- -- This program 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 this program. If not, see . with Name_Table; -- use Name_Table; with Vhdl.Nodes_Priv; with Tables; 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; Prev_Scope : out Var_Scope_Acc) is begin if Has_Current_Subprg_Instance then Field := Add_Instance_Factory_Field (Current_Subprg_Instance.Ident, Current_Subprg_Instance.Ptr_Type); Prev_Scope := Current_Subprg_Instance.Scope; else Field := O_Fnode_Null; Prev_Scope := 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) and then Field /= O_Fnode_Null 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_Scope : Var_Scope_Acc; 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_Scope : Var_Scope_Acc; 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 .. 4096); Identifier_Len : Natural := 0; Identifier_Start : Natural := 1; -- Per scope unique id. 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; pragma Assert (Old.Prev_Id_Start <= Identifier_Start); 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; -- Common routine for instance and frame. procedure Start_Instance_Factory (Inst : Inst_Build_Acc) is begin Inst.Prev := Inst_Build; Inst.Prev_Id_Start := Identifier_Start; Identifier_Start := Identifier_Len + 1; if Inst.Scope.Scope_Type /= O_Tnode_Null then Start_Uncomplete_Record_Type (Inst.Scope.Scope_Type, Inst.Elements); else Start_Record_Type (Inst.Elements); end if; Inst_Build := Inst; end Start_Instance_Factory; procedure Push_Instance_Factory (Scope : Var_Scope_Acc) is Inst : Inst_Build_Acc; begin Inst := new Inst_Build_Type (Instance); Inst.Scope := Scope; Start_Instance_Factory (Inst); end Push_Instance_Factory; procedure Push_Frame_Factory (Scope : Var_Scope_Acc; Persistant : Boolean) is Inst : Inst_Build_Acc; begin if Persistant then Inst := new Inst_Build_Type (Persistant_Frame); else Inst := new Inst_Build_Type (Stack_Frame); end if; Inst.Scope := Scope; Start_Instance_Factory (Inst); end Push_Frame_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_Field (Child : Var_Scope_Type) return O_Fnode is begin return Child.Field; end Get_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 Finish_Instance_Factory (Scope : in Var_Scope_Acc) is Res : O_Tnode; begin Finish_Record_Type (Inst_Build.Elements, Res); Pop_Build_Instance; Scope.Scope_Type := Res; end Finish_Instance_Factory; procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc) is begin -- Not matching. pragma Assert (Inst_Build.Kind = Instance); Finish_Instance_Factory (Scope); end Pop_Instance_Factory; procedure Pop_Frame_Factory (Scope : in Var_Scope_Acc) is begin -- Not matching. pragma Assert (Inst_Build.Kind in Stack_Frame .. Persistant_Frame); Finish_Instance_Factory (Scope); end Pop_Frame_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 | Stack_Frame | Persistant_Frame => 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 Create_Union_Scope (Scope : out Var_Scope_Type; Stype : O_Tnode) is begin pragma Assert (Scope.Scope_Type = O_Tnode_Null); pragma Assert (Scope.Kind = Var_Scope_None); Scope.Scope_Type := Stype; end Create_Union_Scope; 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 Set_Scope_Via_Var (Scope : in out Var_Scope_Type; Var : Var_Type) is begin pragma Assert (Scope.Kind = Var_Scope_None); case Var.Kind is when Var_Scope => Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_Field, Field => Var.I_Field, Up_Link => Var.I_Scope); when Var_Global | Var_Local => Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_Decl, D => Var.E); when Var_None => raise Internal_Error; end case; end Set_Scope_Via_Var; 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 Is_Null (Scope : Var_Scope_Type) return Boolean is begin return Scope.Kind = Var_Scope_None; end Is_Null; 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_Init_Value (Res); Finish_Init_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_Init_Value (Const.E); Finish_Init_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 | Stack_Frame | Persistant_Frame => -- Create a field. New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype); return Var_Type'(Kind => Var_Scope, I_Build_Kind => K, 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 => return Alloc_System; when Var_Scope => case Var.I_Build_Kind is when Stack_Frame => return Alloc_Stack; when Persistant_Frame => return Alloc_Return; when Instance => return Alloc_System; when others => raise Internal_Error; end case; 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_Field (Var : Var_Type) return O_Fnode is begin return Var.I_Field; end Get_Var_Field; 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 the value is restored with a smaller value, some identifiers -- will be reused. This is certainly an internal error. pragma Assert (Identifier_Local <= Id); Identifier_Local := Id; end Restore_Local_Identifier; -- Reset the identifier. procedure Reset_Identifier_Prefix is begin pragma Assert (Identifier_Len = 0 and Identifier_Local = 0); null; end Reset_Identifier_Prefix; procedure Pop_Identifier_Prefix (Mark : in Id_Mark_Type) is begin pragma Assert (Mark.Len <= Identifier_Len); 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; 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); -- 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 "__". function Name_Id_To_String (Name : Name_Id) return String is begin if Name_Table.Is_Character (Name) then declare P : constant Natural := Character'Pos (Name_Table.Get_Character (Name)); Res : String (1 .. 3); begin Res (1) := 'C'; Res (2) := N2hex (P / 16); Res (3) := N2hex (P mod 16); return Res; end; else declare Img : constant String := Name_Table.Image (Name); N_Len : Natural; begin if Img (Img'First) /= '\' then return Img; end if; -- Extended identifier. -- Count number of characters in the extended string. N_Len := 3; for I in Img'First + 1 .. Img'Last - 1 loop if Is_Extended_Char (Img (I)) then N_Len := N_Len + 3; else N_Len := N_Len + 1; end if; end loop; declare Img2 : String (1 .. N_Len); P : Natural; C : Character; begin -- Convert (without the trailing backslash). Img2 (1) := 'X'; P := 1; for I in Img'First + 1 .. Img'Last - 1 loop C := Img (I); if Is_Extended_Char (C) then Img2 (P + 1) := '_'; Img2 (P + 2) := N2hex (Character'Pos (C) / 16); Img2 (P + 3) := N2hex (Character'Pos (C) mod 16); P := P + 3; else Img2 (P + 1) := C; P := P + 1; end if; end loop; Img2 (P + 1) := '_'; Img2 (P + 2) := '_'; pragma Assert (N_Len = P + 2); return Img2; end; end; end if; end Name_Id_To_String; function Identifier_To_String (N : Iir) return String is begin return Name_Id_To_String (Get_Identifier (N)); end Identifier_To_String; procedure Add_Name (Len : in out Natural; Name : Name_Id) is begin Add_String (Len, Name_Id_To_String (Name)); 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 begin if Name = Null_Identifier then Push_Identifier_Prefix (Mark, "", Val); else Push_Identifier_Prefix (Mark, Name_Id_To_String (Name), Val); end if; end Push_Identifier_Prefix; procedure Push_Identifier_Prefix_Uniq (Mark : out Id_Mark_Type) is Str : String := Local_Identifier_Type'Image (Identifier_Local); begin -- Increment local identifier, as the value has been used. 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 begin return Get_Identifier (Name_Id_To_String (Get_Identifier (Id))); end Create_Identifier_Without_Prefix; function Create_Identifier_Without_Prefix (Id : Name_Id; Str : String) return O_Ident is begin if Str'Length = 0 then return Get_Identifier (Name_Id_To_String (Id)); else return Get_Identifier (Name_Id_To_String (Id) & Str); end if; end Create_Identifier_Without_Prefix; function Create_Identifier_Without_Prefix (Id : Iir; Str : String) return O_Ident is begin return Create_Identifier_Without_Prefix (Get_Identifier (Id), Str); 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_Elab_Identifier (Kind : Elab_Kind) return O_Ident is begin case Kind is when Elab_Decls => return Create_Identifier ("DECL_ELAB"); when Elab_Stmts => return Create_Identifier ("STMT_ELAB"); end case; end Create_Elab_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_Build_Kind => Var.I_Build_Kind, 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 Align_Val (Algn : Alignment_Type) return O_Cnode is begin case Algn is when Align_Undef => raise Internal_Error; when Align_8 => return Ghdl_Index_1; when Align_16 => return Ghdl_Index_2; when Align_32 => return Ghdl_Index_4; when Align_Ptr => return Ghdl_Index_Ptr_Align; when Align_64 => return Ghdl_Index_8; end case; end Align_Val; 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_Unbounded_Array | Type_Mode_Unbounded_Record | Type_Mode_Bounds_Acc => if Stable then return Dv2M (D, Vtype, Mode); else return Lv2M (L, Vtype, Mode); end if; when Type_Mode_Complex_Array | Type_Mode_Complex_Record | Type_Mode_Protected => if Stable then return Dp2M (D, Vtype, Mode); else return Lp2M (L, Vtype, Mode); end if; when Type_Mode_Static_Array | Type_Mode_Static_Record => if Stable then return Dv2M (D, Vtype, Mode); else return Lv2M (L, Vtype, Mode); end if; when Type_Mode_Unknown => raise Internal_Error; end case; end Get_Var; function Get_Varp (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) return Mnode is Stable : Boolean; begin -- FIXME: there may be Vv2M and Vp2M. Stable := Is_Var_Stable (Var); if Stable then return Dp2M (Get_Var_Label (Var), Vtype, Mode); else return Lp2M (Get_Var (Var), Vtype, Mode); end if; end Get_Varp; 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_Ep => -- Create a pointer variable. D := Create_Temp_Init (M.M1.Ptype, M.M1.Ep); return Mnode'(M1 => (State => Mstate_Dp, K => K, T => M.M1.T, Dp => D, Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); when Mstate_Ev => if not Can_Copy then raise Internal_Error; end if; -- Create a scalar variable. D := Create_Temp_Init (M.M1.Vtype, M.M1.Ev); return Mnode'(M1 => (State => Mstate_Dv, K => K, T => M.M1.T, Dv => D, Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); 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_Ev => E := M.M1.Ev; when Mstate_Ep => raise Internal_Error; 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 not in Type_Mode_Unbounded 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; function Add_Pointer (Ptr : O_Enode; Offset : O_Enode; Res_Ptr : O_Tnode) return O_Enode is begin return New_Unchecked_Address (New_Slice (New_Access_Element (New_Convert_Ov (Ptr, Char_Ptr_Type)), Chararray_Type, Offset), Res_Ptr); end Add_Pointer; package Node_Infos is new Tables (Table_Component_Type => Ortho_Info_Acc, Table_Index_Type => Iir, Table_Low_Bound => 0, Table_Initial => 1024); 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 Vhdl.Nodes_Priv; F, L : Iir; begin F := Node_Infos.Last; L := 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 pragma Assert (Node_Infos.Table (Target) = null); 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 pragma Assert (Target /= Null_Iir); 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 Unchecked_Deallocation (Info); end Free_Type_Info; function Get_Ortho_Literal (Target : Iir) return O_Cnode is begin return Get_Info (Target).Lit_Node; end Get_Ortho_Literal; 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_Composite; end Is_Composite; function Is_Complex_Type (Tinfo : Type_Info_Acc) return Boolean is begin case Tinfo.Type_Mode is when Type_Mode_Non_Composite => return False; when Type_Mode_Static_Record | Type_Mode_Static_Array => return False; when Type_Mode_Complex_Record | Type_Mode_Complex_Array => return True; when Type_Mode_Unbounded_Record | Type_Mode_Unbounded_Array => return False; when Type_Mode_Protected => -- Considered as a complex type, as its size is known only in -- the body. -- Shouldn't be used. raise Internal_Error; when Type_Mode_Unknown => return False; end case; end Is_Complex_Type; function Is_Static_Type (Tinfo : Type_Info_Acc) return Boolean is begin case Tinfo.Type_Mode is when Type_Mode_Non_Composite => return True; when Type_Mode_Static_Record | Type_Mode_Static_Array => return True; when Type_Mode_Complex_Record | Type_Mode_Complex_Array | Type_Mode_Unbounded_Record | Type_Mode_Unbounded_Array | Type_Mode_Protected => return False; when Type_Mode_Unknown => return False; end case; end Is_Static_Type; function Is_Unbounded_Type (Tinfo : Type_Info_Acc) return Boolean is begin return Tinfo.Type_Mode in Type_Mode_Unbounded; end Is_Unbounded_Type; procedure Free_Node_Infos is Info : Ortho_Info_Acc; begin -- Check each node is not marked. for I in Node_Infos.First .. Node_Infos.Last loop Info := Get_Info (I); pragma Assert (Info = null or else not Info.Mark); end loop; -- Clear duplicated nodes for I in Node_Infos.First .. Node_Infos.Last loop Info := Get_Info (I); if Info /= null then if Info.Mark then -- This info is shared by another node and was already seen. -- Unreference it. Clear_Info (I); else Info.Mark := True; end if; end if; end loop; -- Free infos for I in Node_Infos.First .. Node_Infos.Last loop Info := Get_Info (I); if Info /= null then if Info.Kind = Kind_Type then Free_Type_Info (Info); else Free_Info (I); end if; 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 if Is_Composite (T) then return Mnode'(M1 => (State => Mstate_Ep, K => Kind, T => T, Ep => E, Vtype => T.Ortho_Type (Kind), Ptype => T.Ortho_Ptr_Type (Kind))); else return Mnode'(M1 => (State => Mstate_Ev, K => Kind, T => T, Ev => E, Vtype => T.Ortho_Type (Kind), Ptype => T.Ortho_Ptr_Type (Kind))); end if; end E2M; function E2M (E : O_Enode; T : Type_Info_Acc; Kind : Object_Kind_Type; Vtype : O_Tnode; Ptype : O_Tnode) return Mnode is begin pragma Assert (Is_Composite (T)); return Mnode'(M1 => (State => Mstate_Ep, K => Kind, T => T, Ep => E, Vtype => Vtype, Ptype => Ptype)); 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_Ev => -- 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 Mstate_Ep => return New_Access_Element (M.M1.Ep); 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_Ev | Mstate_Ep => 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_Ev => return M.M1.Ev; when Mstate_Ep => return M.M1.Ep; 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_Ep => return M.M1.Ep; when Mstate_Ev => -- For scalar, M contains the value so there is no lvalue from -- which the address can be taken. raise Internal_Error; 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_Unbounded_Array | Type_Mode_Unbounded_Record | Type_Mode_Bounds_Acc => return Lv2M (L, Vtype, Mode); when Type_Mode_Complex_Array | Type_Mode_Complex_Record | Type_Mode_Protected => return Lp2M (L, Vtype, Mode); when Type_Mode_Static_Array | Type_Mode_Static_Record => return Lv2M (L, Vtype, Mode); 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_Unbounded_Array | Type_Mode_Unbounded_Record | Type_Mode_Bounds_Acc => return Dv2M (D, Vtype, Mode); when Type_Mode_Complex_Array | Type_Mode_Complex_Record | Type_Mode_Protected => return Dp2M (D, Vtype, Mode); when Type_Mode_Static_Array | Type_Mode_Static_Record => return Dv2M (D, Vtype, Mode); 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; procedure Set_Stack2_Mark (Var : O_Lnode) is Constr : O_Assoc_List; begin Start_Association (Constr, Ghdl_Stack2_Mark); New_Assign_Stmt (Var, New_Function_Call (Constr)); end Set_Stack2_Mark; procedure Release_Stack2 (Var : O_Lnode) is Constr : O_Assoc_List; begin Start_Association (Constr, Ghdl_Stack2_Release); New_Association (Constr, New_Value (Var)); New_Procedure_Call (Constr); end Release_Stack2; -- Create a temporary variable. type Temp_Level_Type; type Temp_Level_Acc is access Temp_Level_Type; type Temp_Level_Type is record -- Link to the outer record. Prev : Temp_Level_Acc; -- Nested level. 'Top' level is 0. Level : Natural; -- Generated variable id, starts from 0. Id : Natural; -- True if a scope was created, as it is created dynamically at the -- first use. Emitted : Boolean; -- If true, do not mark/release stack2. No_Stack2_Mark : Boolean; -- Declaration of the variable for the stack2 mark. The stack2 will -- be released at the end of the scope (if used). Stack2_Mark : O_Dnode; 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 -- Allocate a new record. if Old_Level /= null then -- From unused ones. L := Old_Level; Old_Level := L.Prev; else -- No unused, create a new one. L := new Temp_Level_Type; end if; L.all := (Prev => Temp_Level, Level => 0, Id => 0, Emitted => False, No_Stack2_Mark => False, Stack2_Mark => O_Dnode_Null); 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 Disable_Stack2_Release is begin Temp_Level.No_Stack2_Mark := True; end Disable_Stack2_Release; procedure Open_Local_Temp is begin Open_Temp; Temp_Level.Emitted := True; end Open_Local_Temp; function Has_Stack2_Mark return Boolean is begin return Temp_Level.Stack2_Mark /= O_Dnode_Null; end Has_Stack2_Mark; procedure Stack2_Release is begin if Temp_Level.Stack2_Mark /= O_Dnode_Null then Release_Stack2 (New_Obj (Temp_Level.Stack2_Mark)); Temp_Level.Stack2_Mark := O_Dnode_Null; end if; end Stack2_Release; procedure Close_Temp is L : Temp_Level_Acc; begin -- Check that OPEN_TEMP was called. pragma Assert (Temp_Level /= null); 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; -- 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 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; if Temp_Level.No_Stack2_Mark then -- Stack2 mark and release was explicitly disabled. return; end if; Temp_Level.Stack2_Mark := Create_Temp (Ghdl_Ptr_Type); Set_Stack2_Mark (New_Obj (Temp_Level.Stack2_Mark)); 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; function Create_Temp_Bounds (Tinfo : Type_Info_Acc) return Mnode is begin return Dv2M (Create_Temp (Tinfo.B.Bounds_Type), Tinfo, Mode_Value, Tinfo.B.Bounds_Type, Tinfo.B.Bounds_Ptr_Type); end Create_Temp_Bounds; -- 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;