----------------------------------------------------------------------
--  Dictionary - Package body                                       --
--  Copyright (C) 2002 Adalog                                       --
--  Author: J-P. Rosen                                              --
--                                                                  --
--  ADALOG   is   providing   training,   consultancy,   expertise, --
--  assistance and custom developments  in Ada and related software --
--  engineering techniques.  For more info about our services:      --
--  ADALOG                   Tel: +33 1 41 24 31 40                 --
--  19-21 rue du 8 mai 1945  Fax: +33 1 41 24 07 36                 --
--  94110 ARCUEIL            E-m: info@adalog.fr                    --
--  FRANCE                   URL: http://www.adalog.fr              --
--                                                                  --
--  This  unit 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.  This  unit 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 this program; see file --
--  COPYING.   If not, write  to the  Free Software  Foundation, 59 --
--  Temple Place - Suite 330, Boston, MA 02111-1307, 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.                                                 --
----------------------------------------------------------------------

with -- Standard Ada units
  Ada.Characters.Handling,
  Ada.Strings.Wide_Maps,
  Ada.Strings.Wide_Fixed,
  Ada.Wide_Text_IO;

with -- ASIS units
  Asis.Declarations,
  Asis.Text;

with -- Application specific units
  Utilities,
  Thick_Queries,
  Dictionary.Scanner,
  Dictionary.Table_Manager;
