------------------------------------------------------------------------------ -- -- -- GLADE COMPONENTS -- -- -- -- X E _ B A C K . G A R L I C -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2005 Free Software Foundation, Inc. -- -- -- -- GNATDIST 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. GNATDIST is distributed in the hope that it will be useful, but -- -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABI- -- -- LITY 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 GNATDIST; see file COPYING. If -- -- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- GLADE is maintained by AdaCore -- -- (email: sales@adacore.com) -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; use GNAT.OS_Lib; with XE; use XE; with XE_Defs; use XE_Defs; with XE_Defs.Defaults; with XE_Flags; use XE_Flags; with XE_Front; use XE_Front; with XE_IO; use XE_IO; with XE_Names; use XE_Names; with XE_Utils; use XE_Utils; with XE_Back; pragma Elaborate_All (XE_Back); package body XE_Back.GARLIC is type GARLIC_Backend is new Backend with null record; procedure Set_PCS_Dist_Flags (Self : access GARLIC_Backend); procedure Initialize (Self : access GARLIC_Backend); procedure Run_Backend (Self : access GARLIC_Backend); function Get_Detach_Flag (Self : access GARLIC_Backend) return Name_Id; Elaboration_File : File_Name_Type; Protocol_Config_File : File_Name_Type; Storage_Config_File : File_Name_Type; type RU_Id is (RU_System, RU_System_Garlic, RU_System_Garlic_Elaboration, RU_System_Garlic_Filters, RU_System_Garlic_Heart, RU_System_Garlic_Name_Table, RU_System_Garlic_No_Tasking, RU_System_Garlic_Options, RU_System_Garlic_Priorities, RU_System_Garlic_Protocols, RU_System_Garlic_Protocols_Config, RU_System_Garlic_Remote, RU_System_Garlic_Startup, RU_System_Garlic_Storages, RU_System_Garlic_Storages_Config, RU_System_Garlic_Tasking, RU_System_Garlic_Types, RU_System_Partition_Interface, RU_System_RPC, RU_System_RPC_Server); RU : array (RU_Id) of Unit_Name_Type; type RE_Id is (RE_Register_Partition_To_Launch, RE_Set_RPC_Handler_Priority, RE_Set_RPC_Handler_Priority_Policy, RE_Set_Rsh_Command, RE_Set_Rsh_Options, RE_Set_Slave, RE_Set_Termination, RE_Set_Reconnection, RE_Set_Boot_Location, RE_Set_Self_Location, RE_Set_Data_Location, RE_Set_Nolaunch, RE_Set_Task_Pool_Bounds, RE_Set_Light_PCS, RE_Set_Pure_Client, RE_Initialize_0, RE_Initialize_1, RE_Initialize_2, RE_Set_Partition_Name, RE_Set_Registration_Filter, RE_Set_Default_Filter, RE_Set_Channel_Filter, RE_Register_Passive_Partition, RE_Register_Passive_Package, RE_Register_Passive_Package_On_Passive_Partition, RE_Elaborate_Passive_Partition, RE_Check, RE_Run, RE_Partition_ID, RE_Register); RE : array (RE_Id) of Unit_Name_Type; RE_Unit_Table : constant array (RE_Id) of RU_Id := (RE_Register_Partition_To_Launch => RU_System_Garlic_Remote, RE_Set_RPC_Handler_Priority => RU_System_Garlic_Priorities, RE_Set_RPC_Handler_Priority_Policy => RU_System_Garlic_Priorities, RE_Set_Rsh_Command => RU_System_Garlic_Options, RE_Set_Rsh_Options => RU_System_Garlic_Options, RE_Set_Slave => RU_System_Garlic_Options, RE_Set_Termination => RU_System_Garlic_Options, RE_Set_Reconnection => RU_System_Garlic_Options, RE_Set_Boot_Location => RU_System_Garlic_Options, RE_Set_Self_Location => RU_System_Garlic_Options, RE_Set_Data_Location => RU_System_Garlic_Options, RE_Set_Nolaunch => RU_System_Garlic_Options, RE_Set_Task_Pool_Bounds => RU_System_Garlic_Options, RE_Set_Light_PCS => RU_System_Garlic_Options, RE_Set_Pure_Client => RU_System_Garlic_Options, RE_Initialize_0 => RU_System_Garlic_No_Tasking, RE_Initialize_1 => RU_System_Garlic_Tasking, RE_Initialize_2 => RU_System_Garlic_Name_Table, RE_Set_Partition_Name => RU_System_Garlic_Options, RE_Set_Registration_Filter => RU_System_Garlic_Filters, RE_Set_Default_Filter => RU_System_Garlic_Filters, RE_Set_Channel_Filter => RU_System_Garlic_Filters, RE_Register_Passive_Partition => RU_System_Partition_Interface, RE_Register_Passive_Package => RU_System_Partition_Interface, RE_Register_Passive_Package_On_Passive_Partition => RU_System_Partition_Interface, RE_Elaborate_Passive_Partition => RU_System_Partition_Interface, RE_Check => RU_System_Partition_Interface, RE_Run => RU_System_Partition_Interface, RE_Partition_ID => RU_System_RPC, RE_Register => RU_System_Garlic_Protocols); procedure Add_Protocol (First : in out Location_Id; Last : in out Location_Id; Name : Name_Id); -- Add a protocol of name Name to the chained list which starts at -- First and ends at Last. function Location_List_Image (Location : Location_Id) return Name_Id; -- Explore linked list of locations to build its image procedure Generate_Elaboration_File (P : Partition_Id); -- Create the elaboration unit for the given partition. This unit -- overloads the default PCS settings. procedure Generate_Executable_File (P : Partition_Id); -- Compile main partition file and elaboration file. -- Bind and link partition to create executable. procedure Generate_Partition_Main_File (P : Partition_Id); -- Create a procedure which "withes" all the RCI or SP receivers -- of the partition and insert the main procedure if needed. procedure Generate_Protocol_Config_File (P : Partition_Id); -- Create protocol configuration file that includes the protocols -- required in the GLADE configuration file for this partition. procedure Generate_Storage_Config_File (P : Partition_Id); -- Create storage configuration file that includes the storages -- required in the GLADE configuration file for this partition. function Name (U : Unit_Id) return Name_Id; -- Take a unit id and return its name removing unit suffix. ------------------ -- Add_Protocol -- ------------------ procedure Add_Protocol (First : in out Location_Id; Last : in out Location_Id; Name : Name_Id) is LID : Location_Id; begin if First /= No_Location_Id then LID := First; while LID /= No_Location_Id loop if Locations.Table (LID).Major = Name then return; end if; LID := Locations.Table (LID).Next_Location; end loop; end if; Add_Location (First, Last, Name, No_Name); end Add_Protocol; ------------------------------- -- Generate_Elaboration_File -- ------------------------------- procedure Generate_Elaboration_File (P : Partition_Id) is procedure Register_Launched_Partition (P : Partition_Id); --------------------------------- -- Register_Launched_Partition -- --------------------------------- procedure Register_Launched_Partition (P : Partition_Id) is Current : Partition_Type renames Partitions.Table (P); Use_Rem_Host : Boolean; Remote_Host : Name_Id; Executable : File_Name_Type := Current.Executable_File; begin Write_Image (Remote_Host, Current.Host, P); Use_Rem_Host := Present (Remote_Host); if not Use_Rem_Host then Remote_Host := Quote (Current.Name); end if; Executable := Strip_Exec_Suffix (Executable); Write_Call (RE (RE_Register_Partition_To_Launch), Capitalize (Id (Boolean'Image (Use_Rem_Host))), Get_Name_String (Remote_Host), Quote (To_Absolute_File (Executable) & Current.Command_Line)); end Register_Launched_Partition; Filename : File_Name_Type; File : File_Descriptor; Current : Partition_Type renames Partitions.Table (P); Channel : Channel_Id; Filter : Filter_Name_Type; Peer : Partition_Id; begin Filename := Elaboration_File & ADB_Suffix_Id; Filename := Dir (Current.Partition_Dir, Filename); Create_File (File, Filename); Set_Output (File); Write_Line ("pragma Warnings (Off);"); Write_With_Clause (RU (RU_System_Garlic_Filters), True); Write_With_Clause (RU (RU_System_Garlic_Heart), True); Write_With_Clause (RU (RU_System_Garlic_Name_Table), True); Write_With_Clause (RU (RU_System_Garlic_Options), True); Write_With_Clause (RU (RU_System_Garlic_Priorities), True); Write_With_Clause (RU (RU_System_Garlic_Remote), True); Write_With_Clause (RU (RU_System_Garlic_Types), True); if Current.Tasking = 'N' then Write_With_Clause (RU (RU_System_Garlic_No_Tasking), False, True); else Write_With_Clause (RU (RU_System_Garlic_Tasking), False, True); end if; -- Add filtering package if needed Filter := Default_Registration_Filter; if Present (Filter) then Write_With_Clause (RU (RU_System_Garlic_Filters) and Capitalize (Filter)); end if; if Present (Current.Filter) then Write_With_Clause (RU (RU_System_Garlic_Filters) and Capitalize (Current.Filter)); end if; if Current.First_Channel /= No_Channel_Id then Channel := Current.First_Channel; while Channel /= No_Channel_Id loop Filter := Channels.Table (Channel).Filter; if Present (Filter) then Write_With_Clause (RU (RU_System_Garlic_Filters) and Capitalize (Filter)); end if; if Channels.Table (Channel).Lower.My_Partition = P then Channel := Channels.Table (Channel).Lower.Next_Channel; else Channel := Channels.Table (Channel).Upper.Next_Channel; end if; end loop; end if; Write_Str ("package body "); Write_Name (RU (RU_System_Garlic_Elaboration)); Write_Line (" is"); Increment_Indentation; Write_Indentation; Write_Line ("procedure Initialize is"); Write_Indentation; Write_Line ("begin"); Increment_Indentation; if Current.Priority /= No_Priority then Write_Call (RE (RE_Set_RPC_Handler_Priority), No_Name, Current.Priority'Img); end if; if Default_Priority_Policy /= No_Priority_Policy then Write_Call (RE (RE_Set_RPC_Handler_Priority_Policy), Priority_Policy_Img (Default_Priority_Policy)); end if; Write_Call (RE (RE_Set_Rsh_Command), Quote (Get_Rsh_Command)); Write_Call (RE (RE_Set_Rsh_Options), Quote (Get_Rsh_Options)); -- If the partition holds the main unit, then it cannot be slave. -- Otherwise, it is. if P /= Main_Partition then Write_Call (RE (RE_Set_Slave), Id ("True")); else Write_Call (RE (RE_Set_Slave), Id ("False")); end if; -- How should the partition terminate. Note that -- Global_Termination is the default. No need to force the -- default. if Current.Termination /= No_Termination then Write_Call (RE (RE_Set_Termination), Termination_Img (Current.Termination)); end if; -- When this partition is restarted, how should we handle -- reconnections? if Current.Reconnection /= No_Reconnection then Write_Call (RE (RE_Set_Reconnection), Reconnection_Img (Current.Reconnection)); end if; -- If a protocol has been specified, then use it (with its data -- if present). if Default_First_Boot_Location /= No_Location_Id then Write_Call (RE (RE_Set_Boot_Location), Location_List_Image (Default_First_Boot_Location)); end if; -- Compute the self location string (eventually composed of -- several locations separated by commas). if Current.First_Network_Loc /= No_Location_Id then Write_Call (RE (RE_Set_Self_Location), Location_List_Image (Current.First_Network_Loc)); end if; -- Compute the data location string (eventually composed of -- several locations separated by commas). if Current.Storage_Loc /= No_Location_Id then Write_Call (RE (RE_Set_Data_Location), Location_List_Image (Current.Storage_Loc)); end if; -- If we have no Ada starter (None or Shell), then it is equivalent -- to having --nolaunch on the command line. if Default_Starter /= Ada_Import then Write_Call (RE (RE_Set_Nolaunch), No_Name, "True"); end if; -- Do we want to control the number of anonymous tasks if Current.Task_Pool /= No_Task_Pool then Name_Len := 0; Add_Str_To_Name_Buffer (Int'Image (Current.Task_Pool (1))); Add_Char_To_Name_Buffer (','); Add_Str_To_Name_Buffer (Int'Image (Current.Task_Pool (2))); Add_Char_To_Name_Buffer (','); Add_Str_To_Name_Buffer (Int'Image (Current.Task_Pool (3))); Write_Call (RE (RE_Set_Task_Pool_Bounds), Id (Name_Buffer (2 .. Name_Len))); end if; -- Set tasking policy and with appropriate package if Current.Tasking = 'N' then Write_Call (RE (RE_Initialize_0)); Write_Call (RE (RE_Set_Light_PCS), Id ("True")); elsif Current.Tasking = 'U' then Write_Call (RE (RE_Initialize_1)); Write_Call (RE (RE_Set_Pure_Client), Id ("True")); else -- Get_Tasking (P) = 'P' Write_Call (RE (RE_Initialize_1)); end if; -- Elaborate Name_Table Write_Call (RE (RE_Initialize_2)); Write_Call (RE (RE_Set_Partition_Name), Quote (Current.Name)); -- Set registration filter, default filter and partition filters Filter := Default_Registration_Filter; if Present (Filter) then Write_Call (RE (RE_Set_Registration_Filter), Quote (Filter)); end if; Filter := Partitions.Table (Default_Partition_Id).Filter; if Present (Filter) then Write_Call (RE (RE_Set_Default_Filter), Quote (Filter)); end if; Channel := Current.First_Channel; while Channel /= No_Channel_Id loop Filter := Channels.Table (Channel).Filter; if Channels.Table (Channel).Lower.My_Partition = P then Peer := Channels.Table (Channel).Upper.My_Partition; Channel := Channels.Table (Channel).Lower.Next_Channel; else Peer := Channels.Table (Channel).Lower.My_Partition; Channel := Channels.Table (Channel).Upper.Next_Channel; end if; if Present (Filter) then Write_Call (RE (RE_Set_Channel_Filter), Quote (Partitions.Table (Peer).Name), No_Str, Quote (Filter)); end if; end loop; -- Initialize filters Filter := Default_Registration_Filter; if Present (Filter) then Write_Call (RU (RU_System_Garlic_Filters) and Capitalize (Filter) and "Initialize"); end if; if Present (Current.Filter) then Write_Call (RU (RU_System_Garlic_Filters) and Capitalize (Current.Filter) and "Initialize"); end if; Channel := Current.First_Channel; while Channel /= No_Channel_Id loop Filter := Channels.Table (Channel).Filter; if Present (Filter) then Write_Call (RU (RU_System_Garlic_Filters) and Capitalize (Filter) and "Initialize"); end if; if Channels.Table (Channel).Lower.My_Partition = P then Channel := Channels.Table (Channel).Lower.Next_Channel; else Channel := Channels.Table (Channel).Upper.Next_Channel; end if; end loop; if P = Main_Partition then if Default_Starter = Ada_Import then for J in Partitions.First + 1 .. Partitions.Last loop if J /= Main_Partition and then Partitions.Table (J).Passive /= BTrue then Register_Launched_Partition (J); end if; end loop; end if; end if; Decrement_Indentation; Write_Indentation; Write_Line ("end Initialize;"); Decrement_Indentation; Write_Str ("end "); Write_Name (RU (RU_System_Garlic_Elaboration)); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Elaboration_File; ------------------------------ -- Generate_Executable_File -- ------------------------------ procedure Generate_Executable_File (P : Partition_Id) is Current : Partition_Type renames Partitions.Table (P); Executable : File_Name_Type; Directory : Directory_Name_Type; I_Part_Dir : String_Access; Comp_Args : String_List (1 .. 8); Make_Args : String_List (1 .. 8); Sfile : File_Name_Type; Prj_Fname : File_Name_Type; Length : Natural := 6; begin Executable := Current.Executable_File; Directory := Current.Partition_Dir; Name_Len := 2; Name_Buffer (1) := '-'; Name_Buffer (2) := 'I'; Get_Name_String_And_Append (Directory); I_Part_Dir := new String'(Name_Buffer (1 .. Name_Len)); -- Give the priority to partition and stub directory against -- current directory. Comp_Args (1) := E_Current_Dir; Comp_Args (2) := I_Part_Dir; Comp_Args (3) := I_Stub_Dir; Comp_Args (4) := I_Current_Dir; -- If there is no project file, then save ali and object files -- in partition directory. if Project_File_Name = null then Comp_Args (5) := Object_Dir_Flag; Comp_Args (6) := new String'(Get_Name_String (Directory)); else Comp_Args (5) := Project_File_Flag; Prj_Fname := Dir (Directory, Part_Prj_File_Name); Comp_Args (6) := new String'(Get_Name_String (Prj_Fname)); end if; -- Compile Garlic elaboration file Sfile := Elaboration_File & ADB_Suffix_Id; if Project_File_Name = null then Sfile := Dir (Directory, Sfile); end if; Compile (Sfile, Comp_Args (1 .. Length)); -- Compile protocol configuration file if any Sfile := Protocol_Config_File & ADB_Suffix_Id; if Is_Regular_File (Dir (Directory, Sfile)) then if Project_File_Name = null then Sfile := Dir (Directory, Sfile); end if; Compile (Sfile, Comp_Args (1 .. Length)); end if; -- Compile storage support configuration file if any Sfile := Storage_Config_File & ADB_Suffix_Id; if Is_Regular_File (Dir (Directory, Sfile)) then if Project_File_Name = null then Sfile := Dir (Directory, Sfile); end if; Compile (Sfile, Comp_Args (1 .. Length)); end if; -- We already checked the consistency of all the partition -- units. In case of an inconsistency of exception mode, we may -- have to rebuild some parts of garlic (units configured just -- for this partition). Note that some parts of Garlic may have -- been already recompiled when the monolithic application was -- initially built. Some bodies may be missing as they are -- assigned to partitions we do not want to build. So compile -- silently and do not exit on errors (keep going). Sfile := Partition_Main_File & ADB_Suffix_Id; if Project_File_Name = null then Sfile := Dir (Directory, Sfile); Comp_Args (7) := Compile_Only_Flag; Comp_Args (8) := Keep_Going_Flag; Length := 8; end if; Build (Sfile, Comp_Args (1 .. Length), Fatal => False, Silent => True); Free (Comp_Args (6)); -- Now we just want to bind and link as the ALI files are now -- consistent. Make_Args (1) := E_Current_Dir; Make_Args (2) := I_Part_Dir; Make_Args (3) := I_Stub_Dir; Make_Args (4) := I_Current_Dir; Make_Args (5) := Bind_Only_Flag; Make_Args (6) := Link_Only_Flag; if Project_File_Name = null then Make_Args (7) := Output_Flag; Make_Args (8) := new String'(Get_Name_String (Executable)); else Make_Args (7) := Project_File_Flag; Prj_Fname := Dir (Directory, Part_Prj_File_Name); Make_Args (8) := new String'(Get_Name_String (Prj_Fname)); end if; Build (Sfile, Make_Args, Fatal => True, Silent => False); Free (Make_Args (2)); Free (Make_Args (8)); end Generate_Executable_File; ---------------------------------- -- Generate_Partition_Main_File -- ---------------------------------- procedure Generate_Partition_Main_File (P : Partition_Id) is Filename : File_Name_Type; File : File_Descriptor; Current : Partition_Type renames Partitions.Table (P); Conf_Unit : Conf_Unit_Id; Unit : Unit_Id; Variable : constant Name_Id := Id ("Partition"); Location : Location_Id; function Import_Stub_From (Partition : Partition_Id) return Boolean; -- Return True when we include stubs assigned to Partition ---------------------- -- Import_Stub_From -- ---------------------- function Import_Stub_From (Partition : Partition_Id) return Boolean is begin for J in Current.First_Stub .. Current.Last_Stub loop if Get_Partition_Id (Stubs.Table (J)) = Partition then return True; end if; end loop; return False; end Import_Stub_From; begin Filename := Partition_Main_File & ADB_Suffix_Id; Filename := Dir (Current.Partition_Dir, Filename); Create_File (File, Filename); Set_Output (File); Write_Line ("pragma Warnings (Off);"); Write_With_Clause (RU (RU_System_Partition_Interface), True); Write_With_Clause (RU (RU_System_RPC)); if Current.Tasking /= 'N' then Write_With_Clause (RU (RU_System_RPC_Server)); end if; Write_With_Clause (RU (RU_System_Garlic_Startup), False, True); -- Assign RCI or SP skels on the partition Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Write_With_Clause (Conf_Units.Table (Conf_Unit).Name); Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; -- Assign the RCI or SP stubs to compare version with skels for J in Current.First_Stub .. Current.Last_Stub loop Write_With_Clause (Stubs.Table (J)); end loop; -- Add termination package and locking mechanisms if needed Write_Str ("procedure "); Write_Name (Partition_Main_Name); Write_Line (" is"); Increment_Indentation; Write_Indentation; Write_Name (Variable); Write_Line (" : "); Write_Name (RE (RE_Partition_ID)); Write_Line (";"); Decrement_Indentation; Write_Line ("begin"); Increment_Indentation; -- Register passive partitions and their shared passive -- packages as they are not going to do this registration by -- themselves. for J in Partitions.First + 1 .. Partitions.Last loop if Partitions.Table (J).Passive = BTrue and then Import_Stub_From (J) then Location := Partitions.Table (J).Storage_Loc; if Location = No_Location_Id then Location := Default_Data_Location; end if; Write_Call (RE (RE_Register_Passive_Partition), Variable, No_Str, Quote (Partitions.Table (J).Name), Get_Name_String (Location_List_Image (Location))); Conf_Unit := Partitions.Table (J).First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Write_Call (RE (RE_Register_Passive_Package_On_Passive_Partition), Variable, No_Str, Quote (Conf_Units.Table (Conf_Unit).Name), No_Str, Conf_Units.Table (Conf_Unit).Name & "'Version"); Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; Conf_Unit := Partitions.Table (J).First_Unit; if Conf_Unit /= No_Conf_Unit_Id then Write_Call (RE (RE_Elaborate_Passive_Partition), Variable); end if; end if; end loop; -- Register shared passive packages since they have no -- elaboration code. Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Unit := Conf_Units.Table (Conf_Unit).My_Unit; if Units.Table (Unit).Shared_Passive then Write_Call (RE (RE_Register_Passive_Package), Quote (Conf_Units.Table (Conf_Unit).Name), Get_Name_String (Name (Unit)) & "'Version"); end if; Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; -- Check version consistency of RCI and SP stubs if Default_Version_Check then for J in Current.First_Stub .. Current.Last_Stub loop Unit := ALIs.Table (Get_ALI_Id (Stubs.Table (J))).Last_Unit; Write_Call (RE (RE_Check), Quote (Stubs.Table (J)), No_Str, Stubs.Table (J) & "'Version", Units.Table (Unit).RCI'Img); end loop; end if; -- Invoke main subprogram through Run routine if Present (Current.Main_Subprogram) then Get_Name_String (Current.Main_Subprogram); Add_Str_To_Name_Buffer ("'Access"); Write_Call (RE (RE_Run), Name_Find); else Write_Call (RE (RE_Run)); end if; Decrement_Indentation; Write_Str ("end "); Write_Name (Partition_Main_Name); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Partition_Main_File; ----------------------------------- -- Generate_Protocol_Config_File -- ----------------------------------- procedure Generate_Protocol_Config_File (P : Partition_Id) is Filename : File_Name_Type; File : File_Descriptor; Current : Partition_Type renames Partitions.Table (P); Major : Name_Id; Location : Location_Id; First_Loc : Location_Id := No_Location_Id; Last_Loc : Location_Id := No_Location_Id; Light_PCS : Boolean; begin Filename := Dir (Current.Partition_Dir, Protocol_Config_File); Location := Current.First_Network_Loc; Light_PCS := Current.Tasking = 'N' and then Current.Light_PCS /= BFalse; -- Having no protocol configured on this partition is not -- enough for using the default protocol configuration. The -- default protocol configuration is customized for a tasking -- profile. Therefore, in case of light PCS, we have to produce -- a specific protocol configuration. if Location = No_Location_Id and then not Light_PCS then Delete_File (Filename & ADB_Suffix_Id); Delete_File (Filename & ALI_Suffix_Id); Delete_File (Filename & Obj_Suffix_Id); return; end if; Filename := Filename & ADB_Suffix_Id; Create_File (File, Filename); Set_Output (File); Write_Line ("pragma Warnings (Off);"); -- Withed location protocols while Location /= No_Location_Id loop Add_Protocol (First_Loc, Last_Loc, Locations.Table (Location).Major); Location := Locations.Table (Location).Next_Location; end loop; if First_Loc = No_Location_Id then Location := Default_First_Boot_Location; while Location /= No_Location_Id loop Add_Protocol (First_Loc, Last_Loc, Locations.Table (Location).Major); Location := Locations.Table (Location).Next_Location; end loop; end if; if First_Loc = No_Location_Id then Add_Protocol (First_Loc, Last_Loc, Id (Get_Def_Protocol_Name)); end if; Location := First_Loc; while Location /= No_Location_Id loop Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Protocols) and Major; Write_With_Clause (Major, False, True); if Current.Tasking /= 'N' then Major := Major and "Server"; Write_With_Clause (Major, False, True); end if; Location := Locations.Table (Location).Next_Location; end loop; Write_Str ("package body "); Write_Name (RU (RU_System_Garlic_Protocols_Config)); Write_Line (" is"); Increment_Indentation; Write_Indentation; Write_Line ("procedure Initialize is"); Write_Indentation; Write_Line ("begin"); -- Register protocols used in partition locations Increment_Indentation; Location := First_Loc; while Location /= No_Location_Id loop Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Protocols) and Major; Write_Call (RE (RE_Register), Major and "Create"); Location := Locations.Table (Location).Next_Location; end loop; Decrement_Indentation; Write_Indentation; Write_Line ("end Initialize;"); Decrement_Indentation; Write_Eol; Write_Str ("end "); Write_Name (RU (RU_System_Garlic_Protocols_Config)); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Protocol_Config_File; ---------------------------------- -- Generate_Storage_Config_File -- ---------------------------------- procedure Generate_Storage_Config_File (P : Partition_Id) is Filename : File_Name_Type; File : File_Descriptor := Invalid_FD; Current : Partition_Type renames Partitions.Table (P); Partition : Partition_Id; Location : Location_Id; Uname : Unit_Name_Type; Major : Name_Id; Use_Default : Boolean := False; Conf_Unit : Conf_Unit_Id; Unit : Unit_Id; begin Filename := Dir (Current.Partition_Dir, Storage_Config_File); Filename := Filename & ADB_Suffix_Id; Delete_File (To_Afile (Filename)); Delete_File (To_Ofile (Filename)); Delete_File (Filename); -- Import the storage supports needed for shared passive stub -- packages configured on other partitions. for S in Current.First_Stub .. Current.Last_Stub loop Uname := Stubs.Table (S); Unit := ALIs.Table (Get_ALI_Id (Uname)).Last_Unit; if Units.Table (Unit).Shared_Passive then if File = Invalid_FD then Create_File (File, Filename); Set_Output (File); Write_Line ("pragma Warnings (Off);"); end if; Partition := Get_Partition_Id (Uname); Location := Partitions.Table (Partition).Storage_Loc; if Location /= No_Location_Id then Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Storages) and Major; Write_With_Clause (Major, False, True); else Use_Default := True; end if; end if; end loop; -- Import storage supports needed for shared passive packages -- configured on this partition. Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Unit := Conf_Units.Table (Conf_Unit).My_Unit; if Units.Table (Unit).Shared_Passive then if File = Invalid_FD then Create_File (File, Filename); Set_Output (File); Write_Line ("pragma Warnings (Off);"); end if; Location := Current.Storage_Loc; if Location /= No_Location_Id then Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Storages) and Major; Write_With_Clause (Major, False, True); else Use_Default := True; end if; end if; Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; -- Import default storage supports when a partition did not -- come with its own. if Use_Default then Location := Default_Data_Location; Major := Capitalize (Locations.Table (Location).Major); Major := RU (RU_System_Garlic_Storages) and Major; Write_With_Clause (Major, False, True); end if; if File = Invalid_FD then return; end if; -- Initialize storage supports Write_Str ("package body "); Write_Name (RU (RU_System_Garlic_Storages_Config)); Write_Line (" is"); Increment_Indentation; Write_Indentation; Write_Line ("procedure Initialize is"); Write_Indentation; Write_Line ("begin"); -- Follow the same approach as for package importation Increment_Indentation; for S in Current.First_Stub .. Current.Last_Stub loop Uname := Stubs.Table (S); Unit := ALIs.Table (Get_ALI_Id (Uname)).Last_Unit; if Units.Table (Unit).Shared_Passive then Partition := Get_Partition_Id (Uname); Location := Partitions.Table (Partition).Storage_Loc; if Location /= No_Location_Id then Major := Locations.Table (Location).Major; Write_Call (RU (RU_System_Garlic_Storages) and Capitalize (Major) and "Initialize"); end if; end if; end loop; Conf_Unit := Current.First_Unit; while Conf_Unit /= No_Conf_Unit_Id loop Unit := Conf_Units.Table (Conf_Unit).My_Unit; if Units.Table (Unit).Shared_Passive then Location := Current.Storage_Loc; if Location /= No_Location_Id then Major := Locations.Table (Location).Major; Write_Call (RU (RU_System_Garlic_Storages) and Capitalize (Major) and "Initialize"); end if; end if; Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit; end loop; if Use_Default then Major := Locations.Table (Default_Data_Location).Major; Write_Call (RU (RU_System_Garlic_Storages) and Capitalize (Major) and "Initialize"); end if; Decrement_Indentation; Write_Indentation; Write_Line ("end Initialize;"); Decrement_Indentation; Write_Eol; Write_Str ("end "); Write_Name (RU (RU_System_Garlic_Storages_Config)); Write_Line (";"); Close (File); Set_Standard_Output; end Generate_Storage_Config_File; --------------------- -- Get_Detach_Flag -- --------------------- function Get_Detach_Flag (Self : access GARLIC_Backend) return Name_Id is pragma Unreferenced (Self); begin return Id ("--detach"); end Get_Detach_Flag; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : access GARLIC_Backend) is pragma Unreferenced (Self); Position : Integer; Length : Natural; begin XE_Back.Initialize; Elaboration_File := Id ("s-garela"); Protocol_Config_File := Id ("s-gaprco"); Storage_Config_File := Id ("s-gastco"); Register_Casing_Rule ("PCS"); for U in RU_Id'First .. RU_Id'Last loop Set_Str_To_Name_Buffer (RU_Id'Image (U)); Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len)); Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); Position := 0; RU (U) := Name_Find; Length := Name_Len; Set_Name_Table_Info (RU (U), RU_Id'Pos (U) + 1); while Name_Len > 0 loop if Name_Buffer (Name_Len) = '_' then Name_Len := Name_Len - 1; Position := Integer (Get_Name_Table_Info (Name_Find)); exit when Position > 0; else Name_Len := Name_Len - 1; end if; end loop; -- When there is a parent, remove parent unit name from -- unit name to get real identifier. if Position > 0 then Set_Str_To_Name_Buffer (Name_Buffer (Name_Len + 2 .. Length)); RU (U) := RU (RU_Id'Val (Position - 1)) and Name_Find; else Set_Str_To_Name_Buffer (Name_Buffer (1 .. Length)); RU (U) := Name_Find; end if; if Debug_Mode then Message (U'Img & " = " & Get_Name_String (RU (U))); end if; end loop; for E in RE_Id loop Set_Str_To_Name_Buffer (RE_Id'Image (E)); Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len)); Apply_Casing_Rules (Name_Buffer (1 .. Name_Len)); while Name_Buffer (Name_Len) in '0' .. '9' or else Name_Buffer (Name_Len) = '_' loop Name_Len := Name_Len - 1; end loop; RE (E) := RU (RE_Unit_Table (E)) and Name_Find; if Debug_Mode then Message (E'Img & " = " & Get_Name_String (RE (E))); end if; end loop; end Initialize; ------------------------- -- Location_List_Image -- ------------------------- function Location_List_Image (Location : Location_Id) return Name_Id is L : Location_Id := Location; begin Name_Len := 0; loop Get_Name_String_And_Append (Locations.Table (L).Major); if Present (Locations.Table (L).Minor) then Add_Str_To_Name_Buffer ("://"); Get_Name_String_And_Append (Locations.Table (L).Minor); end if; L := Locations.Table (L).Next_Location; exit when L = No_Location_Id; Add_Char_To_Name_Buffer (' '); end loop; return Quote (Name_Find); end Location_List_Image; ---------- -- Name -- ---------- function Name (U : Unit_Id) return Name_Id is begin return Name (Units.Table (U).Uname); end Name; ----------------- -- Run_Backend -- ----------------- procedure Run_Backend (Self : access GARLIC_Backend) is Current : Partition_Type; begin Prepare_Directories; Generate_All_Stubs_And_Skels; -- Create partition files and fill partition directories for J in Partitions.First + 1 .. Partitions.Last loop if Partitions.Table (J).To_Build then Current := Partitions.Table (J); if Current.To_Build and then Current.Passive /= BTrue then if Rebuild_Partition (J) then if not Quiet_Mode then Message ("building partition", Current.Name); end if; Generate_Partition_Main_File (J); Generate_Elaboration_File (J); Generate_Protocol_Config_File (J); Generate_Storage_Config_File (J); Generate_Executable_File (J); Generate_Stamp_File (J); end if; elsif Verbose_Mode then Message ("no need to expand", Current.Name); end if; end if; end loop; Generate_Starter_File (Backend_Access (Self)); end Run_Backend; ------------------------ -- Set_PCS_Dist_Flags -- ------------------------ procedure Set_PCS_Dist_Flags (Self : access GARLIC_Backend) is pragma Unreferenced (Self); function Try_Prefix (Prefix : String) return Boolean; -- Try to use the given Prefix, return True if it is valid and -- contains a GARLIC installation. function Try_Prefix (Prefix : String) return Boolean is GARLIC_Dir : constant String := Prefix & Directory_Separator & "lib" & Directory_Separator & "garlic"; begin if Prefix'Length = 0 or else not Is_Directory (GARLIC_Dir) then return False; end if; Scan_Dist_Arg ("-I" & GARLIC_Dir); return True; end Try_Prefix; begin Scan_Dist_Arg ("-margs"); declare Runtime_Prefix : constant String := XE_Defs.Get_Dist_Prefix; Compile_Prefix : constant String := XE_Defs.Defaults.Default_Prefix; begin if True and then not Try_Prefix (Runtime_Prefix) and then not Try_Prefix (Compile_Prefix) then Message ("GARLIC library not found"); raise Fatal_Error; end if; end; Scan_Dist_Arg ("-largs"); Scan_Dist_Arg ("-lgarlic"); end Set_PCS_Dist_Flags; begin Register_Backend ("garlic", new GARLIC_Backend); end XE_Back.GARLIC;