--------------------------------------------------------------------- ----------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . A A D L _ V A L U E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-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; with GNAT.Table; with Ada.Characters.Handling; with Ada.Long_Long_Float_Text_IO; with Charset; package body Ocarina.AADL_Values is AADL_True : constant String := "true"; AADL_False : constant String := "false"; package VT is new GNAT.Table (value_type, value_id, No_Value + 1, 10, 10); ----------- -- Reset -- ----------- procedure Reset is begin VT.Init; end Reset; -------------------- -- Get_Value_Type -- -------------------- function Get_Value_Type (Value : value_id) return value_type is begin return VT.Table (Value); end Get_Value_Type; ----------- -- Image -- ----------- function Image (Value : value_type; Quoted : Boolean := True) return String is use Namet; begin Name_Len := 0; case Value.T is when lt_boolean => if Value.BVal then return AADL_True; else return AADL_False; end if; when lt_string => if Value.SVal = No_Name then return """"""; -- null string ' "" ' else if Quoted then Set_Char_To_Name_Buffer ('"'); Get_Name_String_And_Append (Value.SVal); Add_Char_To_Name_Buffer ('"'); else Get_Name_String (Value.SVal); end if; end if; when lt_enumeration => if Value.EVal = No_Name then return ""; -- null string ' "" ' else Get_Name_String (Value.EVal); end if; when lt_real => if Value.RSign then Set_Char_To_Name_Buffer ('-'); end if; Add_Str_To_Name_Buffer (Image (Value.RVal, Value.RBase, Value.RExp)); when lt_integer => if Value.ISign then Set_Char_To_Name_Buffer ('-'); end if; Add_Str_To_Name_Buffer (Image (Value.IVal, Value.IBase, Value.IExp)); end case; return Name_Buffer (1 .. Name_Len); end Image; ----------- -- Image -- ----------- function Image (Value : value_id; Quoted : Boolean := True) return String is begin if Value = No_Value then return "NoValue"; else return Image (VT.Table (Value), Quoted); end if; end Image; ----------------------- -- New_Boolean_Value -- ----------------------- function New_Boolean_Value (Value : Boolean) return value_id is begin return New_Value (value_type'(lt_boolean, Value)); end New_Boolean_Value; -------------------- -- New_Real_Value -- -------------------- function New_Real_Value (Value : Long_Long_Float; Negative : Boolean := False; Base : unsigned_short_short := 10; Exp : Integer := 0) return value_id is begin return New_Value (value_type'(lt_real, Value, Negative, Base, Exp)); end New_Real_Value; ----------------------- -- New_Integer_Value -- ----------------------- function New_Integer_Value (Value : unsigned_long_long; Negative : Boolean := False; Base : unsigned_short_short := 10; Exp : Integer := 0) return value_id is begin return New_Value (value_type'(lt_integer, Value, Negative, Base, Exp)); end New_Integer_Value; ---------------------- -- New_String_Value -- ---------------------- function New_String_Value (Value : name_id) return value_id is begin return New_Value (value_type'(lt_string, Value)); end New_String_Value; -------------------- -- New_Enum_Value -- -------------------- function New_Enum_Value (Value : name_id) return value_id is begin return New_Value (value_type'(lt_enumeration, Value)); end New_Enum_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; ----------- -- Value -- ----------- function Value (V : value_id) return value_type is begin return VT.Table (V); end Value; function Image (V : Long_Long_Float; Base : unsigned_short_short) return String; function Remove_Ending_Zeros (Str : String) return String; -- Remove ending zeros '0' -- WARNING: if the result string terminates with an '.', the character -- which is next to '.' will be rescued -- Example: Remove_Ending_Zeros ("0.0") = "0.0" function Remove_Leading_Spaces (Str : String) return String; -- Remove leading spaces Minus_Character : constant Character := '-'; Base_Separator : constant Character := '#'; Exp_Separator : constant Character := 'E'; Real_Separator : constant Character := '.'; Real_Epsilon : constant Long_Long_Float := 1.0E-10; Fraction_Max_Digits : constant Integer := 4 * 10; -- Max digits = digits (Real_Epsilon) in base 2 (not in base 10 !!) -- = about (4 * digits (Real_Epsilon) in base 10) Invalid_Number_Base : exception; function Image (V : unsigned_long_long; Base : unsigned_short_short) return String; ----------- -- Image -- ----------- function Image (V : unsigned_short_short) return String is begin return Remove_Leading_Spaces (unsigned_short_short'image (V)); end Image; ----------- -- Image -- ----------- function Image (V : Integer) return String is begin return Remove_Leading_Spaces (Integer'image (V)); end Image; ----------- -- Image -- ----------- function Image (V : unsigned_long_long) return String is begin return Remove_Leading_Spaces (unsigned_long_long'image (V)); end Image; ----------- -- Image -- ----------- function Image (V : unsigned_long_long; Base : unsigned_short_short) return String is Str : String (1 .. unsigned_long_long'size + 4); -- Max digits = BB # (Max Bits) # Str_Pos : Integer := Str'last; Rest : unsigned_long_long := V; LBase : constant unsigned_long_long := unsigned_long_long (Base); Digit : unsigned_short_short; Ch : Character; begin if Base < 2 or else Base > 16 then raise Invalid_Number_Base; end if; loop Digit := unsigned_short_short (Rest mod LBase); if Digit < 10 then Ch := Character'val (Character'pos ('0') + Digit); else Ch := Character'val (Character'pos ('A') + Digit - 10); end if; Str (Str_Pos) := Ch; Str_Pos := Str_Pos - 1; Rest := Rest / LBase; exit when Rest = 0; end loop; return Str (Str_Pos + 1 .. Str'last); end Image; ----------- -- Image -- ----------- function Image (V : unsigned_long_long; Base : unsigned_short_short; Exp : Integer) return String is New_Value : unsigned_long_long; begin if Exp = 0 then if Base = 10 then -- decimal integer without exponent return Image (V); else -- based integer without exponent return Image (Base) & Base_Separator & Image (V, Base) & Base_Separator; end if; else New_Value := unsigned_long_long (Long_Long_Float (V) / Power (Integer (Base), Exp)); if Base = 10 then -- decimal integer with exponent return Image (New_Value) & Exp_Separator & Image (Exp); else -- based intgeger with exponent return Image (Base) & Base_Separator & Image (New_Value, Base) & Base_Separator & Exp_Separator & Image (Exp); end if; end if; end Image; ----------- -- Image -- ----------- function Image (V : Long_Long_Float) return String is Str : String (1 .. 2 * Long_Long_Float'digits + 2); -- Max digits = [+/-] Fore . Aft begin Ada.Long_Long_Float_Text_IO.Put (Str, V, Long_Long_Float'digits, 0); return Remove_Ending_Zeros (Remove_Leading_Spaces (Str)); end Image; ----------- -- Image -- ----------- function Image (V : Long_Long_Float; Base : unsigned_short_short) return String is Str : String (1 .. Fraction_Max_Digits); Sign : Boolean; Integer_Part : unsigned_long_long; Rest : Long_Long_Float; Fraction : Long_Long_Float; LBase : constant Long_Long_Float := Long_Long_Float (Base); Digit : unsigned_short_short; Str_Len : Integer := 0; Ch : Character; begin if V < 0.0 then Sign := True; Rest := -V; else Sign := False; Rest := V; end if; Integer_Part := unsigned_long_long (Long_Long_Float'floor (Rest)); Rest := Rest - Long_Long_Float (Integer_Part); Fraction := 1.0 / LBase; loop Digit := unsigned_short_short (Long_Long_Float'truncation (Rest / Fraction)); if Digit < 10 then Ch := Character'val (Character'pos ('0') + Digit); else Ch := Character'val (Character'pos ('A') + Digit - 10); end if; Str_Len := Str_Len + 1; Str (Str_Len) := Ch; Rest := Rest - Long_Long_Float (Digit) * Fraction; Fraction := Fraction / LBase; exit when Rest < Real_Epsilon or else Str_Len = Str'last; end loop; if Sign then return Minus_Character & Image (Integer_Part, Base) & Real_Separator & Str (1 .. Str_Len); else return Image (Integer_Part, Base) & Real_Separator & Str (1 .. Str_Len); end if; end Image; ----------- -- Image -- ----------- function Image (V : Long_Long_Float; Base : unsigned_short_short; Exp : Integer) return String is New_Value : Long_Long_Float; begin if Exp = 0 then if Base = 10 then -- decimal real without exponent return Image (V); else -- based real without exponent return Image (Base) & Base_Separator & Image (V, Base) & Base_Separator; end if; else New_Value := V / Power (Integer (Base), Exp); if Base = 10 then -- decimal real with exponent return Image (New_Value) & Exp_Separator & Image (Exp); else -- based real with exponent return Image (Base) & Base_Separator & Image (New_Value, Base) & Base_Separator & Exp_Separator & Image (Exp); end if; end if; end Image; ----------- -- Image -- ----------- function Image (Kind : node_kind) return String is use Charset; S : String := node_kind'image (Kind); Capital : Boolean := False; begin To_Lower (S); for I in S'range loop if S (I) = '_' then Capital := True; else if Capital then S (I) := Ada.Characters.Handling.To_Upper (S (I)); end if; Capital := False; end if; end loop; return S (3 .. S'last); end Image; ----------- -- Power -- ----------- function Power (Base : Integer; Exp : Integer) return Long_Long_Float is Result : Long_Long_Float := 1.0; LBase : constant Long_Long_Float := Long_Long_Float (Base); PExp : constant Integer := abs (Exp); begin for I in 1 .. PExp loop Result := Result * LBase; end loop; if Exp < 0 then return 1.0 / Result; else return Result; end if; end Power; ------------------------- -- Remove_Ending_Zeros -- ------------------------- function Remove_Ending_Zeros (Str : String) return String is I : Integer; begin I := Str'last; loop if Str (I) /= '0' then if Str (I) = '.' and then I < Str'last then return Str (Str'first .. I + 1); else return Str (Str'first .. I); end if; end if; exit when I = Str'first; I := I - 1; end loop; return Str; end Remove_Ending_Zeros; --------------------------- -- Remove_Leading_Spaces -- --------------------------- function Remove_Leading_Spaces (Str : String) return String is begin for I in Str'range loop if Str (I) /= ' ' then return Str (I .. Str'last); end if; end loop; return Str; end Remove_Leading_Spaces; --------- -- "*" -- --------- function "*" (L : value_type; R : value_type) return value_type is begin case L.T is when lt_integer => case R.T is when lt_integer => declare Result : value_type (lt_integer); begin Result.IBase := 10; Result.ISign := Safe_XOR (L.ISign, R.ISign); Result.IVal := L.IVal * R.IVal; return Result; end; when lt_real => declare Result : value_type (lt_real); begin Result.RSign := Safe_XOR (L.ISign, R.RSign); Result.RExp := 0; Result.RVal := Long_Long_Float (L.IVal) * R.RVal; return Result; end; when others => raise Constraint_Error; end case; when lt_real => case R.T is when lt_integer => declare Result : value_type (lt_real); begin Result.RSign := Safe_XOR (L.RSign, R.ISign); Result.RExp := 0; Result.RVal := L.RVal * Long_Long_Float (R.IVal); return Result; end; when lt_real => declare Result : value_type (lt_real); begin Result.RSign := Safe_XOR (L.RSign, R.RSign); Result.RExp := 0; Result.RVal := L.RVal * R.RVal; return Result; end; when others => raise Constraint_Error; end case; when others => raise Constraint_Error; end case; end "*"; --------- -- "=" -- --------- function "=" (L : value_type; R : value_type) return Boolean is begin case L.T is when lt_integer => case R.T is when lt_integer => return (L.IVal = R.IVal) and then (L.ISign = R.ISign); when lt_real => return (Long_Long_Float (L.IVal) = R.RVal) and then (L.ISign = R.RSign); when others => raise Constraint_Error; end case; when lt_real => case R.T is when lt_integer => return (L.RVal = Long_Long_Float (R.IVal)) and then (L.RSign = R.ISign); when lt_real => return (L.RVal = R.RVal) and then (L.RSign = R.RSign); when others => raise Constraint_Error; end case; when others => raise Constraint_Error; end case; end "="; --------- -- "<" -- --------- function "<" (L : value_type; R : value_type) return Boolean is Sign_L : Boolean; Sign_R : Boolean; Result : Boolean; begin -- Compare absolute values case L.T is when lt_integer => case R.T is when lt_integer => Sign_L := L.ISign; Sign_R := R.ISign; Result := L.IVal < R.IVal; when lt_real => Sign_L := L.ISign; Sign_R := R.RSign; Result := Long_Long_Float (L.IVal) < R.RVal; when others => raise Constraint_Error; end case; when lt_real => case R.T is when lt_integer => Sign_L := L.RSign; Sign_R := R.ISign; Result := L.RVal < Long_Long_Float (R.IVal); when lt_real => Sign_L := L.RSign; Sign_R := R.RSign; Result := L.RVal < R.RVal; when others => raise Constraint_Error; end case; when others => raise Constraint_Error; end case; -- Take signs into account if Sign_L then if Sign_R then return not Result; else return True; end if; else if Sign_R then return False; else return Result; end if; end if; end "<"; end Ocarina.AADL_Values;