diff options
Diffstat (limited to 'src/vhdl/translate/trans.adb')
| -rw-r--r-- | src/vhdl/translate/trans.adb | 2034 |
1 files changed, 2034 insertions, 0 deletions
diff --git a/src/vhdl/translate/trans.adb b/src/vhdl/translate/trans.adb new file mode 100644 index 0000000..faed4b6 --- /dev/null +++ b/src/vhdl/translate/trans.adb @@ -0,0 +1,2034 @@ +-- 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 : Var_Scope_Acc; 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 + D : O_Dnode; + K : Object_Kind_Type; + begin + K := M.M1.K; + case M.M1.State is + when Mstate_E => + if M.M1.Comp then + D := Create_Temp_Init (M.M1.Ptype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dp, + Comp => M.M1.Comp, + K => K, T => M.M1.T, Dp => D, + Vtype => M.M1.Vtype, Ptype => M.M1.Ptype)); + else + D := Create_Temp_Init (M.M1.Vtype, M.M1.E); + return Mnode'(M1 => (State => Mstate_Dv, + Comp => M.M1.Comp, + 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, + Comp => M.M1.Comp, + 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, + Comp => M.M1.Comp, + 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, + Comp => M.M1.Comp, + 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. + if M.M1.Comp then + raise Internal_Error; + end if; + 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, + Comp => M.M1.Comp, + 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, + Comp => T.Type_Mode in Type_Mode_Fat, + 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, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => T.Ortho_Type (Kind), + Ptype => T.Ortho_Ptr_Type (Kind))); + end Lv2M; + + function Lv2M (L : O_Lnode; + Comp : Boolean; + Vtype : O_Tnode; + Ptype : O_Tnode; + T : Type_Info_Acc; Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Lv, + Comp => Comp, + 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, + Comp => T.Type_Mode in Type_Mode_Fat, + 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, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lp => L, + Vtype => Vtype, Ptype => Ptype)); + end Lp2M; + + 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, + Comp => T.Type_Mode in Type_Mode_Fat, + K => Kind, T => T, Lv => L, + Vtype => Vtype, Ptype => Ptype)); + end Lv2M; + + function Dv2M (D : O_Dnode; + T : Type_Info_Acc; + Kind : Object_Kind_Type) + return Mnode is + begin + return Mnode'(M1 => (State => Mstate_Dv, + Comp => T.Type_Mode in Type_Mode_Fat, + 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, + Comp => T.Type_Mode in Type_Mode_Fat, + 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, + Comp => T.Type_Mode in Type_Mode_Fat, + 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, + Comp => T.Type_Mode in Type_Mode_Fat, + 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, + Comp => T.Type_Mode in Type_Mode_Fat, + 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 => + if M.M1.Comp then + return M.M1.E; + else + raise Internal_Error; + end if; + 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 + 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; |