----------------------------------------
----------------------------------------
--                                                                          --
--                           OCARINA COMPONENTS                             --
--                                                                          --
--          O C A R I N A . G E N E R A T O R S . C _ V A L U E S           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                  Copyright (C) 2007, GET-Telecom Paris.                  --
--                                                                          --
-- Ocarina  is free software;  you  can  redistribute  it and/or  modify    --
-- it under terms of the GNU General Public License as published by the     --
-- Free Software Foundation; either version 2, or (at your option) any      --
-- later version. Ocarina is distributed  in  the  hope  that it will be    --
-- useful, but WITHOUT ANY WARRANTY;  without even the implied warranty of  --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details. You should have received  a copy of the --
-- GNU General Public License distributed with Ocarina; see file COPYING.   --
-- If not, write to the Free Software Foundation, 51 Franklin Street, Fifth --
-- Floor, Boston, MA 02111-1301, USA.                                       --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable to be   --
-- covered  by the  GNU  General  Public  License. This exception does not  --
-- however invalidate  any other reasons why the executable file might be   --
-- covered by the GNU Public License.                                       --
--                                                                          --
--                 Ocarina is maintained by the Ocarina team                --
--                       (ocarina-users@listes.enst.fr)                     --
--                                                                          --
------------------------------------------------------------------------------

with Namet; use Namet;

with Ocarina.AADL_Values;

with GNAT.Table;

