--------------------------------------------- ----------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . G E N E R A T O R S . B U I L D _ U T I L 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 Ada.Unchecked_Deallocation; with GNAT.Table; with GNAT.Dynamic_Tables; with GNAT.OS_Lib; with GNAT.Expect; with GNAT.Directory_Operations; with Namet; with Output; with Utils; with Ocarina.Nodes; with Ocarina.Nutils; with Ocarina.Entities.Components; with Ocarina.Generators.Utils; with Ocarina.Generators.Messages; with Ocarina.Generators.Properties; with Ocarina.Generators.Ada_Tree.Nutils; package body Ocarina.Generators.Build_Utils is use GNAT.OS_Lib; use GNAT.Directory_Operations; use Namet; use Output; use Standard.Utils; use Ocarina.Nodes; use Ocarina.Entities.Components; use Ocarina.Generators.Utils; use Ocarina.Generators.Messages; use Ocarina.Generators.Properties; package AAU renames Ocarina.Nutils; package ADU renames Ocarina.Generators.Ada_Tree.Nutils; package Name_Tables is new GNAT.Dynamic_Tables (name_id, nat, 1, 10, 10); -- Provides a flexible Name_Id list function Length (T : Name_Tables.instance) return int; -- Return the length of a name table function Get_Runtime_Path (Runtime_Name : String) return String; -- Return the directory path to the given runtime procedure Split_Path (P : name_id; L : name_id; Basename : out name_id; Dirname : out name_id); -- Split the brute path 'P' into a base name and a directory name -- in the context of the current working directory and the -- additional location L. The path is even absolute even relative -- to the AADL file directory. All relative path are converted -- into absolute paths. function Resolve_Language (E : node_id) return supported_source_language; -- Fetches the Source_Language property of E. If the property is -- not set, try to deduce the language from the current generator. generic -- This generic package is a generic list to store the "build -- utils" (makefiles, project files...). It provides accessor -- routines to allow a process node to find its corresponding -- its corresponding "build util". type build_util is private; -- The type of "build util" Id : String; -- The Id of the generic table. It MUST be a unique string. with procedure Free (T : in out build_util); -- For deallocation purpose package Generic_List is -- This package is a generic list to store the "build utils" -- (makefiles, project files...). It provides accessor routines -- to allow a process node to find its corresponding its -- corresponding "build util". procedure Set (P : node_id; U : build_util); function Get (P : node_id) return build_util; procedure Free; -- Deallocates the table procedure Init; -- A call to this procedure is NECESSARY after any call to -- Free. It is not necessary before the first use of the table. end Generic_List; ------------ -- Length -- ------------ function Length (T : Name_Tables.instance) return int is begin return Name_Tables.Last (T) - Name_Tables.First + 1; end Length; ---------------------- -- Get_Runtime_Path -- ---------------------- function Get_Runtime_Path (Runtime_Name : String) return String is Runtime_Suffix : constant String := "include" & Directory_Separator & "ocarina" & Directory_Separator & "runtime" & Directory_Separator & Runtime_Name; Runtime_Dir : constant String := Get_Installation_Directory (Runtime_Suffix); begin pragma debug (Display_Debug_Message (Runtime_Name & " path: " & "'" & Runtime_Dir & "'")); if not Is_Directory (Runtime_Dir) then Display_Error (Runtime_Dir & " is not a valid runtime directory", Fatal => True); end if; return Runtime_Dir; end Get_Runtime_Path; ---------------- -- Split_Path -- ---------------- procedure Split_Path (P : name_id; L : name_id; Basename : out name_id; Dirname : out name_id) is begin Get_Name_String (P); -- Get the directory of the file declare Dirname_Str : constant String := Dir_Name (Name_Buffer (1 .. Name_Len)); Basename_Str : constant String := Base_Name (Name_Buffer (1 .. Name_Len)); begin if Dirname_Str = "." & Directory_Separator or else (Dirname_Str'length > 2 and then Dirname_Str (Dirname_Str'first .. Dirname_Str'first + 2) = ".." & Directory_Separator) then -- This is a relative path. To convert it to an absolute -- path, (1) we put the Working directory of Ocarina, (2) -- then the directory of the AADL file (if it is -- relative) and (3) finally 'Dirname_Str'. if L /= No_Name then Get_Name_String (L); -- If the file location is relative, take in account -- the working directory. if Name_Buffer (1 .. 2) = "./" or else Name_Buffer (1 .. 3) = "../" then Get_Name_String (Add_Directory_Separator (Working_Directory)); Get_Name_String_And_Append (L); end if; else Get_Name_String (Add_Directory_Separator (Working_Directory)); end if; Get_Name_String (Add_Directory_Separator (Name_Find)); Add_Str_To_Name_Buffer (Dirname_Str); -- Simplification Set_Str_To_Name_Buffer (Normalize_Pathname (Name_Buffer (1 .. Name_Len))); Dirname := Add_Directory_Separator (Name_Find); else Dirname := Add_Directory_Separator (Get_String_Name (Dirname_Str)); end if; Basename := Get_String_Name (Basename_Str); end; end Split_Path; ------------------ -- Generic_List -- ------------------ package body Generic_List is package Internal_Table is new GNAT.Table (build_util, nat, 1, 10, 10); -- The interal table function Get_Internal_Name (P : node_id) return name_id; -- For code factorization purpose ----------------------- -- Get_Internal_Name -- ----------------------- function Get_Internal_Name (P : node_id) return name_id is begin pragma assert (Is_Process (P)); Set_Nat_To_Name_Buffer (nat (P)); Add_Str_To_Name_Buffer ('%' & Id & '%'); return Name_Find; end Get_Internal_Name; --------- -- Set -- --------- procedure Set (P : node_id; U : build_util) is I_Name : constant name_id := Get_Internal_Name (P); begin Internal_Table.Append (U); Set_Name_Table_Info (I_Name, Internal_Table.Last); end Set; --------- -- Get -- --------- function Get (P : node_id) return build_util is I_Name : constant name_id := Get_Internal_Name (P); Index : constant nat := Get_Name_Table_Info (I_Name); begin if Index = 0 then raise Program_Error with "Try to get a build utils which has" & " not been set"; end if; return Internal_Table.Table (Index); end Get; ---------- -- Init -- ---------- procedure Init is begin Internal_Table.Init; end Init; ---------- -- Free -- ---------- procedure Free is begin for J in Internal_Table.First .. Internal_Table.Last loop Free (Internal_Table.Table (J)); end loop; Internal_Table.Free; Internal_Table.Init; end Free; end Generic_List; ---------------------- -- Resolve_Language -- ---------------------- function Resolve_Language (E : node_id) return supported_source_language is Language : supported_source_language := Get_Source_Language (E); begin -- If the user did not specify a language for E, we assume that -- the langue is the current generator one if Language = language_none then case Current_Generator_Kind is when polyorb_qos_ada | polyorb_hi_ada => Language := language_ada_95; when polyorb_hi_c => Language := language_c; when others => raise Program_Error with "missing language in this" & " case switch"; end case; end if; return Language; end Resolve_Language; --------------- -- Makefiles -- --------------- package body Makefiles 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_Port_Instance (E : node_id); procedure Generate_Architecture_Instance (E : node_id); procedure Generate_Component_Instance (E : node_id); procedure Generate_System_Instance (E : node_id); procedure Generate_Process_Instance (E : node_id); procedure Build_Architecture_Instance (E : node_id); procedure Build_Component_Instance (E : node_id); procedure Build_System_Instance (E : node_id); procedure Build_Process_Instance (E : node_id); procedure Clean_Architecture_Instance (E : node_id); procedure Clean_Component_Instance (E : node_id); procedure Clean_System_Instance (E : node_id); procedure Clean_Process_Instance (E : node_id); type makefile_rec is record Appli_Name : name_id; -- The distributed application name Node_Name : name_id; -- The node name (in lower case) Execution_Platform : supported_execution_platform := platform_none; -- The execution platform of the processor the current node -- is bound to. Transport_API : supported_transport_apis; -- The transport API used by the current node to -- communicate with other nodes. C_Sources : Name_Tables.instance; -- The C source files that may implement some subprograms of -- the current node (absolute or relative path) C_Libraries : Name_Tables.instance; -- The C libraries that may contain the binary code of some -- subprograms of the current node (absolute or relative -- path) end record; -- This structure gathers all the information needed to -- generate a makefile for a given node of the distributed -- application. type makefile_type is access all makefile_rec; Use_Transport : Boolean; -- Use_Transport is used to know if the node has in or out port -- If it uses transport, the C Makefiles will contain something like -- NEED_TRANSPORT = [yes|no]. It is used to know if the files that -- handle transport in PolyORB-HI-C should be compiled or not. procedure Free (M : in out makefile_type); -- Deallocates the internals of T procedure PolyORB_HI_Ada_Makefile (M : makefile_type); procedure PolyORB_HI_C_Makefile (M : makefile_type); procedure PolyORB_Qos_Ada_Makefile (M : makefile_type); -- Generate the part of the Makefile that is specific to the -- corresponding code generator. procedure Ada_C_Command_Line_Flags (M : makefile_type; L_Flag : Boolean); procedure Compile_C_Files (M : makefile_type); -- Code factorization between different generators procedure Change_If_Empty (Str_Ptr : in out String_Access; Value : String); pragma inline (Change_If_Empty); -- If Str_Ptr is null or points to the empty string, reallocate -- it with the given Value. procedure Handle_C_Source (E : node_id; Source_Files : name_array; M : makefile_type); -- Update the makefile structure by adding necessary paths to -- sources or libraries provided by the 'Source_Files' array. E -- is the node for which the source files are given, it is used -- to resolve relatove paths through its absolute location. --------------------- -- Change_If_Empty -- --------------------- procedure Change_If_Empty (Str_Ptr : in out String_Access; Value : String) is begin if Str_Ptr = null or else Str_Ptr.all = "" then if Str_Ptr /= null then Free (Str_Ptr); end if; Str_Ptr := new String'(Value); end if; end Change_If_Empty; ---------- -- Free -- ---------- procedure Free (M : in out makefile_type) is procedure Deallocate is new Ada.Unchecked_Deallocation (makefile_rec, makefile_type); begin Name_Tables.Free (M.all.C_Sources); Name_Tables.Free (M.all.C_Libraries); Deallocate (M); end Free; package Makefiles is new Generic_List (makefile_type, "Makefile_List", Free); -- The list of all the makefile structures ----------- -- Reset -- ----------- procedure Reset is begin Makefiles.Free; end Reset; --------------------- -- Handle_C_Source -- --------------------- procedure Handle_C_Source (E : node_id; Source_Files : name_array; M : makefile_type) is Source_Basename : name_id; Source_Dirname : name_id; S_Name : name_id; begin for J in Source_Files'range loop -- Ensure the source is added only once per node Get_Name_String (Source_Files (J)); Get_Name_String_And_Append (M.Node_Name); Add_Str_To_Name_Buffer ("%source_text%"); S_Name := Name_Find; if Get_Name_Table_Info (S_Name) = 0 then Set_Name_Table_Info (S_Name, 1); Get_Name_String (Source_Files (J)); Split_Path (Source_Files (J), Loc (E).Dir, Source_Basename, Source_Dirname); Get_Name_String (Source_Basename); if Name_Buffer (Name_Len - 1 .. Name_Len) = ".o" or else Name_Buffer (Name_Len - 1 .. Name_Len) = ".a" then -- Library names MUST begin with "lib" if Name_Buffer (Name_Len - 1 .. Name_Len) = ".a" and then (Name_Len <= 5 or else Name_Buffer (1 .. 3) /= "lib") then Display_Error ("Invalid library name" & Name_Buffer (1 .. Name_Len), Fatal => True); end if; Get_Name_String (Source_Dirname); Get_Name_String_And_Append (Source_Basename); Name_Tables.Append (M.C_Libraries, Name_Find); elsif Name_Buffer (Name_Len - 1 .. Name_Len) = ".c" then Get_Name_String (Source_Dirname); Get_Name_String_And_Append (Source_Basename); Name_Tables.Append (M.C_Sources, Name_Find); end if; end if; end loop; end Handle_C_Source; ----------- -- 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 k_port_spec_instance => Visit_Port_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_subprogram => Visit_Subprogram_Instance (E); when others => null; end case; end Visit_Component_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : node_id) is S : constant node_id := Parent_Subcomponent (E); A : constant node_id := Parent_Component (Parent_Subcomponent (E)); M : constant makefile_type := new makefile_rec; SC : node_id; begin -- Associates the Makefile structure to the process -- instance. Keep in mind that it is important to use -- accesses here because all the visited threads and -- subprgrams will fetch this access to update the -- corresponding structure. Makefiles.Set (E, M); Use_Transport := False; M.Appli_Name := Normalize_Name (Name (Identifier (A))); M.Node_Name := Normalize_Name (Name (Identifier (S))); -- Get the execution platform of the processor this node is -- bound to. M.Execution_Platform := Get_Execution_Platform (Get_Bound_Processor (E)); -- Get the transport API used by this node. It is -- important to ensure that the Namings package visitors -- have already been executed since they perform all -- consistency checks and bind a node to its transport -- API. M.Transport_API := Fetch_Transport_API (E); -- Initialize the lists Name_Tables.Init (M.C_Sources); Name_Tables.Init (M.C_Libraries); -- Visit all the subcomponents of the process if not AAU.Is_Empty (Subcomponents (E)) then SC := First_Node (Subcomponents (E)); while Present (SC) loop -- Visit the corresponding instance of SC Visit (Corresponding_Instance (SC)); SC := Next_Node (SC); end loop; end if; end Visit_Process_Instance; --------------------------- -- Visit_System_Instance -- --------------------------- procedure Visit_System_Instance (E : node_id) is S : node_id; begin -- 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; end Visit_System_Instance; --------------------------- -- Visit_Thread_Instance -- --------------------------- procedure Visit_Thread_Instance (E : node_id) is Parent_Process : constant node_id := Corresponding_Instance (Get_Container_Process (E)); M : constant makefile_type := Makefiles.Get (Parent_Process); Language : constant supported_source_language := Resolve_Language (E); Source_Files : constant name_array := Get_Source_Text (E); Call_Seq : node_id; Spg_Call : node_id; F : node_id; begin -- If the thread implementataion is in C, we need to update -- the makefile structure if Language = language_c then Handle_C_Source (E, Source_Files, M); end if; -- Visit the features of the thread for possible source -- files. 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 Use_Transport := True; if Is_In (F) then Visit (F); end if; 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; ------------------------------- -- Visit_Subprogram_Instance -- ------------------------------- procedure Visit_Subprogram_Instance (E : node_id) is Parent_Process : constant node_id := Corresponding_Instance (Get_Container_Process (E)); M : constant makefile_type := Makefiles.Get (Parent_Process); Subprogram_Kind : constant supported_subprogram_kind := Get_Subprogram_Kind (E); Source_Files : constant name_array := Get_Source_Text (E); Call_Seq : node_id; Spg_Call : node_id; begin -- Only C subprogram influence the structure of the -- generated makefile. case Subprogram_Kind is when subprogram_opaque_c => -- If the subprogram is implemented by C source files, -- add the files to the C_Files list of the makefile -- structure. If the subprogram is implemented by a C -- library, add the files to the C_Libraries list of -- the makefile structure. Handle_C_Source (E, Source_Files, M); when others => null; end case; -- Visit all the call sequences of the subprogram 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_Subprogram_Instance; ------------------------- -- Visit_Port_Instance -- ------------------------- procedure Visit_Port_Instance (E : node_id) is Parent_Process : constant node_id := Corresponding_Instance (Get_Container_Process (Parent_Component (E))); M : constant makefile_type := Makefiles.Get (Parent_Process); Language : constant supported_source_language := Resolve_Language (E); Source_Files : constant name_array := Get_Source_Text (E); begin -- If the port implementataion is in C, we need to update -- the makefile structure if Language = language_c then Handle_C_Source (E, Source_Files, M); end if; end Visit_Port_Instance; -------------- -- Generate -- -------------- procedure Generate (E : node_id) is begin case Kind (E) is when k_architecture_instance => Generate_Architecture_Instance (E); when k_component_instance => Generate_Component_Instance (E); when others => null; end case; end Generate; ------------------------------------ -- Generate_Architecture_Instance -- ------------------------------------ procedure Generate_Architecture_Instance (E : node_id) is begin Generate (Root_System (E)); end Generate_Architecture_Instance; --------------------------------- -- Generate_Component_Instance -- --------------------------------- procedure Generate_Component_Instance (E : node_id) is Cathegory : constant component_category := Get_Category_Of_Component (E); begin case Cathegory is when cc_system => Generate_System_Instance (E); when cc_process => Generate_Process_Instance (E); when others => null; end case; end Generate_Component_Instance; ------------------------------ -- Generate_System_Instance -- ------------------------------ procedure Generate_System_Instance (E : node_id) is S : node_id; begin -- Generate the makefiles of all process subcomponents if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop Generate (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; end Generate_System_Instance; ------------------------------- -- Generate_Process_Instance -- ------------------------------- procedure Generate_Process_Instance (E : node_id) is M : constant makefile_type := Makefiles.Get (E); Fd : File_Descriptor; begin -- Enter the directories Enter_Directory (M.Appli_Name); Enter_Directory (M.Node_Name); -- Create the file Fd := Create_File ("Makefile", Text); if Fd = Invalid_FD then raise Program_Error; end if; -- Setting the output Set_Output (Fd); Write_Line ("#####################################################"); Write_Line ("# This Makefile has been generated automatically #"); Write_Line ("# by the Ocarina AADL toolsuite. #"); Write_Line ("# Do not edit this file since all your changes will #"); Write_Line ("# be overriddedn at the next code generation. #"); Write_Line ("#####################################################"); Write_Eol; Write_Str ("# Distributed application name : "); Write_Name (M.Appli_Name); Write_Eol; Write_Str ("# Node name : "); Write_Name (M.Node_Name); Write_Eol; Write_Line ("# Execution platform : " & M.Execution_Platform'img); Write_Line ("# Transport API : " & M.Transport_API'img); Write_Eol; if Current_Generator_Kind = polyorb_hi_ada or else Current_Generator_Kind = polyorb_qos_ada then -- Common variable declaration -- Determin the compiler that will be used. If the user did -- specify the target prefix by mean of the environment -- variable "TARGET_PREFIX" then we use its -- value. Otherwise, we use the default compiler name. declare Target_Prefix : String_Access := Getenv ("TARGET_PREFIX"); Target : String_Access; begin case M.Execution_Platform is when platform_native | platform_none => Change_If_Empty (Target_Prefix, ""); Target := new String'("NATIVE"); when platform_leon_rtems | platform_leon_ork => Change_If_Empty (Target_Prefix, "sparc-elf-"); Target := new String'("NATIVE"); when platform_erc32_ork => Change_If_Empty (Target_Prefix, "erc32-elf-"); Target := new String'("NATIVE"); when others => raise Program_Error; end case; Write_Line ("GNATMAKE = " & Target_Prefix.all & "gnatmake"); Write_Line ("GNAT = " & Target_Prefix.all & "gnat"); Write_Line ("GCC = " & Target_Prefix.all & "gcc"); Write_Line ("TARGET = " & Target.all); Write_Line ("BUILD = Debug"); Write_Line ("CGCTRL = No"); Free (Target_Prefix); Free (Target); end; end if; case Current_Generator_Kind is when polyorb_hi_ada => PolyORB_HI_Ada_Makefile (M); when polyorb_qos_ada => PolyORB_Qos_Ada_Makefile (M); when polyorb_hi_c => PolyORB_HI_C_Makefile (M); when others => raise Program_Error; end case; -- Close the file Close (Fd); Set_Standard_Output; -- Leave the directories Leave_Directory; Leave_Directory; end Generate_Process_Instance; ----------------------------- -- PolyORB_HI_Ada_Makefile -- ----------------------------- procedure PolyORB_HI_Ada_Makefile (M : makefile_type) is -- N : Name_Id; begin -- Variable definitions -- Project file Write_Str ("PROJECT_FILE = "); Write_Name (M.Node_Name); Write_Line (".gpr"); Write_Eol; -- The 'all' target Write_Str ("all:"); -- If there are C files to be compiled add a dependency on -- these files if Length (M.C_Sources) > 0 then Write_Str (" compile-c-files"); end if; Write_Eol; Write_Char (ASCII.HT); Write_Line ("ADA_PROJECT_PATH=" & Quoted (Get_Runtime_Path ("polyorb-hi") & Path_Separator & "$$ADA_PROJECT_PATH") & " \"); Write_Char (ASCII.HT); Write_Str (" $(GNATMAKE) -P$(PROJECT_FILE) -XTARGET=$(TARGET)" & " -XBUILD=$(BUILD) -XCGCTRL=$(CGCTRL)"); -- If there are C source or C libraries, there will be more -- options. Ada_C_Command_Line_Flags (M, True); Write_Str (" $(EXTERNAL_OBJECTS) "); Write_Eol; -- GNAT Check target Write_Eol; Write_Line ("check:"); Write_Char (ASCII.HT); Write_Line ("ADA_PROJECT_PATH=" & Quoted (Get_Runtime_Path ("polyorb-hi") & Path_Separator & "$$ADA_PROJECT_PATH") & " \"); Write_Char (ASCII.HT); Write_Line (" $(GNAT) check -P$(PROJECT_FILE) -XTARGET=$(TARGET) " & " -rules -ALL +RGoto +RSlices +RDecl_Blocks " & " +RDiscr_Rec +RContr_Types 2> /dev/null"); -- GNAT Metrics target Write_Eol; Write_Line ("metrics:"); Write_Char (ASCII.HT); Write_Line ("ADA_PROJECT_PATH=" & Quoted (Get_Runtime_Path ("polyorb-hi") & Path_Separator & "$$ADA_PROJECT_PATH") & " \"); Write_Char (ASCII.HT); Write_Line (" $(GNAT) metric -P$(PROJECT_FILE) -XTARGET=$(TARGET) " & " 2> /dev/null"); -- Compile the C files, if any Write_Eol; Compile_C_Files (M); Write_Eol; end PolyORB_HI_Ada_Makefile; --------------------------- -- PolyORB_HI_C_Makefile -- --------------------------- procedure PolyORB_HI_C_Makefile (M : makefile_type) is begin Write_Str ("BINARY = "); Write_Name (M.Node_Name); Write_Eol; Write_Str ("TARGET = "); case M.Execution_Platform is when platform_native | platform_none => Write_Str ("native"); when platform_leon_rtems => Write_Str ("leon.rtems"); when platform_leon_ork => Write_Str ("leon.ork"); when platform_erc32_ork => Write_Str ("erc32.ork"); when platform_arm_dslinux => Write_Str ("arm.dslinux"); when platform_arm_n770 => Write_Str ("arm.n770"); end case; Write_Eol; Write_Str ("NEED_TRANSPORT = "); if Use_Transport then Write_Str ("yes"); else Write_Str ("no"); end if; Write_Eol; -- The 'all' target Write_Line ("all: compile-node"); Write_Line ("include $(POLYORB_HI_PATH)/share/make/Makefile.common"); Write_Eol; end PolyORB_HI_C_Makefile; ------------------------------ -- PolyORB_Qos_Ada_Makefile -- ------------------------------ procedure PolyORB_Qos_Ada_Makefile (M : makefile_type) is begin -- Project file Write_Str ("PROJECT_FILE = "); Write_Name (M.Node_Name); Write_Line (".gpr"); Write_Eol; -- The 'all' target Write_Str ("all: "); -- If there are C files to be compiled add a dependency on -- these files if Length (M.C_Sources) > 0 then Write_Str (" compile-c-files"); end if; Write_Eol; Write_Str (ASCII.HT & "$(GNAT) make -P$(PROJECT_FILE) `polyorb-config`"); -- If there are C source or C libraries, there will be more -- options. Ada_C_Command_Line_Flags (M, False); Write_Eol; Write_Eol; -- Compile the C files, if any Compile_C_Files (M); Write_Eol; end PolyORB_Qos_Ada_Makefile; ------------------------------ -- Ada_C_Command_Line_Flags -- ------------------------------ procedure Ada_C_Command_Line_Flags (M : makefile_type; L_Flag : Boolean) is begin if Length (M.C_Sources) > 0 or else Length (M.C_Libraries) > 0 then if L_Flag then Write_Line (" -largs \"); Write_Str (ASCII.HT & " "); else Write_Str (" "); end if; end if; -- In case of C source files, we add the correspodning .o -- files. if Length (M.C_Sources) > 0 then for J in Name_Tables.First .. Name_Tables.Last (M.C_Sources) loop Get_Name_String (M.C_Sources.Table (J)); Set_Str_To_Name_Buffer (Base_Name (Name_Buffer (1 .. Name_Len))); Name_Buffer (Name_Len) := 'o'; Write_Name (Name_Find); exit when J = Name_Tables.Last (M.C_Sources); Write_Line (" \"); Write_Str (ASCII.HT & " "); end loop; end if; -- In case of C libraries or objects, we add the -- corresponding option. if Length (M.C_Libraries) > 0 then Write_Line (" \"); Write_Str (ASCII.HT & " "); for J in Name_Tables.First .. Name_Tables.Last (M.C_Libraries) loop Get_Name_String (M.C_Libraries.Table (J)); -- Some tests declare Is_Object : constant Boolean := Name_Buffer (Name_Len) = 'o'; Dirname : constant String := Dir_Name (Name_Buffer (1 .. Name_Len)); Basename : constant String := Base_Name (Name_Buffer (1 .. Name_Len)); begin if Is_Object then Write_Name (M.C_Libraries.Table (J)); else Write_Str ("-L" & Dirname & ' '); Write_Str ("-l"); Write_Str (Basename (Basename'first + 3 .. Basename'last)); end if; end; exit when J = Name_Tables.Last (M.C_Libraries); Write_Line (" \"); Write_Str (ASCII.HT & " "); end loop; end if; end Ada_C_Command_Line_Flags; --------------------- -- Compile_C_Files -- --------------------- procedure Compile_C_Files (M : makefile_type) is begin if Length (M.C_Sources) > 0 then Write_Line ("compile-c-files:"); for J in Name_Tables.First .. Name_Tables.Last (M.C_Sources) loop declare O_File : name_id; begin Get_Name_String (M.C_Sources.Table (J)); Name_Buffer (Name_Len) := 'o'; Set_Str_To_Name_Buffer (Base_Name (Name_Buffer (1 .. Name_Len))); O_File := Name_Find; Write_Char (ASCII.HT); Write_Str ("$(GCC) -c "); Write_Name (M.C_Sources.Table (J)); Write_Str (" -o "); Write_Name (O_File); Write_Eol; end; end loop; end if; end Compile_C_Files; ----------- -- Build -- ----------- procedure Build (E : node_id) is begin case Kind (E) is when k_architecture_instance => Build_Architecture_Instance (E); when k_component_instance => Build_Component_Instance (E); when others => null; end case; end Build; --------------------------------- -- Build_Architecture_Instance -- --------------------------------- procedure Build_Architecture_Instance (E : node_id) is begin Build (Root_System (E)); end Build_Architecture_Instance; ------------------------------ -- Build_Component_Instance -- ------------------------------ procedure Build_Component_Instance (E : node_id) is Cathegory : constant component_category := Get_Category_Of_Component (E); begin case Cathegory is when cc_system => Build_System_Instance (E); when cc_process => Build_Process_Instance (E); when others => null; end case; end Build_Component_Instance; --------------------------- -- Build_System_Instance -- --------------------------- procedure Build_System_Instance (E : node_id) is S : node_id; begin -- Build all process subcomponents if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop Build (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; end Build_System_Instance; ---------------------------- -- Build_Process_Instance -- ---------------------------- procedure Build_Process_Instance (E : node_id) is use GNAT.Expect; M : constant makefile_type := Makefiles.Get (E); Fd : Process_Descriptor; Result : Expect_Match; Status : Integer := 0; Args : Argument_List (1 .. 0); begin -- Enter the directories Enter_Directory (M.Appli_Name); Enter_Directory (M.Node_Name); -- Invoke the 'make' command Non_Blocking_Spawn (Descriptor => Fd, Command => GNU_Make_Cmd, Args => Args, Buffer_Size => 16 * 1_024, Err_To_Out => True); Add_Filter (Fd, Trace_Filter'access, GNAT.Expect.Output); Add_Filter (Fd, Trace_Filter'access, GNAT.Expect.Died); -- Wait until the command achieves its execution begin Expect (Fd, Result, "", -1); -- This call never match, it is only used to wait until -- Ocarina1 terminates. exception when GNAT.Expect.Process_Died => Close (Fd, Status); if Status /= 0 then Display_Error (GNU_Make_Cmd & " died unexpectedly with code: " & Status'img, Fatal => True); else pragma debug (Display_Debug_Message (GNU_Make_Cmd & " finished normally", Force => True)); null; end if; end; -- Leave the directories Leave_Directory; Leave_Directory; end Build_Process_Instance; ----------- -- Clean -- ----------- procedure Clean (E : node_id) is begin case Kind (E) is when k_architecture_instance => Clean_Architecture_Instance (E); when k_component_instance => Clean_Component_Instance (E); when others => null; end case; end Clean; --------------------------------- -- Clean_Architecture_Instance -- --------------------------------- procedure Clean_Architecture_Instance (E : node_id) is begin Clean (Root_System (E)); end Clean_Architecture_Instance; ------------------------------ -- Clean_Component_Instance -- ------------------------------ procedure Clean_Component_Instance (E : node_id) is Cathegory : constant component_category := Get_Category_Of_Component (E); begin case Cathegory is when cc_system => Clean_System_Instance (E); when cc_process => Clean_Process_Instance (E); when others => null; end case; end Clean_Component_Instance; --------------------------- -- Clean_System_Instance -- --------------------------- procedure Clean_System_Instance (E : node_id) is S : node_id; begin -- Clean all process subcomponents if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop Clean (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; end Clean_System_Instance; ---------------------------- -- Clean_Process_Instance -- ---------------------------- procedure Clean_Process_Instance (E : node_id) is use GNAT.Expect; M : constant makefile_type := Makefiles.Get (E); begin -- Enter the directories GNAT.Directory_Operations.Remove_Dir (Get_Name_String (M.Appli_Name), True); exception when GNAT.Directory_Operations.Directory_Error => null; end Clean_Process_Instance; end Makefiles; ----------------------- -- Ada_Project_Files -- ----------------------- package body Ada_Project_Files 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_Port_Instance (E : node_id); procedure Generate_Architecture_Instance (E : node_id); procedure Generate_Component_Instance (E : node_id); procedure Generate_System_Instance (E : node_id); procedure Generate_Process_Instance (E : node_id); type ada_project_file_rec is record Appli_Name : name_id; -- The distributed application name Node_Name : name_id; -- The node name (in lower case) Is_Server : Boolean; -- True of the process has IN ports Execution_Platform : supported_execution_platform; -- The execution platform of the processor the current node -- is bound to. Transport_API : supported_transport_apis; -- The transport API used by the current node to -- communicate with other nodes. Spec_Names : Name_Tables.instance; Custom_Spec_Names : Name_Tables.instance; -- USER Ada specs with custom names. For each index J, -- Spec_Names (J) is the Ada spec name and Custom_Spec_Names -- (J) is the file name containing the spec. Body_Names : Name_Tables.instance; Custom_Body_Names : Name_Tables.instance; -- USER Ada bodies with custom names. For each index J, -- Body_Names (J) is the Ada body name and Custom_Body_Names -- (J) is the file name containing the body. User_Source_Dirs : Name_Tables.instance; -- Directories of the source files provided by the user end record; -- This structure gathers all the information needed to -- generate an Ada project file for a given node of the -- distributed application. type ada_project_file_type is access all ada_project_file_rec; procedure Free (P : in out ada_project_file_type); -- Deallocates the internals of T procedure PolyORB_HI_Ada_Ada_Project_File (P : ada_project_file_type); procedure PolyORB_HI_C_Ada_Project_File (P : ada_project_file_type); procedure PolyORB_Qos_Ada_Ada_Project_File (P : ada_project_file_type); -- Generate the part of the Ada project file that is specific -- to the corresponding code generator. procedure Handle_Ada_Source (E : node_id; Implem_Name : name_id; Source_Files : name_array; P : ada_project_file_type); -- Update the project file structure by adding necessary paths -- to sources provided by the 'Source_Files' array. If no -- source text is given bu an implmenentation name is, deduce -- file names from implementation name. E is the node for which -- the source files are given, it is used to resolve relatove -- paths through its absolute location. ---------- -- Free -- ---------- procedure Free (P : in out ada_project_file_type) is procedure Deallocate is new Ada.Unchecked_Deallocation (ada_project_file_rec, ada_project_file_type); begin -- Deallocate internal tables Name_Tables.Free (P.all.Spec_Names); Name_Tables.Free (P.all.Custom_Spec_Names); Name_Tables.Free (P.all.Body_Names); Name_Tables.Free (P.all.Custom_Body_Names); Name_Tables.Free (P.all.User_Source_Dirs); Deallocate (P); end Free; package Ada_Project_Files is new Generic_List (ada_project_file_type, "Ada_Project_File_List", Free); -- The list of all the makefile structures ----------- -- Reset -- ----------- procedure Reset is begin Ada_Project_Files.Free; end Reset; ----------------------- -- Handle_Ada_Source -- ----------------------- procedure Handle_Ada_Source (E : node_id; Implem_Name : name_id; Source_Files : name_array; P : ada_project_file_type) is Conv_Base_Name : name_id; Custom_Name : name_id; Suffix : String (1 .. 4); Source_Dirname : name_id; Source_Basename : name_id; Binding_Key : constant String := "%user_src_dir%"; begin if Implem_Name /= No_Name then Conv_Base_Name := ADU.Conventional_Base_Name (ADU.Unit_Name (Implem_Name)); end if; -- Ensure the user gives at most 2 sources files (a spec and -- a body). if Source_Files'length > 2 then Display_Located_Error (Loc (E), "More than 2 source files for an Ada subprogram", Fatal => True); end if; if Source_Files'length = 0 and then Implem_Name /= No_Name then -- This means that the user did not provide source file -- names for the Ada implementation bu did provided the -- implementataion name. Therefore, the corresponding -- source files have conventional names and are located -- at the same directory as the AADL file. Split_Path (Conv_Base_Name, Loc (E).Dir, Source_Basename, Source_Dirname); Set_Str_To_Name_Buffer (Binding_Key); Get_Name_String_And_Append (Source_Dirname); Get_Name_String_And_Append (P.Node_Name); if Get_Name_Table_Byte (Name_Find) = 0 then Name_Tables.Append (P.User_Source_Dirs, Source_Dirname); Set_Name_Table_Byte (Name_Find, 1); end if; elsif Source_Files'length /= 0 and then Implem_Name /= No_Name then for J in Source_Files'range loop Split_Path (Source_Files (J), Loc (E).Dir, Source_Basename, Source_Dirname); -- Add the directory to the user directory list -- (if it has not been added yet) Set_Str_To_Name_Buffer (Binding_Key); Get_Name_String_And_Append (Source_Dirname); Get_Name_String_And_Append (P.Node_Name); if Get_Name_Table_Byte (Name_Find) = 0 then Name_Tables.Append (P.User_Source_Dirs, Source_Dirname); Set_Name_Table_Byte (Name_Find, 1); end if; Get_Name_String (Source_Basename); -- The .ad[bs] consumes 4 characters from to -- total file name. The user must give at leas -- on character base name. if Name_Len < 5 then Display_Located_Error (Loc (E), "Incorrect text file name", Fatal => True); end if; Suffix := Name_Buffer (Name_Len - 3 .. Name_Len); Custom_Name := Name_Find; if Suffix = ".ads" then if Custom_Name /= Conv_Base_Name then -- Add a custom Spec clause Name_Tables.Append (P.Spec_Names, ADU.Unit_Name (Implem_Name)); Name_Tables.Append (P.Custom_Spec_Names, Custom_Name); end if; elsif Suffix = ".adb" then if Custom_Name /= Conv_Base_Name then -- Add a custom Body clause Name_Tables.Append (P.Body_Names, ADU.Unit_Name (Implem_Name)); Name_Tables.Append (P.Custom_Body_Names, Custom_Name); end if; else Display_Located_Error (Loc (E), "Unknown suffix for Ada file name: """ & Suffix & """", Fatal => True); end if; end loop; end if; end Handle_Ada_Source; ----------- -- 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 k_port_spec_instance => Visit_Port_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_subprogram => Visit_Subprogram_Instance (E); when others => null; end case; end Visit_Component_Instance; ---------------------------- -- Visit_Process_Instance -- ---------------------------- procedure Visit_Process_Instance (E : node_id) is S : constant node_id := Parent_Subcomponent (E); A : constant node_id := Parent_Component (Parent_Subcomponent (E)); P : constant ada_project_file_type := new ada_project_file_rec; SC : node_id; begin -- Associates the Ada project file structure to the process -- instance. Keep in mind that it is important to use -- accesses here because all the visited threads and -- subprgrams will fetch this access to update the -- corresponding structure. Ada_Project_Files.Set (E, P); P.Appli_Name := Normalize_Name (Name (Identifier (A))); P.Node_Name := Normalize_Name (Name (Identifier (S))); P.Is_Server := Has_In_Ports (E); -- Get the execution platform of the processor this node is -- bound to. P.Execution_Platform := Get_Execution_Platform (Get_Bound_Processor (E)); -- Get the transport API used by this node. It is -- important to ensure that the Namings package visitors -- have already been executed since they perform all -- consistency checks and bind a node to its transport -- API. P.Transport_API := Fetch_Transport_API (E); -- Initialize the lists Name_Tables.Init (P.Spec_Names); Name_Tables.Init (P.Custom_Spec_Names); Name_Tables.Init (P.Body_Names); Name_Tables.Init (P.Custom_Body_Names); Name_Tables.Init (P.User_Source_Dirs); -- Visit all the subcomponents of the process if not AAU.Is_Empty (Subcomponents (E)) then SC := First_Node (Subcomponents (E)); while Present (SC) loop -- Visit the corresponding instance of SC Visit (Corresponding_Instance (SC)); SC := Next_Node (SC); end loop; end if; end Visit_Process_Instance; --------------------------- -- Visit_System_Instance -- --------------------------- procedure Visit_System_Instance (E : node_id) is S : node_id; begin -- 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; end Visit_System_Instance; --------------------------- -- Visit_Thread_Instance -- --------------------------- procedure Visit_Thread_Instance (E : node_id) is Parent_Process : constant node_id := Corresponding_Instance (Get_Container_Process (E)); P : constant ada_project_file_type := Ada_Project_Files.Get (Parent_Process); Language : constant supported_source_language := Resolve_Language (E); Compute_Entrypoint : constant name_id := Get_Thread_Compute_Entrypoint (E); Source_Files : constant name_array := Get_Source_Text (E); Call_Seq : node_id; Spg_Call : node_id; F : node_id; begin -- Only Ada files affect the structure of Ada project files if Language = language_ada_95 then Handle_Ada_Source (E, Compute_Entrypoint, Source_Files, P); end if; -- Visit the features of the thread for possible source -- files. 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 Is_In (F) then Visit (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; ------------------------------- -- Visit_Subprogram_Instance -- ------------------------------- procedure Visit_Subprogram_Instance (E : node_id) is Parent_Process : constant node_id := Corresponding_Instance (Get_Container_Process (E)); P : constant ada_project_file_type := Ada_Project_Files.Get (Parent_Process); Subprogram_Kind : constant supported_subprogram_kind := Get_Subprogram_Kind (E); Source_Name : constant name_id := Get_Source_Name (E); Source_Files : constant name_array := Get_Source_Text (E); Call_Seq : node_id; Spg_Call : node_id; begin -- Only Ada subprograms may influence the structure of the -- generated project files. case Subprogram_Kind is when subprogram_opaque_ada_95 | subprogram_hybrid_ada_95 => Handle_Ada_Source (E, Source_Name, Source_Files, P); when others => null; end case; -- Visit all the call sequences of the subprogram 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_Subprogram_Instance; ------------------------- -- Visit_Port_Instance -- ------------------------- procedure Visit_Port_Instance (E : node_id) is Parent_Process : constant node_id := Corresponding_Instance (Get_Container_Process (Parent_Component (E))); P : constant ada_project_file_type := Ada_Project_Files.Get (Parent_Process); Language : constant supported_source_language := Resolve_Language (E); Compute_Entrypoint : constant name_id := Get_Port_Compute_Entrypoint (E); Source_Files : constant name_array := Get_Source_Text (E); begin -- Only Ada files affect the structure of Ada project files if Language = language_ada_95 then Handle_Ada_Source (E, Compute_Entrypoint, Source_Files, P); end if; end Visit_Port_Instance; -------------- -- Generate -- -------------- procedure Generate (E : node_id) is begin case Kind (E) is when k_architecture_instance => Generate_Architecture_Instance (E); when k_component_instance => Generate_Component_Instance (E); when others => null; end case; end Generate; ------------------------------------ -- Generate_Architecture_Instance -- ------------------------------------ procedure Generate_Architecture_Instance (E : node_id) is begin Generate (Root_System (E)); end Generate_Architecture_Instance; --------------------------------- -- Generate_Component_Instance -- --------------------------------- procedure Generate_Component_Instance (E : node_id) is Cathegory : constant component_category := Get_Category_Of_Component (E); begin case Cathegory is when cc_system => Generate_System_Instance (E); when cc_process => Generate_Process_Instance (E); when others => null; end case; end Generate_Component_Instance; ------------------------------ -- Generate_System_Instance -- ------------------------------ procedure Generate_System_Instance (E : node_id) is S : node_id; begin -- Generate the project files of all process subcomponents if not AAU.Is_Empty (Subcomponents (E)) then S := First_Node (Subcomponents (E)); while Present (S) loop Generate (Corresponding_Instance (S)); S := Next_Node (S); end loop; end if; end Generate_System_Instance; ------------------------------- -- Generate_Process_Instance -- ------------------------------- procedure Generate_Process_Instance (E : node_id) is P : constant ada_project_file_type := Ada_Project_Files.Get (E); Fd : File_Descriptor; begin -- Enter the directories Enter_Directory (P.Appli_Name); Enter_Directory (P.Node_Name); -- Create the file Get_Name_String (P.Node_Name); Fd := Create_File (Name_Buffer (1 .. Name_Len) & ".gpr", Text); if Fd = Invalid_FD then raise Program_Error; end if; -- Setting the output Set_Output (Fd); Write_Line ("--------------------------------------------------------"); Write_Line ("-- This project file has been generated automatically --"); Write_Line ("-- by the Ocarina AADL toolsuite. --"); Write_Line ("-- Do not edit this file since all your changes will --"); Write_Line ("-- be overriddedn at the next code generation. --"); Write_Line ("--------------------------------------------------------"); Write_Eol; Write_Str ("-- Application name : "); Write_Name (P.Appli_Name); Write_Eol; Write_Str ("-- Node name : "); Write_Name (P.Node_Name); Write_Eol; Write_Line ("-- Execution platform : " & P.Execution_Platform'img); Write_Line ("-- Transport API : " & P.Transport_API'img); Write_Eol; case Current_Generator_Kind is when polyorb_hi_ada => PolyORB_HI_Ada_Ada_Project_File (P); when polyorb_qos_ada => PolyORB_Qos_Ada_Ada_Project_File (P); when polyorb_hi_c => PolyORB_HI_C_Ada_Project_File (P); when others => raise Program_Error; end case; -- Close the file Close (Fd); Set_Standard_Output; -- Leave the directories Leave_Directory; Leave_Directory; end Generate_Process_Instance; ------------------------------------- -- PolyORB_HI_Ada_Ada_Project_File -- ------------------------------------- procedure PolyORB_HI_Ada_Ada_Project_File (P : ada_project_file_type) is begin -- If the transport API is SpaceWire, add the dependency -- to the project file gathering the SpaceWire driver. if P.Transport_API = transport_spacewire then Write_Line ("with ""mts_ada_binding.gpr"";"); Write_Eol; end if; Write_Str ("project "); Write_Name (P.Node_Name); Write_Line (" extends ""polyorb_hi"" is"); Increment_Indentation; -- The source directory list Write_Indentation; Write_Line ("for Source_Dirs use"); Increment_Indentation; Write_Indentation (-1); Write_Line ("(""."","); -- Get the PolyORB-HI runtime source directory Write_Indentation; Write_Str ("""" & Get_Runtime_Path ("polyorb-hi") & """"); -- The user provided source dirs if Length (P.User_Source_Dirs) > 0 then Write_Line (","); for J in Name_Tables.First .. Name_Tables.Last (P.User_Source_Dirs) loop Write_Indentation; Write_Char ('"'); Write_Name (P.User_Source_Dirs.Table (J)); Write_Char ('"'); exit when J = Name_Tables.Last (P.User_Source_Dirs); Write_Line (","); end loop; end if; Write_Line (");"); Decrement_Indentation; -- The main subprogram name Write_Eol; Write_Indentation; Write_Str ("for Main use ("""); Write_Name (P.Node_Name); Write_Line (".adb"");"); -- The custom file names Write_Eol; Write_Indentation; Write_Line ("Package Naming is"); Increment_Indentation; Write_Eol; Write_Indentation; Write_Line ("-- Custom generated file names"); Write_Eol; Get_Name_String (P.Node_Name); Add_Str_To_Name_Buffer ("_deployment.ads"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Indentation; Write_Str ("for Specification (""Deployment"") use """); Write_Name (P.Node_Name); Write_Line ("_deployment.ads"";"); end if; Get_Name_String (P.Node_Name); Add_Str_To_Name_Buffer ("_naming.ads"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Indentation; Write_Str ("for Specification (""Naming"") use """); Write_Name (P.Node_Name); Write_Line ("_naming.ads"";"); end if; Get_Name_String (P.Node_Name); Add_Str_To_Name_Buffer ("_types.ads"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Indentation; Write_Str ("for Specification (""Types"") use """); Write_Name (P.Node_Name); Write_Line ("_types.ads"";"); end if; Get_Name_String (P.Node_Name); Add_Str_To_Name_Buffer ("_types.adb"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Indentation; Write_Str ("for Body (""Types"") use """); Write_Name (P.Node_Name); Write_Line ("_types.adb"";"); end if; Get_Name_String (P.Node_Name); Add_Str_To_Name_Buffer ("_subprograms.ads"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Indentation; Write_Str ("for Specification (""Subprograms"") use """); Write_Name (P.Node_Name); Write_Line ("_subprograms.ads"";"); end if; Get_Name_String (P.Node_Name); Add_Str_To_Name_Buffer ("_subprograms.adb"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Indentation; Write_Str ("for Body (""Subprograms"") use """); Write_Name (P.Node_Name); Write_Line ("_subprograms.adb"";"); end if; Get_Name_String (P.Node_Name); Add_Str_To_Name_Buffer ("_marshallers.ads"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Indentation; Write_Str ("for Specification (""Marshallers"") use """); Write_Name (P.Node_Name); Write_Line ("_marshallers.ads"";"); end if; Get_Name_String (P.Node_Name); Add_Str_To_Name_Buffer ("_marshallers.adb"); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Write_Indentation; Write_Str ("for Body (""Marshallers"") use """); Write_Name (P.Node_Name); Write_Line ("_marshallers.adb"";"); end if; Write_Eol; Write_Indentation; Write_Line ("-- Custom middleware file names"); Write_Eol; case P.Execution_Platform is when platform_leon_rtems | platform_leon_ork | platform_erc32_ork => Write_Indentation; Write_Line ("for Body (""Output_Low_Level"")" & " use ""output_low_level_leon.adb"";"); when others => Write_Indentation; Write_Line ("for Body (""Output_Low_Level"")" & " use ""output_low_level_native.adb"";"); end case; case P.Transport_API is when transport_bsd_sockets => Write_Indentation; Write_Line ("for Body (""PolyORB_HI.Transport_Low_Level"")" & " use ""polyorb_hi-transport_low_level_sockets.adb"";"); when transport_spacewire => Write_Indentation; Write_Line ("for Body (""PolyORB_HI.Transport_Low_Level"")" & " use ""polyorb_hi-transport_low_level_mts.adb"";"); if P.Is_Server then Write_Indentation; Write_Line ("for Body (""PolyORB_HI.Transport_Low_Level.Extras"")" & " use " & """polyorb_hi-transport_low_level-extras_mts.adb"";"); end if; when others => Write_Indentation; Write_Line ("for Body (""PolyORB_HI.Transport_Low_Level"")" & " use ""polyorb_hi-transport_low_level_dummy.adb"";"); end case; if Length (P.Spec_Names) > 0 then Write_Eol; Write_Indentation; Write_Line ("-- Custom user spec names"); Write_Eol; for J in Name_Tables.First .. Name_Tables.Last (P.Spec_Names) loop Write_Indentation; Write_Str ("for Specification ("""); Write_Name (P.Spec_Names.Table (J)); Write_Str (""") use """); Write_Name (P.Custom_Spec_Names.Table (J)); Write_Line (""";"); end loop; end if; if Length (P.Body_Names) > 0 then Write_Eol; Write_Indentation; Write_Line ("-- Custom user body names"); Write_Eol; for J in Name_Tables.First .. Name_Tables.Last (P.Body_Names) loop Write_Indentation; Write_Str ("for Body ("""); Write_Name (P.Body_Names.Table (J)); Write_Str (""") use """); Write_Name (P.Custom_Body_Names.Table (J)); Write_Line (""";"); end loop; end if; Write_Eol; Decrement_Indentation; Write_Indentation; Write_Line ("end Naming;"); Decrement_Indentation; Write_Str ("end "); Write_Name (P.Node_Name); Write_Line (";"); end PolyORB_HI_Ada_Ada_Project_File; ----------------------------------- -- PolyORB_HI_C_Ada_Project_File -- ----------------------------------- procedure PolyORB_HI_C_Ada_Project_File (P : ada_project_file_type) is pragma unreferenced (P); begin null; end PolyORB_HI_C_Ada_Project_File; -------------------------------------- -- PolyORB_Qos_Ada_Ada_Project_File -- -------------------------------------- procedure PolyORB_Qos_Ada_Ada_Project_File (P : ada_project_file_type) is begin Write_Str ("project "); Write_Name (P.Node_Name); Write_Line (" is"); Increment_Indentation; -- The source directory list Write_Indentation; Write_Line ("for Source_Dirs use"); Increment_Indentation; Write_Indentation (-1); Write_Line ("(""."","); -- Get the PolyORB-QoS Ocarina runtime source directory Write_Indentation; Write_Str ("""" & Get_Runtime_Path ("polyorb") & """"); -- The user provided source dirs if Length (P.User_Source_Dirs) > 0 then Write_Line (","); for J in Name_Tables.First .. Name_Tables.Last (P.User_Source_Dirs) loop Write_Indentation; Write_Char ('"'); Write_Name (P.User_Source_Dirs.Table (J)); Write_Char ('"'); exit when J = Name_Tables.Last (P.User_Source_Dirs); Write_Line (","); end loop; end if; Write_Line (");"); Decrement_Indentation; -- The main subprogram name Write_Eol; Write_Indentation; Write_Str ("for Main use ("""); Write_Name (P.Node_Name); Write_Line (".adb"");"); -- The executables are put in the '../bin' directory Write_Indentation; Write_Line ("for Exec_Dir use ""../bin"";"); -- Create the 'bin' directory Create_Directory (Get_String_Name ("../bin")); -- The compile flags Write_Eol; Write_Indentation; Write_Line ("Package Compiler is"); Increment_Indentation; Write_Eol; Write_Indentation; Write_Line ("for Default_Switches (""Ada"") use (""-gnatwae"");"); Write_Eol; Decrement_Indentation; Write_Indentation; Write_Line ("end Compiler;"); -- The build flags Write_Eol; Write_Indentation; Write_Line ("Package Builder is"); Increment_Indentation; Write_Eol; Write_Indentation; Write_Line ("for Default_Switches (""Ada"") use (""-m"");"); Write_Eol; Decrement_Indentation; Write_Indentation; Write_Line ("end Builder;"); Decrement_Indentation; Write_Str ("end "); Write_Name (P.Node_Name); Write_Line (";"); end PolyORB_Qos_Ada_Ada_Project_File; end Ada_Project_Files; ----------- -- Reset -- ----------- procedure Reset is begin Makefiles.Reset; Ada_Project_Files.Reset; end Reset; end Ocarina.Generators.Build_Utils;