------------------------------------------------------------------------------ -- -- -- ASIS UTILITY LIBRARY COMPONENTS -- -- -- -- A S I S _ U L . M I S C -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2016, AdaCore -- -- -- -- Asis Utility Library (ASIS UL) 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 3, or (at your -- -- option) any later version. ASIS UL 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 GNAT; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- -- -- -- ASIS UL is maintained by AdaCore (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Containers.Indefinite_Hashed_Sets; with Ada.Strings.Hash; with Ada.Strings.Fixed; with Ada.Text_IO; use Ada.Text_IO; with Ada.Wide_Characters.Unicode; with GNAT.OS_Lib; use GNAT.OS_Lib; with ASIS_UL.Common; use ASIS_UL.Common; with ASIS_UL.Output; use ASIS_UL.Output; package body ASIS_UL.Misc is ----------------------- -- Local subprograms -- ----------------------- function Non_Case_Sensitive_Is_Equal (Left, Right : String) return Boolean; -- Non-case-sensitive string equality check -------------------------- -- ASIS_Index_Non_Blank -- -------------------------- function ASIS_Index_Non_Blank (Source : String; Going : Direction := Forward) return Natural is begin if Going = Forward then for J in Source'Range loop if not Is_White_Space (Source (J)) then return J; end if; end loop; else -- Going = Backward for J in reverse Source'Range loop if not Is_White_Space (Source (J)) then return J; end if; end loop; end if; -- Fall through if no match return 0; end ASIS_Index_Non_Blank; function ASIS_Index_Non_Blank (Source : Wide_String; Going : Direction := Forward) return Natural is begin if Going = Forward then for J in Source'Range loop if not Is_White_Space (Source (J)) then return J; end if; end loop; else -- Going = Backward for J in reverse Source'Range loop if not Is_White_Space (Source (J)) then return J; end if; end loop; end if; -- Fall through if no match return 0; end ASIS_Index_Non_Blank; --------------- -- ASIS_Trim -- --------------- function ASIS_Trim (Source : String) return String is Low, High : Integer := 0; begin for J in Source'Range loop if not Is_White_Space (Source (J)) then Low := J; exit; end if; end loop; if Low = 0 then -- Only white spaces, so return ""; end if; for J in reverse Source'Range loop if not Is_White_Space (Source (J)) then High := J; exit; end if; end loop; return Source (Low .. High); end ASIS_Trim; function ASIS_Trim (Source : Wide_String) return Wide_String is Low, High : Integer := 0; begin for J in Source'Range loop if not Is_White_Space (Source (J)) then Low := J; exit; end if; end loop; if Low = 0 then -- Only white spaces, so return ""; end if; for J in reverse Source'Range loop if not Is_White_Space (Source (J)) then High := J; exit; end if; end loop; return Source (Low .. High); end ASIS_Trim; ------------------------------ -- Get_Nat_Switch_Parameter -- ------------------------------ function Get_Nat_Switch_Parameter (Val : String) return Natural is Result : Natural := 0; begin Result := Natural'Value (Val); return Result; exception when Constraint_Error => Error ("wrong switch parameter " & Val); raise Parameter_Error; end Get_Nat_Switch_Parameter; ----------- -- Image -- ----------- function Image (I : Integer) return String is begin return Ada.Strings.Fixed.Trim (Integer'Image (I), Ada.Strings.Both); end Image; ----------------- -- Is_Ada_Name -- ----------------- function Is_Ada_Name (S : Wide_String) return Boolean is Result : Boolean := Is_Identifier (S); begin if not Result and then S /= "" then declare S_Last : constant Natural := S'Last; Word_Start : Natural := S'First; Next_Dot : Natural; procedure Set_Next_Dot; -- Sets Next_Dot pointing to the next dot character that follows -- Word_Start. Sets Next_Dot to Word_Start if Word_Start points to -- dot. Sets Next_Dot to S_Last + 1if there is no dot character -- after Word_Start. procedure Set_Next_Dot is begin Next_Dot := S_Last + 1; for J in Word_Start .. S_Last loop if S (J) = '.' then Next_Dot := J; exit; end if; end loop; end Set_Next_Dot; begin Result := True; Set_Next_Dot; while Word_Start <= S_Last loop if not Is_Identifier (S (Word_Start .. Next_Dot - 1)) then Result := False; exit; end if; Word_Start := Next_Dot + 1; Set_Next_Dot; end loop; if S (S_Last) = '.' then Result := False; end if; end; end if; return Result; end Is_Ada_Name; ------------------- -- Is_Identifier -- ------------------- function Is_Identifier (S : Wide_String) return Boolean is Result : Boolean := False; begin if S'Length > 0 and then Ada.Wide_Characters.Unicode.Is_Letter (S (S'First)) then Result := Is_Identifier_Suffix (S (S'First + 1 .. S'Last)); end if; return Result; end Is_Identifier; -------------------------- -- Is_Identifier_Prefix -- -------------------------- function Is_Identifier_Prefix (Prefix : Wide_String) return Boolean is Result : Boolean := True; Last_Char_Was_Underline : Boolean := False; begin if Prefix'Length = 0 then return True; end if; if Prefix (Prefix'First) = '_' or else Ada.Wide_Characters.Unicode.Is_Digit (Prefix (Prefix'First)) then return False; end if; for J in Prefix'Range loop if Ada.Wide_Characters.Unicode.Is_Letter (Prefix (J)) or else Ada.Wide_Characters.Unicode.Is_Digit (Prefix (J)) then Last_Char_Was_Underline := False; elsif Prefix (J) = '_' then if Last_Char_Was_Underline then Result := False; exit; else Last_Char_Was_Underline := True; end if; else Result := False; exit; end if; end loop; return Result; end Is_Identifier_Prefix; -------------------------- -- Is_Identifier_Suffix -- -------------------------- function Is_Identifier_Suffix (Suffix : Wide_String) return Boolean is Result : Boolean := True; Last_Char_Was_Underline : Boolean := False; begin if Suffix'Length = 0 then return True; end if; for J in Suffix'Range loop if Ada.Wide_Characters.Unicode.Is_Letter (Suffix (J)) or else Ada.Wide_Characters.Unicode.Is_Digit (Suffix (J)) then Last_Char_Was_Underline := False; elsif Suffix (J) = '_' then if Last_Char_Was_Underline then Result := False; exit; else Last_Char_Was_Underline := True; end if; else Result := False; exit; end if; end loop; if Result then Result := Suffix (Suffix'Last) /= '_'; end if; return Result; end Is_Identifier_Suffix; -------------------- -- Is_White_Space -- -------------------- function Is_White_Space (Ch : Character) return Boolean is begin return Ch = ' ' or else Ch = ASCII.HT; end Is_White_Space; function Is_White_Space (WCh : Wide_Character) return Boolean is begin return WCh = ' ' or else To_Character (WCh) = ASCII.HT; end Is_White_Space; --------------------------------- -- Non_Case_Sensitive_Is_Equal -- --------------------------------- function Non_Case_Sensitive_Is_Equal (Left, Right : String) return Boolean is Result : Boolean := False; begin if Left'Length = Right'Length then Result := To_Lower (Left) = To_Lower (Right); end if; return Result; end Non_Case_Sensitive_Is_Equal; --------------------- -- Parse_File_List -- --------------------- procedure Parse_File_List (File_List_Name : String) is Arg_File : File_Type; File_Name_Buffer : String (1 .. 16 * 1024); File_Name_Len : Natural := 0; Next_Ch : Character; End_Of_Line : Boolean; Tmp_Str : String_Access; function Get_File_Name return String; -- Reads from Par_File_Name the name of the next file (the file to read -- from should exist and be opened). Returns an empty string if there is -- no file names in Par_File_Name any more function Get_File_Name return String is begin File_Name_Len := 0; if not End_Of_File (Arg_File) then Get (Arg_File, Next_Ch); while Is_White_Space (Next_Ch) or else Next_Ch = ASCII.LF or else Next_Ch = ASCII.CR loop exit when End_Of_File (Arg_File); Get (Arg_File, Next_Ch); end loop; -- If we are here. Next_Ch is neither a white space nor -- end-of-line character. Two cases are possible, they require -- different processing: -- -- 1. Next_Ch = '"', this means that the file name is surrounded -- by quotation marks and it can contain spaces inside. -- -- 2. Next_Ch /= '"', this means that the file name is bounded by -- a white space or end-of-line character if Next_Ch = '"' then -- We do not generate any warning for badly formatted content -- of the file such as -- -- file_name_1 -- "file name 2 -- file_name_3 -- -- (We do not check that quotation marks correctly go by pairs) -- Skip leading '"' Get (Arg_File, Next_Ch); while not (Next_Ch = '"' or else Next_Ch = ASCII.LF or else Next_Ch = ASCII.CR) loop File_Name_Len := File_Name_Len + 1; File_Name_Buffer (File_Name_Len) := Next_Ch; Look_Ahead (Arg_File, Next_Ch, End_Of_Line); exit when End_Of_Line or else End_Of_File (Arg_File); Get (Arg_File, Next_Ch); end loop; if Next_Ch = '"' and then not Ada.Text_IO.End_Of_Line (Arg_File) then -- skip trailing '"' Get (Arg_File, Next_Ch); end if; else while not (Is_White_Space (Next_Ch) or else Next_Ch = ASCII.LF or else Next_Ch = ASCII.CR) loop File_Name_Len := File_Name_Len + 1; File_Name_Buffer (File_Name_Len) := Next_Ch; Look_Ahead (Arg_File, Next_Ch, End_Of_Line); exit when End_Of_Line or else End_Of_File (Arg_File); Get (Arg_File, Next_Ch); end loop; end if; end if; return File_Name_Buffer (1 .. File_Name_Len); end Get_File_Name; begin Open (Arg_File, In_File, File_List_Name); Tmp_Str := new String'(Get_File_Name); while Tmp_Str.all /= "" loop Process_File (Tmp_Str.all); Free (Tmp_Str); Tmp_Str := new String'(Get_File_Name); end loop; Free (Tmp_Str); end Parse_File_List; ----------------- -- Proper_Case -- ----------------- function Proper_Case (S : String) return String is Result : String := S; After_Underscore : Boolean := False; begin Result (Result'First) := To_Upper (Result (Result'First)); for J in Result'First + 1 .. Result'Last loop if Result (J) = '_' then After_Underscore := True; else if After_Underscore then Result (J) := To_Upper (Result (J)); After_Underscore := False; else Result (J) := To_Lower (Result (J)); end if; end if; end loop; return Result; end Proper_Case; ------------------- -- Remove_Spaces -- ------------------- function Remove_Spaces (S : String) return String is Result : String (1 .. S'Length); Res_Last : Natural := 0; begin for J in S'Range loop if not Is_White_Space (S (J)) then Res_Last := Res_Last + 1; Result (Res_Last) := S (J); end if; end loop; return Result (1 .. Res_Last); end Remove_Spaces; ------------------------------ -- Simple_String_Dictionary -- ------------------------------ package body Simple_String_Dictionary is package Dictionaries is new Ada.Containers.Indefinite_Hashed_Sets (Element_Type => String, Hash => Ada.Strings.Hash, Equivalent_Elements => Non_Case_Sensitive_Is_Equal, "=" => Non_Case_Sensitive_Is_Equal); Dictionary : Dictionaries.Set; Iterator : Dictionaries.Cursor := Dictionaries.No_Element; ----------------------- -- Add_To_Dictionary -- ----------------------- procedure Add_To_Dictionary (S : String) is begin Dictionaries.Include (Dictionary, S); end Add_To_Dictionary; ------------ -- Clear -- ------------ procedure Clear is begin Dictionaries.Clear (Dictionary); end Clear; ---------- -- Done -- ---------- function Done return Boolean is begin return not Dictionaries.Has_Element (Iterator); end Done; -------------- -- Is_Empty -- -------------- function Is_Empty return Boolean is begin return Dictionaries.Is_Empty (Dictionary); end Is_Empty; ---------------------- -- Is_In_Dictionary -- ---------------------- function Is_In_Dictionary (S : String) return Boolean is begin return Dictionaries.Contains (Dictionary, S); end Is_In_Dictionary; ---------------- -- Next_Entry -- ---------------- function Next_Entry return String is Result : constant String := Dictionaries.Element (Iterator); begin Iterator := Dictionaries.Next (Iterator); return Result; end Next_Entry; ---------------------- -- Print_Dictionary -- ---------------------- procedure Print_Dictionary is Next_Item : Dictionaries.Cursor; begin Put_Line (Standard_Error, "Content of dictionary " & Dictionary_Name); if Is_Empty then Put_Line (Standard_Error, "Empty"); else Next_Item := Dictionaries.First (Dictionary); while Dictionaries.Has_Element (Next_Item) loop Put (Standard_Error, ">>"); Put (Standard_Error, Dictionaries.Element (Next_Item)); Put_Line (Standard_Error, "<<"); Next_Item := Dictionaries.Next (Next_Item); end loop; end if; end Print_Dictionary; ---------------------------- -- Remove_From_Dictionary -- ---------------------------- procedure Remove_From_Dictionary (S : String) is begin Dictionaries.Exclude (Dictionary, S); end Remove_From_Dictionary; -------------------- -- Reset_Iterator -- -------------------- procedure Reset_Iterator is begin Iterator := Dictionaries.First (Dictionary); end Reset_Iterator; end Simple_String_Dictionary; --------------- -- Lock_File -- --------------- procedure Lock_File (Lock_File_Name : Lock_Files.Path_Name) is begin Lock_Files.Lock_File (Lock_File_Name, Wait => 0.1, Retries => 2 * 60 * 10); -- Retry for 2 minutes, every 100 milliseconds. end Lock_File; procedure Unlock_File (Lock_File_Name : Lock_Files.Path_Name) is begin Lock_Files.Unlock_File (Lock_File_Name); end Unlock_File; ----------------------- -- String_Hash_Table -- ----------------------- package body String_Hash_Table is ---------- -- Hash -- ---------- function Hash (Name : String) return Hash_Index_Type is subtype Int_1_12 is Int range 1 .. 12; -- Used to avoid when others on case jump below Even_Name_Len : Integer; -- Last even numbered position (used for >12 case) -- We take one-to-one the code of the Hash function from Namet -- (namet.adb, rev. 1.90). Namet.Hash function works on the name -- buffer defined in Namet. We simulate this buffer by defining the -- following variables (note converting the argument string to lower -- case before computing the hash value): Name_Buffer : constant String := To_Lower (Name); -- Note, that out Has function is not case-sensitive! Name_Len : constant Natural := Name_Buffer'Last; begin -- Special test for 12 (rather than counting on a when others for the -- case statement below) avoids some Ada compilers converting the -- case statement into successive jumps. -- The case of a name longer than 12 characters is handled by taking -- the first 6 odd numbered characters and the last 6 even numbered -- characters if Name_Len > 12 then Even_Name_Len := (Name_Len) / 2 * 2; return (((((((((((( Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 + Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 + Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 + Character'Pos (Name_Buffer (11))) * 2 + Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num; end if; -- For the cases of 1-12 characters, all characters participate in -- the hash. The positioning is randomized, with the bias that -- characters later on participate fully (i.e. are added towards the -- right side). case Int_1_12 (Name_Len) is when 1 => return Character'Pos (Name_Buffer (1)); when 2 => return (( Character'Pos (Name_Buffer (1))) * 64 + Character'Pos (Name_Buffer (2))) mod Hash_Num; when 3 => return ((( Character'Pos (Name_Buffer (1))) * 16 + Character'Pos (Name_Buffer (3))) * 16 + Character'Pos (Name_Buffer (2))) mod Hash_Num; when 4 => return (((( Character'Pos (Name_Buffer (1))) * 8 + Character'Pos (Name_Buffer (2))) * 8 + Character'Pos (Name_Buffer (3))) * 8 + Character'Pos (Name_Buffer (4))) mod Hash_Num; when 5 => return ((((( Character'Pos (Name_Buffer (4))) * 8 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (3))) * 4 + Character'Pos (Name_Buffer (5))) * 8 + Character'Pos (Name_Buffer (2))) mod Hash_Num; when 6 => return (((((( Character'Pos (Name_Buffer (5))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (4))) * 4 + Character'Pos (Name_Buffer (2))) * 4 + Character'Pos (Name_Buffer (6))) * 4 + Character'Pos (Name_Buffer (3))) mod Hash_Num; when 7 => return ((((((( Character'Pos (Name_Buffer (4))) * 4 + Character'Pos (Name_Buffer (3))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (2))) * 2 + Character'Pos (Name_Buffer (5))) * 2 + Character'Pos (Name_Buffer (7))) * 2 + Character'Pos (Name_Buffer (6))) mod Hash_Num; when 8 => return (((((((( Character'Pos (Name_Buffer (2))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (3))) * 2 + Character'Pos (Name_Buffer (5))) * 2 + Character'Pos (Name_Buffer (7))) * 2 + Character'Pos (Name_Buffer (6))) * 2 + Character'Pos (Name_Buffer (4))) * 2 + Character'Pos (Name_Buffer (8))) mod Hash_Num; when 9 => return ((((((((( Character'Pos (Name_Buffer (2))) * 4 + Character'Pos (Name_Buffer (1))) * 4 + Character'Pos (Name_Buffer (3))) * 4 + Character'Pos (Name_Buffer (4))) * 2 + Character'Pos (Name_Buffer (8))) * 2 + Character'Pos (Name_Buffer (7))) * 2 + Character'Pos (Name_Buffer (5))) * 2 + Character'Pos (Name_Buffer (6))) * 2 + Character'Pos (Name_Buffer (9))) mod Hash_Num; when 10 => return (((((((((( Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (02))) * 2 + Character'Pos (Name_Buffer (08))) * 2 + Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (04))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (06))) * 2 + Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (10))) mod Hash_Num; when 11 => return ((((((((((( Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (06))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (08))) * 2 + Character'Pos (Name_Buffer (02))) * 2 + Character'Pos (Name_Buffer (10))) * 2 + Character'Pos (Name_Buffer (04))) * 2 + Character'Pos (Name_Buffer (11))) mod Hash_Num; when 12 => return (((((((((((( Character'Pos (Name_Buffer (03))) * 2 + Character'Pos (Name_Buffer (02))) * 2 + Character'Pos (Name_Buffer (05))) * 2 + Character'Pos (Name_Buffer (01))) * 2 + Character'Pos (Name_Buffer (06))) * 2 + Character'Pos (Name_Buffer (04))) * 2 + Character'Pos (Name_Buffer (08))) * 2 + Character'Pos (Name_Buffer (11))) * 2 + Character'Pos (Name_Buffer (07))) * 2 + Character'Pos (Name_Buffer (09))) * 2 + Character'Pos (Name_Buffer (10))) * 2 + Character'Pos (Name_Buffer (12))) mod Hash_Num; end case; end Hash; end String_Hash_Table; ------------------- -- To_Lower_Case -- ------------------- function To_Lower_Case (S : Wide_String) return Wide_String is Result : Wide_String (S'Range); begin for J in Result'Range loop Result (J) := Ada.Wide_Characters.Unicode.To_Lower_Case (S (J)); end loop; return Result; end To_Lower_Case; ------------------- -- To_Upper_Case -- ------------------- function To_Upper_Case (S : Wide_String) return Wide_String is Result : Wide_String (S'Range); begin for J in Result'Range loop Result (J) := Ada.Wide_Characters.Unicode.To_Upper_Case (S (J)); end loop; return Result; end To_Upper_Case; end ASIS_UL.Misc;