------------------------------------ -------------------------------------------- -- -- -- 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;