package body Ocarina.Generators.C_Values is

   package OV renames Ocarina.AADL_Values;

   Hex : constant String := "0123456789ABCDEF";

   package VT is new GNAT.Table (value_type, value_id, No_Value + 1, 10, 10);

   subtype ull is unsigned_long_long;

   procedure Add_ULL_To_Name_Buffer (U : ull; B : ull; S : Integer := 1);

   ---------
   -- "*" --
   ---------

   function "*" (L, R : value_type) return value_type is
      V : value_type := L;
   begin
      case V.K is
         when k_int =>
            if L.Base = R.Base then
               V.Base := 10;
            end if;
            V.Sign := L.Sign * R.Sign;
            V.IVal := L.IVal * R.IVal;

         when k_float =>
            V.FVal := L.FVal * R.FVal;

         when others =>
            return Bad_Value;
      end case;
      return V;
   end "*";

   ---------
   -- "+" --
   ---------

   function "+" (L, R : value_type) return value_type is
      V : value_type := R;
   begin
      case R.K is
         when k_int =>
            if L.Base /= R.Base then
               V.Base := 10;
            end if;
            if L.Sign = R.Sign then
               V.IVal := L.IVal + R.IVal;
            elsif R.IVal <= L.IVal then
               V.Sign := L.Sign;
               V.IVal := L.IVal - R.IVal;
            else
               V.Sign := -L.Sign;
               V.IVal := R.IVal - L.IVal;
            end if;

         when k_float =>
            V.FVal := L.FVal + R.FVal;

         when others =>
            return Bad_Value;

      end case;
      return V;
   end "+";

   ---------
   -- "-" --
   ---------

   function "-" (R : value_type) return value_type is
      V : value_type := R;
   begin
      case R.K is
         when k_int =>
            V.Sign := -V.Sign;

         when k_float =>
            V.FVal := -V.FVal;

         when others =>
            return Bad_Value;

      end case;
      return V;
   end "-";

   ---------
   -- "-" --
   ---------

   function "-" (L, R : value_type) return value_type is
      V : value_type := R;
   begin
      case R.K is
         when k_int =>
            V.Sign := -V.Sign;

         when k_float =>
            V.FVal := -V.FVal;

         when others =>
            return Bad_Value;

      end case;
      return L + V;
   end "-";

   ---------
   -- "/" --
   ---------

   function "/" (L, R : value_type) return value_type is
      V : value_type := L;
   begin
      case V.K is
         when k_int =>
            if L.Base = R.Base then
               V.Base := 10;
            end if;
            V.Sign := L.Sign * R.Sign;
            V.IVal := L.IVal / R.IVal;

         when k_float =>
            V.FVal := L.FVal / R.FVal;

         when others =>
            return Bad_Value;
      end case;
      return V;
   end "/";

   ---------
   -- "<" --
   ---------

   function "<" (L, R : value_type) return Boolean is
   begin
      case R.K is
         when k_int =>
            if L.Sign > 0 then
               if R.Sign > 0 then
                  return L.IVal < R.IVal;
               else
                  return False;
               end if;
            elsif R.Sign > 0 then
               return True;
            else
               return L.IVal > R.IVal;
            end if;

         when k_float =>
            return L.FVal < R.FVal;

         when others =>
            return False;

      end case;
   end "<";

   -----------
   -- "and" --
   -----------

   function "and" (L, R : value_type) return value_type is
      LV : value_type := L;
      RV : value_type := R;
   begin
      case L.K is
         when k_int =>
            if LV.Base /= RV.Base then
               LV.Base := 10;
            end if;
            if LV.Sign < 0 then
               LV.IVal := lull - LV.IVal;
            end if;
            if RV.Sign < 0 then
               RV.IVal := lull - RV.IVal;
            end if;
            LV.IVal := LV.IVal and RV.IVal;
            LV.Sign := 1;

         when others =>
            return Bad_Value;
      end case;
      return LV;
   end "and";

   -----------
   -- "mod" --
   -----------

   function "mod" (L, R : value_type) return value_type is
      V : value_type := L;
   begin
      case L.K is
         when k_int =>
            if L.Base /= R.Base then
               V.Base := 10;
            end if;
            V.Sign := L.Sign * R.Sign;
            V.IVal := L.IVal mod R.IVal;

         when others =>
            return Bad_Value;
      end case;
      return V;
   end "mod";

   -----------
   -- "not" --
   -----------

   function "not" (R : value_type) return value_type is
      V : value_type := R;
   begin
      case V.K is
         when k_int =>
            V.IVal := unsigned_long_long (not unsigned_long (V.IVal));

         when others =>
            return Bad_Value;
      end case;
      return V;
   end "not";

   ----------
   -- "or" --
   ----------

   function "or" (L, R : value_type) return value_type is
      LV : value_type := L;
      RV : value_type := R;
   begin
      case L.K is
         when k_int =>
            if LV.Base /= RV.Base then
               LV.Base := 10;
            end if;
            if LV.Sign < 0 then
               LV.IVal := lull - LV.IVal;
            end if;
            if RV.Sign < 0 then
               RV.IVal := lull - RV.IVal;
            end if;
            LV.IVal := LV.IVal or RV.IVal;
            LV.Sign := 1;

         when others =>
            return Bad_Value;
      end case;
      return LV;
   end "or";

   -----------
   -- "xor" --
   -----------

   function "xor" (L, R : value_type) return value_type is
      LV : value_type := L;
      RV : value_type := R;
   begin
      case LV.K is
         when k_int =>
            if LV.Base /= RV.Base then
               LV.Base := 10;
            end if;
            if LV.Sign < 0 then
               LV.IVal := lull - LV.IVal;
            end if;
            if RV.Sign < 0 then
               RV.IVal := lull - RV.IVal;
            end if;
            LV.IVal := LV.IVal xor RV.IVal;
            LV.Sign := 1;

         when others =>
            return Bad_Value;
      end case;
      return LV;
   end "xor";

   ----------------------------
   -- Add_ULL_To_Name_Buffer --
   ----------------------------

   procedure Add_ULL_To_Name_Buffer (U : ull; B : ull; S : Integer := 1) is
      Q : constant ull := U / B;
      R : constant ull := U mod B;
   begin
      if Q /= 0 or else S > 1 then
         Add_ULL_To_Name_Buffer (Q, B, S - 1);
      end if;
      Add_Char_To_Name_Buffer (Hex (Hex'first + Natural (R)));
   end Add_ULL_To_Name_Buffer;

   -----------
   -- Image --
   -----------

   function Image (Value : value_id) return String is
      V : value_type;
   begin
      if Value = No_Value then
         return "<>";
      end if;
      V        := VT.Table (Value);
      Name_Len := 0;
      case V.K is

         when k_int =>
            if V.Sign < 0 then
               Add_Char_To_Name_Buffer ('-');
            elsif V.Base = 16 then
               Add_Str_To_Name_Buffer ("16#");
            elsif V.Base = 8 then
               Add_Str_To_Name_Buffer ("8#");
            end if;

            Add_ULL_To_Name_Buffer (V.IVal, ull (V.Base));

            if V.Base = 16 or else V.Base = 8 then
               Add_Char_To_Name_Buffer ('#');
            end if;

         when k_float =>
            Add_Str_To_Name_Buffer (long_double'image (V.FVal));
            declare
               Index : Natural := Name_Len;

            begin

               --  Find exponent if any

               while Index > 0 and then Name_Buffer (Index) /= 'E' loop
                  Index := Index - 1;
               end loop;

               --  Remove leading zero in exponent part.

               if Index > 0 then
                  Index := Index + 2;
                  while Index <= Name_Len and then Name_Buffer (Index) = '0'
                  loop
                     Name_Buffer (Index .. Name_Len - 1) :=
                       Name_Buffer (Index + 1 .. Name_Len);
                     Name_Len := Name_Len - 1;
                  end loop;

                  --  Remove exponent

                  if Index > Name_Len then
                     Name_Len := Name_Len - 2;
                     Index    := Name_Len;

                  else
                     Index := Name_Len;
                     while Name_Buffer (Index) /= 'E' loop
                        Index := Index - 1;
                     end loop;
                     Index := Index - 1;
                  end if;

               end if;

               --  Remove trailing zero in fraction part.

               while Name_Buffer (Index) = '0' loop
                  exit when Name_Buffer (Index - 1) = '.';
                  Name_Buffer (Index .. Name_Len - 1) :=
                    Name_Buffer (Index + 1 .. Name_Len);
                  Name_Len := Name_Len - 1;
                  Index    := Index - 1;
               end loop;
            end;

         when k_char =>
            if V.CVal <= 127 then
               declare
                  C : constant Character := Character'val (Natural (V.CVal));
               begin
                  if C in '!' .. '~' then
                     Add_Char_To_Name_Buffer (''');
                     Add_Char_To_Name_Buffer (C);
                     Add_Char_To_Name_Buffer (''');
                  else
                     Add_Str_To_Name_Buffer ("Character'Val (");
                     Add_ULL_To_Name_Buffer (ull (V.CVal), 10);
                     Add_Char_To_Name_Buffer (')');
                  end if;
               end;
            else
               Add_Str_To_Name_Buffer ("Wide_Character'Val (");
               Add_ULL_To_Name_Buffer (ull (V.CVal), 10);
               Add_Char_To_Name_Buffer (')');
            end if;

         when k_pointed_char =>
            if V.PCVal = No_Name then
               return '"' & '"';
            end if;
            Add_Char_To_Name_Buffer ('"'); -- "
            Get_Name_String_And_Append (V.PCVal);
            Add_Char_To_Name_Buffer ('"'); -- "

         when others =>
            raise Program_Error;
      end case;

      return Name_Buffer (1 .. Name_Len);
   end Image;

   ----------------
   -- To_C_Value --
   ----------------

   function To_C_Value (V : value_id) return value_id is
      VT     : constant OV.value_type := OV.Value (V);
      Result : value_id;
   begin
      case VT.T is
         when OV.lt_integer =>
            if VT.ISign then
               Result := New_Int_Value (VT.IVal, -1, VT.IBase);
            else
               Result := New_Int_Value (VT.IVal, 1, VT.IBase);
            end if;
         when OV.lt_real =>
            Result := New_Floating_Point_Value (long_double (VT.RVal));
         when OV.lt_string =>
            Result := New_Pointed_Char_Value (VT.SVal);
         when OV.lt_boolean =>
            raise Constraint_Error;
         when others =>
            raise Constraint_Error;
      end case;

      return Result;
   end To_C_Value;

   ------------------------------
   -- New_Floating_Point_Value --
   ------------------------------

   function New_Floating_Point_Value (Value : long_double) return value_id is
   begin
      return New_Value (value_type'(k_float, Value));
   end New_Floating_Point_Value;

   -------------------
   -- New_Int_Value --
   -------------------

   function New_Int_Value
     (Value : unsigned_long_long;
      Sign  : short_short;
      Base  : unsigned_short_short) return value_id
   is
   begin
      return New_Value (value_type'(k_int, Value, Sign, Base));
   end New_Int_Value;

   -------------------------
   -- New_Character_Value --
   -------------------------

   function New_Char_Value (Value : unsigned_short) return value_id is
   begin
      return New_Value (value_type'(k_char, Value));
   end New_Char_Value;

   ---------------
   -- New_Value --
   ---------------

   function New_Value (Value : value_type) return value_id is
      V : value_id;
   begin
      VT.Increment_Last;
      V            := VT.Last;
      VT.Table (V) := Value;
      return V;
   end New_Value;

   ---------------
   -- Set_Value --
   ---------------

   procedure Set_Value (V : value_id; X : value_type) is
   begin
      VT.Table (V) := X;
   end Set_Value;

   ----------------
   -- Shift_Left --
   ----------------

   function Shift_Left (L, R : value_type) return value_type is
      LV : value_type := L;
      RV : value_type := R;
   begin
      case RV.K is
         when k_int =>
            if RV.Sign < 0 then
               RV.Sign := 1;
               return Shift_Right (LV, RV);
            end if;

            --  Keep working with left operand base

            LV.IVal := Shift_Left (LV.IVal, Natural (RV.IVal));
            return LV;

         when others =>
            return Bad_Value;
      end case;
   end Shift_Left;

   -----------------
   -- Shift_Right --
   -----------------

   function Shift_Right (L, R : value_type) return value_type is
      LV : value_type := L;
      RV : value_type := R;
   begin
      case RV.K is
         when k_int =>
            if RV.Sign < 0 then
               RV.Sign := 1;
               return Shift_Left (LV, RV);
            end if;

            --  Keep working with left operand base

            LV.IVal := Shift_Right (LV.IVal, Natural (RV.IVal));
            return LV;

         when others =>
            return Bad_Value;
      end case;
   end Shift_Right;

   ----------------------------
   -- New_Pointed_Char_Value --
   ----------------------------

   function New_Pointed_Char_Value (Value : name_id) return value_id is
   begin
      return New_Value (value_type'(k_pointed_char, Value));
   end New_Pointed_Char_Value;

   -----------
   -- Value --
   -----------

   function Value (V : value_id) return value_type is
   begin
      return VT.Table (V);
   end Value;

   -----------
   -- Reset --
   -----------

   procedure Reset is
   begin
      VT.Init;
   end Reset;

end Ocarina.Generators.C_Values;