------------------------------------ -------------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . G E N E R A T O R S . P O _ H I _ C . T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2007, GET-Telecom Paris. -- -- -- -- Ocarina is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. Ocarina 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 distributed with Ocarina; see file COPYING. -- -- If not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- Ocarina is maintained by the Ocarina team -- -- (ocarina-users@listes.enst.fr) -- -- -- ------------------------------------------------------------------------------ with Ocarina.Nodes; with Ocarina.Nutils; with Ocarina.Entities.Components; with Ocarina.Generators.Utils; with Ocarina.Generators.Properties; with Ocarina.Generators.Messages; with Ocarina.Generators.C_Tree.Nutils; with Ocarina.Generators.C_Tree.Nodes; with Ocarina.Generators.PO_HI_C.Mapping; with Ocarina.Generators.PO_HI_C.Runtime; package body Ocarina.Generators.PO_HI_C.Types is use Ocarina.Nodes; use Ocarina.Entities.Components; use Ocarina.Generators.Utils; use Ocarina.Generators.Properties; use Ocarina.Generators.Messages; use Ocarina.Generators.C_Tree.Nutils; use Ocarina.Generators.PO_HI_C.Mapping; use Ocarina.Generators.PO_HI_C.Runtime; package AAU renames Ocarina.Nutils; package CTN renames Ocarina.Generators.C_Tree.Nodes; ----------------- -- Header_File -- ----------------- package body Header_File is procedure Visit_Architecture_Instance (E : Node_Id); procedure Visit_Component_Instance (E : Node_Id); procedure Visit_System_Instance (E : Node_Id); procedure Visit_Process_Instance (E : Node_Id); procedure Visit_Thread_Instance (E : Node_Id); procedure Visit_Subprogram_Instance (E : Node_Id); procedure Visit_Data_Instance (E : Node_Id); function Feature_Spg_Spec (E : Node_Id) return Node_Id; ---------------------- -- Feature_Spg_Spec -- ---------------------- function Feature_Spg_Spec (E : Node_Id) return Node_Id is N : Node_Id; Spg : Node_Id; Parameters : constant List_Id := New_List (CTN.K_Parameter_List); begin pragma Assert (Kind (E) = K_Subprogram_Spec_Instance); Spg := Corresponding_Instance (E); pragma Assert (Is_Subprogram (Spg)); Append_Node_To_List (Make_Parameter_Specification (Defining_Identifier => Make_Defining_Identifier (PN (P_Value)), Parameter_Type => Make_Pointer_Type (Map_C_Defining_Identifier (Parent_Component (E)))), Parameters); N := Make_Function_Specification (Defining_Identifier => Map_C_Feature_Subprogram (E), Parameters => Parameters, Return_Type => New_Node (CTN.K_Void)); return N; end Feature_Spg_Spec; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case Kind (E) is when K_Architecture_Instance => Visit_Architecture_Instance (E); when K_Component_Instance => Visit_Component_Instance (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Architecture_Instance -- --------------------------------- procedure Visit_Architecture_Instance (E : Node_Id) is begin Visit (Root_System (E)); end Visit_Architecture_Instance; ------------------------------ -- Visit_Component_Instance -- ------------------------------ procedure Visit_Component_Instance (E : Node_Id) is Cathegory : constant Component_Category := Get_Category_Of_Component (E); begin case Cathegory is when CC_System => Visit_System_Instance (E); when CC_Process => Visit_Process_Instance (E); when CC_Thread => Visit_Thread_Instance (E); when CC_Data => Visit_Data_Instance (E); when CC_Subprogram => Visit_Subprogram_Instance (E); when others => null; end case; end Visit_Component_Instance; ------------------------- -- Visit_Data_Instance -- ------------------------- procedure Visit_Data_Instance (E : Node_Id) is Data_Type : Supported_Data_Type; N : Node_Id; M : Node_Id; S : Node_Id; Data_Size : Size_Type; begin if No (Get_Handling (E, By_Name, H_C_Type_Spec)) then Add_Include (RH (RH_PO_HI_Types)); -- FIXME: For now, strings and arrays are unsupported -- The code generation for the following types is not yet -- supported: Arrays and bounded strings. Data_Type := Get_Data_Type (E); Data_Size := Get_Data_Size (E); case Data_Type is when Data_Boolean => N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => Make_Defining_Identifier (TN (T_Int))); Append_Node_To_List (N, CTN.Declarations (Current_File)); when Data_Integer => if Data_Size.S = 0 then N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => Make_Defining_Identifier (TN (T_Int))); Append_Node_To_List (N, CTN.Declarations (Current_File)); elsif Data_Size.S = 8 and then Data_Size.U = Bit then N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => RE (RE_Int8_T)); Append_Node_To_List (N, CTN.Declarations (Current_File)); elsif Data_Size.S = 1 and then Data_Size.U = Properties.Byte then N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => RE (RE_Int8_T)); Append_Node_To_List (N, CTN.Declarations (Current_File)); elsif Data_Size.S = 16 and then Data_Size.U = Bit then N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => RE (RE_Int16_T)); Append_Node_To_List (N, CTN.Declarations (Current_File)); elsif Data_Size.S = 2 and then Data_Size.U = Properties.Byte then N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => RE (RE_Int16_T)); Append_Node_To_List (N, CTN.Declarations (Current_File)); elsif Data_Size.S = 32 and then Data_Size.U = Bit then N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => RE (RE_Int32_T)); Append_Node_To_List (N, CTN.Declarations (Current_File)); elsif Data_Size.S = 4 and then Data_Size.U = Properties.Byte then N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => RE (RE_Int32_T)); Append_Node_To_List (N, CTN.Declarations (Current_File)); elsif Data_Size.S = 64 and then Data_Size.U = Bit then N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => RE (RE_Int64_T)); Append_Node_To_List (N, CTN.Declarations (Current_File)); elsif Data_Size.S = 8 and then Data_Size.U = Properties.Byte then N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => RE (RE_Int64_T)); Append_Node_To_List (N, CTN.Declarations (Current_File)); else Display_Error ("Unsupported data size", Fatal => True); end if; when Data_Float | Data_Fixed => N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => Make_Defining_Identifier (TN (T_Float))); Append_Node_To_List (N, CTN.Declarations (Current_File)); when Data_Record | Data_With_Accessors => declare Struct_Members : constant List_Id := New_List (CTN.K_Enumeration_Literals); Protected_Struct_Members : constant List_Id := New_List (CTN.K_Enumeration_Literals); C : Node_Id := First_Node (Subcomponents (E)); begin -- Build the component list while Present (C) loop -- Generate the Ada type corresponding to the -- subcomponent. Visit (Corresponding_Instance (C)); -- Make the record or private type component N := Make_Member_Declaration (Defining_Identifier => Map_C_Defining_Identifier (C), Used_Type => Map_C_Data_Type_Designator (Corresponding_Instance (C))); Append_Node_To_List (N, Struct_Members); C := Next_Node (C); end loop; if Data_Type = Data_Record then -- Record type N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => Make_Struct_Aggregate (Members => Struct_Members)); Append_Node_To_List (N, CTN.Declarations (Current_File)); else -- Protected type Append_Node_To_List (Make_Member_Declaration (Used_Type => RE (RE_Protected_T), Defining_Identifier => Make_Defining_Identifier (MN (M_Protected_Id))), Protected_Struct_Members); if not Is_Empty (Struct_Members) then S := CTN.First_Node (Struct_Members); while Present (S) loop Append_Node_To_List (S, Protected_Struct_Members); S := CTN.Next_Node (S); end loop; end if; N := Make_Full_Type_Declaration (Defining_Identifier => Map_C_Defining_Identifier (E), Type_Definition => Make_Struct_Aggregate (Members => Protected_Struct_Members)); Append_Node_To_List (N, CTN.Declarations (Current_File)); S := First_Node (Features (E)); while Present (S) loop -- We are sure that S is of kind -- K_Subprogram_Spec_Instance. Otherwise, -- an error whould be raised when trying -- to find the data type. -- Build a subprogram spec and append it -- to the visible part of the protected -- type. M := Feature_Spg_Spec (S); Bind_AADL_To_Feature_Subprogram (Identifier (S), M); Append_Node_To_List (M, CTN.Declarations (Current_File)); S := Next_Node (S); end loop; -- Build the private type spec end if; end; when others => Display_Located_Error (Loc (E), "Unsupported data type!", Fatal => True); end case; -- Mark the data type as being handled an appent it to -- the handled list. Set_Handling (E, By_Name, H_C_Type_Spec, N); -- In the case of a data type with accessor, visit the -- parameters of its features subprograms. It is -- important to do this *after* marking the type as -- handled, to avoid endless loops and *before* adding -- the type declaration to the package statements because -- the declaration order of type is important in Ada. if Data_Type = Data_With_Accessors then S := First_Node (Features (E)); while Present (S) loop Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; end if; Bind_AADL_To_Type_Definition (Identifier (E), Get_Handling (E, By_Name, H_C_Type_Spec)); end Visit_Data_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : Node_Id) is U : constant Node_Id := CTN.Distributed_Application_Unit (CTN.Naming_Node (Backend_Node (Identifier (E)))); P : constant Node_Id := CTN.Entity (U); S : Node_Id; begin Push_Entity (P); Push_Entity (U); Set_Types_Header; -- Start recording the handling since they have to be reset -- for each node. Start_Recording_Handlings; -- Visit all the subcomponents of the process if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the component instance corresponding to the -- subcomponent S. Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; -- Unmark all the marked types Reset_Handlings; Pop_Entity; -- U Pop_Entity; -- P end Visit_Process_Instance; ------------------------------- -- Visit_Subprogram_Instance -- ------------------------------- procedure Visit_Subprogram_Instance (E : Node_Id) is F : Node_Id; begin -- Declare all necessary data types if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = K_Port_Spec_Instance then Display_Located_Error (Loc (F), "Port features in subprogram are not supported", Fatal => True); end if; if Present (Corresponding_Instance (F)) then Visit (Corresponding_Instance (F)); end if; F := Next_Node (F); end loop; end if; end Visit_Subprogram_Instance; --------------------------- -- Visit_System_Instance -- --------------------------- procedure Visit_System_Instance (E : Node_Id) is S : Node_Id; begin Push_Entity (HI_Distributed_Application_Root); -- Visit all the subcomponents of the system if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the component instance corresponding to the -- subcomponent S. Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; Pop_Entity; -- HI_Distributed_Application_Root end Visit_System_Instance; --------------------------- -- Visit_Thread_Instance -- --------------------------- procedure Visit_Thread_Instance (E : Node_Id) is Call_Seq : Node_Id; Spg_Call : Node_Id; F : Node_Id; begin if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = K_Port_Spec_Instance and then Nodes.Is_Data (F) then Visit (Corresponding_Instance (F)); end if; F := Next_Node (F); end loop; end if; -- Visit all the call sequences of the thread if not AAU.Is_Empty (Calls (E)) then Call_Seq := First_Node (Calls (E)); while Present (Call_Seq) loop -- For each call sequence visit all the called -- subprograms. if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then Spg_Call := First_Node (Subprogram_Calls (Call_Seq)); while Present (Spg_Call) loop Visit (Corresponding_Instance (Spg_Call)); Spg_Call := Next_Node (Spg_Call); end loop; end if; Call_Seq := Next_Node (Call_Seq); end loop; end if; end Visit_Thread_Instance; end Header_File; ----------------- -- Source_File -- ----------------- package body Source_File is procedure Visit_Architecture_Instance (E : Node_Id); procedure Visit_Component_Instance (E : Node_Id); procedure Visit_System_Instance (E : Node_Id); procedure Visit_Process_Instance (E : Node_Id); procedure Visit_Thread_Instance (E : Node_Id); procedure Visit_Subprogram_Instance (E : Node_Id); procedure Visit_Data_Instance (E : Node_Id); function Feature_Spg_Body (E : Node_Id) return Node_Id; -- Builds a body for a protected object procedure from an AADL -- subprogram spec E. ---------------------- -- Feature_Spg_Body -- ---------------------- function Feature_Spg_Body (E : Node_Id) return Node_Id is N : Node_Id; Call_Profile : List_Id; Param : Node_Id; C_Access : Node_Id; D : Node_Id; Statements : constant List_Id := New_List (CTN.K_Statement_List); Spg : Node_Id; begin pragma Assert (Kind (E) = K_Subprogram_Spec_Instance); Spg := Corresponding_Instance (E); pragma Assert (Is_Subprogram (Spg)); -- Make the call to __po_hi_protected_lock Call_Profile := New_List (CTN.K_Parameter_Profile); Append_Node_To_List (Make_Member_Designator (Make_Defining_Identifier (MN (M_Protected_Id)), Make_Defining_Identifier (PN (P_Value)), Is_Pointer => True), Call_Profile); Append_Node_To_List (Make_Call_Profile (Defining_Identifier => RE (RE_Protected_Lock), Parameters => Call_Profile), Statements); Call_Profile := New_List (CTN.K_Parameter_Profile); if not AAU.Is_Empty (Features (Spg)) then Param := First_Node (Features (Spg)); while Present (Param) loop if Kind (Param) = K_Parameter_Instance then -- Create a parameter association N := Map_C_Defining_Identifier (Param); Append_Node_To_List (N, Call_Profile); end if; Param := Next_Node (Param); end loop; end if; -- 2 - The list of all record fileds given -- FIXME: Respect the mapping rules by setting the correct -- parameter orientation. For now all parameter are -- considered IN OUT. Provide all necessary routines -- (passing through intermediate variables, to prevent the -- user from cheating). if not AAU.Is_Empty (Features (Spg)) then C_Access := First_Node (Features (Spg)); while Present (C_Access) loop if Kind (C_Access) = K_Subcomponent_Access_Instance then D := Corresponding_Instance (C_Access); if not AAU.Is_Empty (Subcomponents (D)) then Param := First_Node (Subcomponents (D)); while Present (Param) loop -- Create a parameter association N := Make_Variable_Address (Make_Member_Designator (Defining_Identifier => Map_C_Defining_Identifier (Param), Aggregate_Name => Make_Defining_Identifier (PN (P_Value)), Is_Pointer => True)); Append_Node_To_List (N, Call_Profile); Param := Next_Node (Param); end loop; end if; end if; C_Access := Next_Node (C_Access); end loop; end if; -- Add an include subprograms.h in types.c -- If we use subprograms Add_Include (RH (RH_Subprograms)); N := Make_Call_Profile (CTN.Defining_Identifier (CTN.Subprogram_Node (Backend_Node (Identifier (Corresponding_Instance (E))))), Call_Profile); Append_Node_To_List (N, Statements); -- Make the call to __po_hi_protected_unlock Call_Profile := New_List (CTN.K_Parameter_Profile); Append_Node_To_List (Make_Member_Designator (Make_Defining_Identifier (MN (M_Protected_Id)), Make_Defining_Identifier (PN (P_Value)), Is_Pointer => True), Call_Profile); Append_Node_To_List (Make_Call_Profile (Defining_Identifier => RE (RE_Protected_Unlock), Parameters => Call_Profile), Statements); -- Build the subprogram implementation N := Make_Function_Implementation (CTN.Feature_Subprogram_Node (Backend_Node (Identifier (E))), No_List, Statements); return N; end Feature_Spg_Body; ----------- -- Visit -- ----------- procedure Visit (E : Node_Id) is begin case Kind (E) is when K_Architecture_Instance => Visit_Architecture_Instance (E); when K_Component_Instance => Visit_Component_Instance (E); when others => null; end case; end Visit; --------------------------------- -- Visit_Architecture_Instance -- --------------------------------- procedure Visit_Architecture_Instance (E : Node_Id) is begin Visit (Root_System (E)); end Visit_Architecture_Instance; ------------------------------ -- Visit_Component_Instance -- ------------------------------ procedure Visit_Component_Instance (E : Node_Id) is Cathegory : constant Component_Category := Get_Category_Of_Component (E); begin case Cathegory is when CC_System => Visit_System_Instance (E); when CC_Process => Visit_Process_Instance (E); when CC_Thread => Visit_Thread_Instance (E); when CC_Data => Visit_Data_Instance (E); when CC_Subprogram => Visit_Subprogram_Instance (E); when others => null; end case; end Visit_Component_Instance; ------------------------- -- Visit_Data_Instance -- ------------------------- procedure Visit_Data_Instance (E : Node_Id) is N : Node_Id; Data_Type : Supported_Data_Type; begin Data_Type := Get_Data_Type (E); Add_Include (RH (RH_Types)); if Data_Type = Data_With_Accessors then if No (Get_Handling (E, By_Name, H_C_Type_Body)) then declare C : Node_Id := First_Node (Subcomponents (E)); S : Node_Id; begin -- Visit the subcomponents while Present (C) loop Visit (Corresponding_Instance (C)); C := Next_Node (C); end loop; -- Protected type S := First_Node (Features (E)); while Present (S) loop -- Build a subprogram spec and append it to -- the visible part of the protected type. N := Feature_Spg_Body (S); Append_Node_To_List (N, CTN.Declarations (Current_File)); S := Next_Node (S); end loop; -- Mark the data type as being handled Set_Handling (E, By_Name, H_C_Type_Body, N); -- FIXME : Handle correctly data with accessor -- marshalling. end; end if; end if; end Visit_Data_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : Node_Id) is U : constant Node_Id := CTN.Distributed_Application_Unit (CTN.Naming_Node (Backend_Node (Identifier (E)))); P : constant Node_Id := CTN.Entity (U); S : Node_Id; begin Push_Entity (P); Push_Entity (U); Set_Types_Source; Start_Recording_Handlings; -- Visit all the subcomponents of the process if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the component instance corresponding to the -- subcomponent S. Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; -- Unmark all the marked types Reset_Handlings; Pop_Entity; -- U Pop_Entity; -- P end Visit_Process_Instance; ------------------------------- -- Visit_Subprogram_Instance -- ------------------------------- procedure Visit_Subprogram_Instance (E : Node_Id) is F : Node_Id; begin -- Declare all necessary data types if not AAU.Is_Empty (Features (E)) then F := First_Node (Features (E)); while Present (F) loop if Kind (F) = K_Port_Spec_Instance then Display_Located_Error (Loc (F), "Port features in subprogram are not supported", Fatal => True); end if; if Present (Corresponding_Instance (F)) then Visit (Corresponding_Instance (F)); end if; F := Next_Node (F); end loop; end if; end Visit_Subprogram_Instance; --------------------------- -- Visit_System_Instance -- --------------------------- procedure Visit_System_Instance (E : Node_Id) is S : Node_Id; begin Push_Entity (HI_Distributed_Application_Root); -- Visit all the subcomponents of the system if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop -- Visit the component instance corresponding to the -- subcomponent S. Visit (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; Pop_Entity; -- HI_Distributed_Application_Root end Visit_System_Instance; --------------------------- -- Visit_Thread_Instance -- --------------------------- procedure Visit_Thread_Instance (E : Node_Id) is Call_Seq : Node_Id; Spg_Call : Node_Id; begin -- Visit all the call sequences of the thread if not AAU.Is_Empty (Calls (E)) then Call_Seq := First_Node (Calls (E)); while Present (Call_Seq) loop -- For each call sequence visit all the called -- subprograms. if not AAU.Is_Empty (Subprogram_Calls (Call_Seq)) then Spg_Call := First_Node (Subprogram_Calls (Call_Seq)); while Present (Spg_Call) loop Visit (Corresponding_Instance (Spg_Call)); Spg_Call := Next_Node (Spg_Call); end loop; end if; Call_Seq := Next_Node (Call_Seq); end loop; end if; end Visit_Thread_Instance; end Source_File; end Ocarina.Generators.PO_HI_C.Types;