package body Dictionary is
   use Utilities, Dictionary.Table_Manager;
   use Ada.Strings.Wide_Maps;

   --
   -- Element Table stores substitution from the $elements$ section,
   -- Identifier_Table stores substitution from the $identifiers$ section.
   -- When an overloaded name is entered in a table, the corresponding non-overloaded
   -- name is also entered, and the entry is flagged to note that there exists (at least)
   -- one overloaded name for this name.
   -- This avoids looking up the tables for overloaded names for every identifier.
   --
   Element_Table    : Table;
   Identifier_Table : Table;

   To_Question : constant Wide_Character_Mapping := To_Mapping (",", "?");

   ----------------------
   -- Has_Substitution --
   ----------------------

   function Has_Substitution (E : Asis.Defining_Name; Kind : Substitution_Kind := Name) return Boolean is
      use Thick_Queries, Asis.Declarations;
      Dict_Data : Dictionary_Data_Access;
   begin
      Dict_Data := Fetch (To_Upper (Full_Name_Image (E)), From => Element_Table);
      if Dict_Data /= null and then
        Dict_Data.Has_Overloading and then
        Is_Present (To_Upper (Full_Name_Image (E, With_Profile => True)),
                    Into => Element_Table)
      then
         Dict_Data := Fetch (To_Upper (Full_Name_Image (E, With_Profile => True)),
                             From => Element_Table);
      end if;

      if Dict_Data = null or else Dict_Data.Substitution = Undefined then
         -- not found
         case Kind is
            when Short | Name =>
               -- Try Identifier substitution
               Dict_Data := Fetch (To_Upper (Defining_Name_Image (E)), From => Identifier_Table);
               if Dict_Data = null then
                  return False;
               end if;

               if Dict_Data.Has_Overloading and then
                 Is_Present (To_Upper (Defining_Name_Image (E) & Profile_Image (E)),
                             Into => Identifier_Table)
              then
                 Dict_Data := Fetch (To_Upper (Defining_Name_Image (E) & Profile_Image(E)),
                                     From => Identifier_Table);
              end if;
            when Qualified =>
               -- No identifier substitution for qualified name
               return False;
         end case;
      end if;

      case Dict_Data.Substitution is
         when Present =>
            case Kind is
               when Short | Name =>
                  return True;
               when Qualified =>
                  return Dict_Data.Params.Absolute or Dict_Data.Params.Location_Length > 0;
            end case;
         when None | Undefined =>
            return False;
      end case;
   end Has_Substitution;

   ----------------
   -- Initialize --
   ----------------

   -- Reads the dictionary in from the file with the given name

   -- Grammar:

   -- Specification   ::= <Original> "=>" <Substitute> |
   --                     "not" <Original>

   -- Original        ::=  <Full_Name> | "all" <Typed_Name>
   -- Full_Name       ::= <Typed_Name> [ "." <Full_Name>]
   -- Typed_Name      ::= <Identifier> [ "{" [<Profile>] "}" ]
   -- Profile         ::= "return" <Full_Name> | <Profile_List> [ "return" <Full_Name>]
   -- Profile_List    ::= ["access"] <Full_Name> [";" <Profile_list>]

   -- Substitute      ::= ["abs"] <Full_Name> [ [","] <Substitute_List>] |
   --                     [<Full_Name>] [ "in" <Full_Name>]
   -- Substitute_List ::= <Full_Name> [[","] <Substitute_List>]

   -- Rules not expressed by grammar:
   -- Overloaded names and qualified names not allowed in Identifiers section

   procedure Initialize (Dictionary_Name : String) is
      use Ada.Wide_Text_IO, Dictionary.Scanner;

      F          : File_Type;
      Had_Errors : Boolean  := False;

      -- Information set by the parsing functions:
      With_All   : Boolean;
      Qualified  : Boolean;
      Overloaded : Boolean;

      -- Invariants for the following parsing functions:
      -- On entrance, Current_Token is the first token of the corresponding syntax
      --   This is checked by the function itself, not the caller.
      -- On exit, Current_Token is the first token not in the corresponding syntax

      -- Forward declaration:
      function Full_Name return Wide_String;

      function Identifier return Wide_String is
      begin
         declare
            Name : constant Wide_String := Current_Name;
         begin
            Next_Token;
            return Name;
         end;
      exception
         when Constraint_Error =>
            -- Raised by Current_Name if Current_Token.Kind /= Name
            Error ("Identifier expected");
      end Identifier;

      function Substitute_List return Wide_String is
         Name1 : constant Wide_String := Full_Name;
      begin
         if Current_Token.Kind = Comma then
            Next_Token;
            return Name1 & ", " & Substitute_List;
         elsif Current_Token.Kind = Name then
            return Name1 & ", " & Substitute_List;
         else
            return Name1;
         end if;
      end Substitute_List;

      function Substitute return Substitution_Params is
         Absolute : Boolean := False;
         No_Name  : Boolean := False;
      begin
         if Current_Token.Kind = Keyword then
           case Current_Token.Key is
              when Key_Abs =>
                 Absolute := True;
              when Key_In =>
                 No_Name := True;
              when others =>
                Error ("Unexpected keyword: " & Key_Kind'Wide_Image (Current_Token.Key));
           end case;
           Next_Token;
         end if;

         declare
            Name1 : constant Wide_String := Full_Name;
         begin
            if No_Name then
               -- "in" <Full_Name>
               return (Name_Length     => 0,
                       Location_Length => Name1'Length,
                       Name            => "",
                       Location        => Name1,
                       Absolute        => False,
                       Multiple        => False);
            end if;

            case Current_Token.Kind is
               when Comma =>
                  -- ["abs"] <Full_Name> "," <Substitute_List>]
                  -- (always absolute, regardless of "abs")
                  Next_Token;
                  declare
                     Name2 : constant Wide_String := Name1 & ", " & Substitute_List;
                  begin
                     return (Name_Length     => Name2'length,
                             Location_Length => 0,
                             Name            => Name2,
                             Location        => "",
                             Absolute => True,
                             Multiple => True);
                  end;
               when Name =>
                  -- ["abs"] <Full_Name> <Substitute_List>]
                  -- (always absolute, regardless of "abs")
                  declare
                     Name2 : constant Wide_String := Name1 & ", " & Substitute_List;
                  begin
                     return (Name_Length     => Name2'length,
                             Location_Length => 0,
                             Name            => Name2,
                             Location        => "",
                             Absolute => True,
                             Multiple => True);
                  end;
               when Keyword =>
                  if Current_Token.Key = Key_In then
                     -- <Full_Name> "in" <Full_Name>
                     if Absolute then
                        Error ("""abs"" not allowed with ""in""");
                     end if;
                     Next_Token;

                     declare
                        Name2 : constant Wide_String := Full_Name;
                     begin
                        return (Name_Length     => Name1'length,
                                Location_Length => Name2'Length,
                                Name            => Name1,
                                Location        => Name2,
                                Absolute => False,
                                Multiple => False);
                     end;
                  else
                     Error ("Unexpected keyword: " & Key_Kind'Wide_Image (Current_Token.Key));
                  end if;
               when Eol | Eof =>
                     -- ["abs"] <Full_Name>
                     return (Name_Length     => Name1'length,
                             Location_Length => 0,
                             Name            => Name1,
                             Location        => "",
                             Absolute => Absolute,
                             Multiple => False);
               when others =>
                  Error ("Unexpected " & Token_Kind'Wide_Image (Current_Token.Kind));
            end case;
         end;
      end Substitute;

      function Profile_List return Wide_String is
         With_Access : Boolean := False;
      begin
         if Current_Token.Kind = Keyword and then Current_Token.Key = Key_Access then
            With_Access := True;
            Next_Token;
         end if;

         -- If not qualified, assume the identifier is declared in Standard
         Qualified := False;
         declare
            Name1 : constant Wide_String := Full_Name;

            function Formated_Name return Wide_String is
            begin
               if Qualified then
                  if With_Access then
                     return '*' & Name1;
                  else
                     return Name1;
                  end if;
               else
                  if With_Access then
                     return '*' & "STANDARD." & Name1;
                  else
                     return "STANDARD." & Name1;
                  end if;
               end if;
            end Formated_Name;
         begin
            if Current_Token.Kind = Semi_Colon then
               Next_Token;
               return Formated_Name & ';' & Profile_List;
            else
               return Formated_Name;
            end if;
         end;
      end Profile_List;

      function Profile return Wide_String is
      begin
         if Current_Token.Kind = Keyword and then Current_Token.Key = Key_Return then
            Next_Token;
            Qualified := False;
            declare
               Result_Type : constant Wide_String := Full_Name;
            begin
               -- If not qualified, assume the identifier is declared in Standard
               if not Qualified then
                  return ':' & "STANDARD." & Result_Type;
               else
                  return ':' & Result_Type;
               end if;
            end;
         end if;

         declare
            List1 : constant Wide_String := Profile_List;
         begin
            if Current_Token.Kind = Keyword and then Current_Token.Key = Key_Return then
               Next_Token;
               Qualified := False;
               declare
                  Result_Type : constant Wide_String := Full_Name;
               begin
                  -- If not qualified, assume the identifier is declared in Standard
                  if not Qualified then
                     return List1 & ':' & "STANDARD." & Result_Type;
                  else
                     return List1 & ':' & Result_Type;
                  end if;
               end;
            else
               return List1;
            end if;
         end;
      end Profile;

      function Typed_Name return Wide_String is
         Name1 : constant Wide_String := Identifier;
      begin
         if Current_Token.Kind = Left_Bracket then
            Next_Token;
            Overloaded := True;
            if Current_Token.Kind = Right_Bracket then
               Next_Token;
               return Name1 & "{}";
            else
               declare
                  Profile1 : constant Wide_String := Profile;
               begin
                  if Current_Token.Kind = Right_Bracket then
                     Next_Token;
                  else
                     Error ("Missing ""}""");
                  end if;
                  return Name1 & '{' & Profile1 & '}';
               end;
            end if;
         else
            return Name1;
         end if;
      end Typed_Name;

      function Full_Name return Wide_String is
         Ident1 : constant Wide_String := Typed_Name;
      begin
         if Current_Token.Kind = Period then
            Next_Token;
            Qualified := True;
            return Ident1 & '.' & Full_Name;
         else
            return Ident1;
         end if;
      end Full_Name;

      function Original return Wide_String is
      begin
         if Current_Token.Kind = Keyword and then Current_Token.Key = Key_All then
            With_All := True;
            Next_Token;
            return Typed_Name;
         else
            With_All := False;
            return Full_Name;
         end if;
      end Original;

      procedure Specification is
         procedure Enter (Original   : Wide_String;
                          Substitute : Substitution_Params;
                          Overloaded : Boolean;
                          Into       : in out Table) is
            use Ada.Strings.Wide_Fixed;
            Data : Dictionary_Data_Access;

            function Remove_Profile (Name : Wide_String) return Wide_String is
               -- Remove everythign between {} from name.
               -- Of course, brackets can be nested.
               Result : Wide_String (Name'Range);
               Bracket_Depth : Natural := 0;
               Out_Inx : Natural := Result'First - 1;
            begin
               for In_Inx in Name'Range loop
                  case Name (In_Inx) is
                     when '{' =>
                        Bracket_Depth := Bracket_Depth + 1;
                     when '}' =>
                        Bracket_Depth := Bracket_Depth - 1;
                     when others =>
                        if Bracket_Depth = 0 then
                           Out_Inx := Out_Inx + 1;
                           Result (Out_Inx) := Name (In_Inx);
                        end if;
                  end case;
               end loop;
               return Result (Result'First .. Out_Inx);
            end Remove_Profile;

            Subst : Data_Substitution_Kind;
         begin   -- Enter
            Trace (Original & " => " & Substitute.Name & " in " & Substitute.Location);

            if Substitute = Null_Params then
               Subst := None;
            else
               Subst := Present;
            end if;

            Data := Fetch (Original, From => Into);
            if Data = null then
               -- Entry not present, add the real entry:
               Add (Original,
                    (Name_Length     => Substitute.Name_Length,
                     Location_Length => Substitute.Location_Length,
                     Substitution    => Subst,
                     Has_Overloading => False,
                     Params          => Substitute),
                    To => Into);
            elsif Data.Substitution /= Undefined then
               -- Real entry already there
               raise Already_Present;
            else
               -- Dummy entry because we had an overloaded one
               Assert (Data.Has_Overloading, "Entry without simple or overloaded name");
               Replace (Original,
                        (Name_Length     => Substitute.Name_Length,
                         Location_Length => Substitute.Location_Length,
                         Substitution    => Subst,
                         Has_Overloading => True,
                         Params          => Substitute),
                        Into => Into);
            end if;


            -- Add or modify the corresponding non overloaded entry if necessary:
            if Overloaded then
               declare
                  Simple_Name : constant Wide_String := Remove_Profile (Original);
               begin
                  Data := Fetch (Simple_Name, From => Into);
                  if Data = null then
                     -- Not found
                     Add (Simple_Name,
                          (Name_Length     => Null_Params.Name_Length,
                           Location_Length => Null_Params.Location_Length,
                           Substitution    => Undefined,
                           Has_Overloading => True,
                           Params => Null_Params),
                          To => Into);
                  else
                     Data.Has_Overloading := True;
                  end if;
               end;
            end if;
         end Enter;

         Original_Overloaded : Boolean;
      begin   -- Specification
         Overloaded := False;
         if Current_Token.Kind = Keyword and then Current_Token.Key = Key_Not then
            -- "not" <Original>
            Next_Token;
            declare
               The_Original : constant Wide_String := To_Upper (Original);
            begin
               if With_All then
                  Enter (The_Original,
                         Null_Params,
                         Overloaded => Overloaded,
                         Into       => Identifier_Table);
               else
                  Enter (The_Original,
                         Null_Params,
                         Overloaded => Overloaded,
                         Into       => Element_Table);

               end if;
            end;

         else
            -- <Original> "=>" Substitute
            declare
               The_Original : constant Wide_String := To_Upper (Original);
            begin
               if Current_Token.Kind = Arrow then
                  Next_Token;
               else
                  Error ("Missing ""=>""");
               end if;

               Original_Overloaded := Overloaded;
               Overloaded          := False;
               declare
                  The_Substitute : constant Substitution_Params := Substitute;
               begin
                  if Overloaded then
                     Error ("Overloaded names not allowed for substitution");
                  end if;

                  if With_All then
                     Enter (The_Original,
                            The_Substitute,
                            Overloaded => Original_Overloaded,
                            Into       => Identifier_Table);
                  else
                     Enter (The_Original,
                            The_Substitute,
                            Overloaded => Original_Overloaded,
                            Into       => Element_Table);

                  end if;
               exception
                  when Already_Present =>
                     Error ("Double definition for " & The_Original);
               end;
            end;
         end if;
      end Specification;

      use Utilities, Ada.Strings.Wide_Fixed, Ada.Characters.Handling;
   begin   -- Initialize
      if Index (To_Wide_String (Dictionary_Name), Pattern => "=>") /= 0 then
         Start_Scan (To_Wide_String (Dictionary_Name));
      else
         if Dictionary_Name /= "-" then
            Open (F, Mode => In_File, Name => Dictionary_Name);
            Set_Input (F);
         end if;
         Start_Scan;
      end if;

      while Current_Token.Kind /= Eof loop
         begin
            Specification;

            if Current_Token.Kind not in EoL..Eof then
               Trace ("Token: " & Token_Kind'Wide_Image (Current_Token.Kind));
               Error ("End of line expected");
            end if;

         exception
            when Syntax_Error =>
               -- Skip everything till EoL
               Had_Errors := True;
               while Current_Token.Kind not in EoL..Eof loop
                  Next_Token;
               end loop;
         end;

         Next_Token;
      end loop;

      if Is_Open (F) then
         Set_Input (Standard_Input); -- Necessary to allow close
         Close (F);
      end if;

      if Had_Errors then
         raise Invalid_Dictionary;
      end if;

      -- Rebalance tables, now that they are fully built
      Balance (Element_Table);
      Balance (Element_Table);
      Balance (Identifier_Table);

   exception
      when Name_Error =>
         User_Message ("Unable to find " & To_Wide_String (Dictionary_Name));
         raise Invalid_Dictionary;
      when others =>
         if Is_Open (F) then
            Set_Input (Standard_Input); -- Necessary to allow close
            Close (F);
         end if;
         raise;
   end Initialize;

   ------------------
   -- Substitution --
   ------------------

   function Substitution (E            : Asis.Defining_Name;
                          Kind         : Substitution_Kind;
                          Multiplicity : Multiplicity_Kind := Single) return Wide_String is
      use Thick_Queries, Asis.Declarations, Ada.Strings, Ada.Strings.Wide_Fixed, Asis.Text;

      Dict_Data : Dictionary_Data_Access;
   begin    -- Substitution

      -- Look into Element_Table
      Dict_Data := Fetch (To_Upper (Full_Name_Image (E)), From => Element_Table);
      if Dict_Data /= null and then
        Dict_Data.Has_Overloading and then
        Is_Present (To_Upper (Full_Name_Image (E, With_Profile => True)),
                    Into => Element_Table)
      then
         Dict_Data := Fetch (To_Upper (Full_Name_Image (E, With_Profile => True)),
                             From => Element_Table);
      end if;

      if Dict_Data = null or else Dict_Data.Substitution = Undefined then
         if Kind = Qualified then
            -- Do not look in identifier tables if Qualified
            raise Not_Present;
         end if;

         -- Look into indentifier table
         Dict_Data := Fetch (To_Upper (Defining_Name_Image (E)), From => Identifier_Table);

         if Dict_Data = null then
            -- not found
            raise Not_Present;
         elsif Dict_Data.Has_Overloading and then Is_Present (To_Upper (Defining_Name_Image (E) & Profile_Image (E)),
                                                              Into => Identifier_Table)
         then
            Dict_Data := Fetch (To_Upper (Defining_Name_Image (E) & Profile_Image (E)),
                                From => Identifier_Table);
         end if;
      end if;

      if Dict_Data.Substitution /= Present then
         raise Not_Present;
      end if;

      -- At this point, we have the right substitution.
      -- Final check about allowed multiplicity and absolute value before returning.
      -- Also provide default name if not provided in substitution
      if Multiplicity = Single and Dict_Data.Params.Multiple then
         User_Message ("<<" &
                       Line_Number'Wide_Image (First_Line_Number (E)) &
                       ": Multiple substitution for " &
                       Defining_Name_Image (E) &
                       " not allowed in this context>>");
         return Translate (Dict_Data.Params.Name, To_Question);

      elsif Dict_Data.Params.Absolute then
         -- Always return full string if absolute
         -- Note: Multiple implies absolute
         return Dict_Data.Params.Name;

      else
         case Kind is
            when Name =>
               if Dict_Data.Name_Length = 0 then
                  return Defining_Name_Image (E);
               else
                  return Dict_Data.Params.Name (Index (Dict_Data.Params.Name,
                                                       ".",
                                                       Going => Backward) + 1 -- OK if not found
                                                .. Dict_Data.Params.Name_Length);
               end if;
            when Short =>
               if Dict_Data.Name_Length = 0 then
                  return Defining_Name_Image (E);
               else
                  return Dict_Data.Params.Name;
               end if;
            when Qualified =>
               if Dict_Data.Location_Length = 0 then
                  -- Missing qualification
                     raise Not_Present;
               end if;
               if Dict_Data.Name_Length = 0 then
                  return Dict_Data.Params.Location & "." & Defining_Name_Image (E);
               else
                  return Dict_Data.Params.Location & "." & Dict_Data.Params.Name;
               end if;
         end case;
      end if;

   exception
      when Not_Present =>
         Trace ("Not present, " & To_Upper (Defining_Name_Image (E) & Profile_Image (E)));
         raise;
   end Substitution;

end Dictionary;
