-- -*- coding: utf-8 -*- -- -- ZanyBlue, an Ada library and framework for finite element analysis. -- -- Copyright (c) 2012, 2018, Michael Rohan -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions -- are met: -- -- * Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- * Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- -- * Neither the name of ZanyBlue nor the names of its contributors may -- be used to endorse or promote products derived from this software -- without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- with Ada.Wide_Wide_Characters.Unicode; with Ada.Containers.Vectors; with ZanyBlue.Text.Locales; with ZanyBlue.Text.Formatting; with ZanyBlue.Utils; with ZanyBlue.Directories; package body ZBMCompile.Codegen.Accessors is use ZanyBlue; use ZanyBlue.Text; use ZanyBlue.Text.Locales; use ZanyBlue.Text.Formatting; use ZanyBlue.Utils; use ZanyBlue.Directories; type Key_Descriptor_Type is record Index : Key_Index_Type; N_Args : Natural; Arg_Types : String_Vectors.Vector; end record; package Key_Descriptor_Vectors is new Ada.Containers.Vectors (Index_Type => Positive, Element_Type => Key_Descriptor_Type); subtype Key_Descriptor_Vector is Key_Descriptor_Vectors.Vector; function Argument_Class (Index : Natural; Arg_Types : String_Vectors.Vector) return String; -- Return the argument class string associated with a argument index. procedure Create_Key_Descriptors (Handler : ZBMC_Handler_Type; Facility : String; Base_Locale : String; Max_Args : out Natural; Key_Descriptors : in out Key_Descriptor_Vector); -- Create the sorted list of descriptors for the keys used in a facility. -- The descriptors give the number of arguments expected for each message -- in a facility and give the accessor argument signature. procedure Create_Facility_Accessors (Catalog : Catalog_Type; Facility : String; Options : Parameter_Set_Type; Modes : String; Max_Args : Natural; Key_Descriptors : Key_Descriptor_Vector; Base_Locale : String; Accessor_Facility : String); -- Create the spec and body for the facility accessors based on the -- accessor facility. procedure Create_Facility_Packages (Handler : ZBMC_Handler_Type; Facility : String; Options : Parameter_Set_Type); -- Create the accessor packages for an individual facility. procedure Copy_Argument_Types (Base_Locale : String; Locales : Locale_Definitions_Map; N_Args : Natural; Arg_Types : in out String_Vectors.Vector); function Message_Arg_Count (Base_Locale : String; Locales : Locale_Definitions_Map) return Natural; -- Return the expected number of arguments for a message. This is the -- the number of argument of the base locale or, if the message is not -- defined for the base locale, the max number of argument for any locale. procedure Write_Base_Message_Text (File : File_Type; Catalog : Catalog_Type; Facility : String; Key : String; Base_Locale : String; Block_Size : Positive); -- Write the value associated with the key in the base locale as a -- comment after the accessor function/procedure in the spec. This -- allows GPS to display the text associated with the message. -------------------- -- Argument_Class -- -------------------- function Argument_Class (Index : Natural; Arg_Types : String_Vectors.Vector) return String is use String_Vectors; Result : constant String := Element (Arg_Types, Index); begin if Result = "" then return "Any_Category_Type"; else return Result; end if; end Argument_Class; ------------------------- -- Copy_Argument_Types -- ------------------------- procedure Copy_Argument_Types (Base_Locale : String; Locales : Locale_Definitions_Map; N_Args : Natural; Arg_Types : in out String_Vectors.Vector) is use Locale_Definitions_Package; begin if Has_Element (Locales.Find (Base_Locale)) then Arg_Types := Element (Locales.Find (Base_Locale)).Arg_Types; else -- No base message, simply append empty strings (any argument type) -- to the type list. for I in 1 .. N_Args loop String_Vectors.Append (Arg_Types, ""); end loop; end if; end Copy_Argument_Types; ------------------------------ -- Create_Accessor_Packages -- ------------------------------ procedure Create_Accessor_Packages (Handler : ZBMC_Handler_Type; Options : Parameter_Set_Type) is Catalog : constant Catalog_Type := Get_Catalog (Handler); begin for I in 1 .. Number_Of_Facilities (Catalog) loop if Is_Ada_Identifier_OK (Get_Facility (Catalog, I)) then Create_Facility_Packages (Handler, Get_Facility (Catalog, I), Options); end if; end loop; end Create_Accessor_Packages; ------------------------------- -- Create_Facility_Accessors -- ------------------------------- procedure Create_Facility_Accessors (Catalog : Catalog_Type; Facility : String; Options : Parameter_Set_Type; Modes : String; Max_Args : Natural; Key_Descriptors : Key_Descriptor_Vector; Base_Locale : String; Accessor_Facility : String) is use Key_Descriptor_Vectors; procedure Close_And_Report (File : in out File_Type; File_Name : String; Facility_Package : String; Updated_Id : String; Retained_Id : String); procedure Write_Accessor (Spec_File : File_Type; Body_File : File_Type; Key_Descriptor : Key_Descriptor_Type); procedure Close_And_Report (File : in out File_Type; File_Name : String; Facility_Package : String; Updated_Id : String; Retained_Id : String) is Updated : Boolean; begin Close_And_Update (File, Updated); Print_Line (ZBMCompile_Facility, Select_Message (Updated, Updated_Id, Retained_Id), +Facility_Package, +File_Name); end Close_And_Report; procedure Write_Accessor (Spec_File : File_Type; Body_File : File_Type; Key_Descriptor : Key_Descriptor_Type) is Local_Arguments : constant String := "Arguments"; Empty_Arguments : constant String := "Empty_Argument_List"; Key : constant String := Get_Key (Catalog, Key_Descriptor.Index); Dash : constant Unicode_Character := '-'; begin Print_Line (Spec_File, Accessor_Facility, "10007", +Key, +Modes); Print_Line (Body_File, Accessor_Facility, "20007", +Key, +Dash, +Key.Length, +Modes); -- Print the argument list for the routine signature for I in 1 .. Key_Descriptor.N_Args loop Print_Line (Spec_File, Accessor_Facility, "10008", +(I - 1), +Modes, +Argument_Class (I - 1, Key_Descriptor.Arg_Types)); Print_Line (Body_File, Accessor_Facility, "10008", +(I - 1), +Modes, +Argument_Class (I - 1, Key_Descriptor.Arg_Types)); end loop; Print_Line (Spec_File, Accessor_Facility, "10009", +Key, +Modes); if Options.Get_Boolean ("accessor_comments") then Write_Base_Message_Text (Spec_File, Catalog, Facility, Key, Base_Locale, Options.Get_Integer ("comment_size")); end if; New_Line (Spec_File); Print_Line (Body_File, Accessor_Facility, "20008", +Modes); if Key_Descriptor.N_Args > 0 then -- Arguments, include the local arguments list Print_Line (Body_File, Accessor_Facility, "20009", +Modes); end if; Print_Line (Body_File, Accessor_Facility, "20010", +Modes); -- Append the arguments to the local Argument_List for I in 1 .. Key_Descriptor.N_Args loop Print_Line (Body_File, Accessor_Facility, "20011", +(I - 1)); end loop; -- Write the call to the underlying ZB routine. if Key_Descriptor.N_Args > 0 then Print_Line (Body_File, Accessor_Facility, "20012", +Get_Facility_Index (Catalog, Facility), +Get_Key_Index (Catalog, Key), +Key, +Local_Arguments); else Print_Line (Body_File, Accessor_Facility, "20012", +Get_Facility_Index (Catalog, Facility), +Get_Key_Index (Catalog, Key), +Key, +Empty_Arguments); end if; end Write_Accessor; Output_Directory : constant String := Options.Get_String ("output_directory"); Package_Name : constant String := Options.Get_String ("package"); Facility_Package : constant String := Format (Accessor_Facility, "00000", +Package_Name, +Facility); Spec_Name : constant String := Compose (Output_Directory, Spec_File_Name (Facility_Package, GNAT_Naming_Style)); Body_Name : constant String := Compose (Output_Directory, Body_File_Name (Facility_Package, GNAT_Naming_Style)); Spec_File : File_Type; Body_File : File_Type; begin Wide_Create_For_Update (Spec_File, Spec_Name); Wide_Create_For_Update (Body_File, Body_Name); -- Write the header comment ... Print_Line (Spec_File, Accessor_Facility, "10001", Argument0 => +Version_Major, Argument1 => +Version_Minor, Argument2 => +Version_Patch, Argument3 => +Revision); Print_Line (Body_File, Accessor_Facility, "20001", Argument0 => +Version_Major, Argument1 => +Version_Minor, Argument2 => +Version_Patch, Argument3 => +Revision); -- Write the with clauses. If there are no message arguments then -- the Arguments package in with'ed in the body rather than the -- spec. if Max_Args > 0 then Print_Line (Spec_File, Accessor_Facility, "10002"); Print_Line (Body_File, Accessor_Facility, "20002"); else Print_Line (Spec_File, Accessor_Facility, "10003"); Print_Line (Body_File, Accessor_Facility, "20003"); end if; -- Write the package declaration/implementation Print_Line (Spec_File, Accessor_Facility, "10004", +Facility_Package); Print_Line (Body_File, Accessor_Facility, "20004", +Facility_Package); -- Write the use clauses. Again, need to differentiate between spec -- and body use of the Argument package (different keys). if Max_Args > 0 then Print_Line (Spec_File, Accessor_Facility, "10005"); Print_Line (Body_File, Accessor_Facility, "20005"); else Print_Line (Spec_File, Accessor_Facility, "10006"); Print_Line (Body_File, Accessor_Facility, "20006"); end if; -- Write the declaration and implementation of the accessor routines -- for the keys in the facility. for I in 1 .. Natural (Length (Key_Descriptors)) loop Write_Accessor (Spec_File, Body_File, Element (Key_Descriptors, I)); end loop; -- Write the end of package declaration/implementation Print_Line (Spec_File, Accessor_Facility, "10010", +Facility_Package); Print_Line (Body_File, Accessor_Facility, "20013", +Facility_Package); Close_And_Report (Spec_File, Spec_Name, Facility_Package, "V00007", "V00008"); Close_And_Report (Body_File, Body_Name, Facility_Package, "V00009", "V00010"); end Create_Facility_Accessors; ------------------------------ -- Create_Facility_Packages -- ------------------------------ procedure Create_Facility_Packages (Handler : ZBMC_Handler_Type; Facility : String; Options : Parameter_Set_Type) is Catalog : constant Catalog_Type := Get_Catalog (Handler); Base_Locale : constant String := Options.Get_String ("reference_locale"); Modes : constant String := Modes_String (Options); Key_Descriptors : Key_Descriptor_Vector; Max_Args : Natural; begin if not Options.Get_Boolean ("accessor_comments") then Print_Line (ZBMCompile_Facility, "I00008"); end if; Create_Key_Descriptors (Handler, Facility, Base_Locale, Max_Args, Key_Descriptors); if Key_Descriptors.Is_Empty then -- No valid keys for facility, skipping generating of accessors Print_Line (ZBMCompile_Facility, "E00030", +Facility); return; end if; -- Create an instance for each selected accessor type. for I in Accessor_Types'Range loop if Options.Get_Boolean ("accessor:" & Accessor_Types (I).all) then Create_Facility_Accessors (Catalog, Facility, Options, Modes, Max_Args, Key_Descriptors, Base_Locale, "zbm" & Accessor_Types (I).all); end if; end loop; exception when Constraint_Error => -- Facility name is defined but it contains no messages Print_Line (ZBMCompile_Facility, "E00021", Argument0 => +Facility); end Create_Facility_Packages; ---------------------------- -- Create_Key_Descriptors -- ---------------------------- procedure Create_Key_Descriptors (Handler : ZBMC_Handler_Type; Facility : String; Base_Locale : String; Max_Args : out Natural; Key_Descriptors : in out Key_Descriptor_Vector) is Catalog : constant Catalog_Type := Get_Catalog (Handler); function "<" (Left, Right : Key_Descriptor_Type) return Boolean; -- Compare two key descriptors based on the key text. procedure Scan_Key (Catalog : Catalog_Type; Facility : String; Key : String; Locales : Locale_Definitions_Map); -- Scan the messages generating a mapping from key to expected number -- of arguments to the base message. package Key_Sorting is new Key_Descriptor_Vectors.Generic_Sorting; -- Package to sort the key descriptor list. --------- -- "<" -- --------- function "<" (Left, Right : Key_Descriptor_Type) return Boolean is use Ada.Wide_Wide_Characters.Unicode; function Norm (Key : String) return String; -- Return a normalize value for the key: simply lowercase it function Norm (Key : String) return String is Result : String := Key; begin for I in Key loop Result.Replace_Unicode (I, To_Lower_Case (Key (I))); end loop; return Result; end Norm; Left_Key : constant String := Norm (Get_Key (Catalog, Left.Index)); Right_Key : constant String := Norm (Get_Key (Catalog, Right.Index)); begin return Left_Key < Right_Key; end "<"; -------------- -- Scan_Key -- -------------- procedure Scan_Key (Catalog : Catalog_Type; Facility : String; Key : String; Locales : Locale_Definitions_Map) is pragma Unreferenced (Facility); N_Args : constant Natural := Message_Arg_Count (Base_Locale, Locales); use Key_Descriptor_Vectors; New_Descriptor : Key_Descriptor_Type := (Index => Get_Key_Index (Catalog, Key), N_Args => N_Args, others => <>); begin if Is_Ada_Identifier_OK (Key) then Copy_Argument_Types (Base_Locale, Locales, N_Args, New_Descriptor.Arg_Types); Key_Descriptors.Append (New_Descriptor); if N_Args > Max_Args then Max_Args := N_Args; end if; end if; end Scan_Key; begin Max_Args := 0; Message_Iterate (Handler, Facility, Scan_Key'Access); Key_Sorting.Sort (Key_Descriptors); end Create_Key_Descriptors; ----------------------- -- Message_Arg_Count -- ----------------------- function Message_Arg_Count (Base_Locale : String; Locales : Locale_Definitions_Map) return Natural is use Locale_Definitions_Package; Result : Natural := 0; procedure Count_Args (Position : Cursor); procedure Count_Args (Position : Cursor) is begin Result := Natural'Max (Result, Natural (String_Vectors.Length (Element (Position).Arg_Types))); end Count_Args; begin if Has_Element (Locales.Find (Base_Locale)) then -- Base locale defined for the message, return the number of args -- for the base message. Result := Natural (String_Vectors.Length (Element (Locales.Find (Base_Locale)).Arg_Types)); else -- No base message, iterate over the defined locales returning -- the maximum number used for any locale. Locales.Iterate (Count_Args'Access); end if; return Result; end Message_Arg_Count; --------------------------- -- Write_Base_Message_Text -- --------------------------- procedure Write_Base_Message_Text (File : File_Type; Catalog : Catalog_Type; Facility : String; Key : String; Base_Locale : String; Block_Size : Positive) is begin Write_Commented_Text (File, Get_Text (Catalog, Facility, Key, Make_Locale (Base_Locale)), Block_Size); exception when No_Such_Message_Error | No_Such_Locale_Error => Print_Line (File, ZBMBase_Facility, "10022"); end Write_Base_Message_Text; end ZBMCompile.Codegen.Accessors;