|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 10518 (0x2916)
Types: TextFile
Names: »B«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─ ⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦4c85d69e2⟧
└─⟦this⟧
-- The use of this system is subject to the software license terms and
-- conditions agreed upon between Rational and the Customer.
--
-- Copyright 1988 by Rational.
--
-- RESTRICTED RIGHTS LEGEND
--
-- Use, duplication, or disclosure by the Government is subject to
-- restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
-- Technical Data and Computer Software clause at 52.227-7013.
--
--
-- Rational
-- 3320 Scott Boulevard
-- Santa Clara, California 95054-3197
--
-- PROPRIETARY AND CONFIDENTIAL INFORMATION OF RATIONAL;
-- USE OR COPYING WITHOUT EXPRESS WRITTEN AUTHORIZATION
-- IS STRICTLY PROHIBITED. THIS MATERIAL IS PROTECTED AS
-- AN UNPUBLISHED WORK UNDER THE U.S. COPYRIGHT ACT OF
-- 1976. CREATED 1988. ALL RIGHTS RESERVED.
--
--
with Io_Exception_Flavors;
with Numeric_Literals;
with System_Types;
with Primitive_Io;
package body Integer_Conversions is
-- procedure Trace
-- (S : String;
-- Absorb_Output : Boolean := Primitive_Io.Global_Absorb_Output)
-- renames Primitive_Io.Put_Line;
Input_Value_Error : exception
renames Io_Exception_Flavors.Input_Value_Error;
-- (Probably Numeric_Literals should import these operators from
-- System_Types, and this package should import these operators
-- from Numeric_Literals.)
function "-" (L : Long_Integer) return Long_Integer
renames System_Types."-";
function "-" (L, R : Long_Integer) return Long_Integer
renames System_Types."-";
function "*" (L, R : Long_Integer) return Long_Integer
renames System_Types."*";
function "/" (L, R : Long_Integer) return Long_Integer
renames System_Types."/";
function "rem" (L, R : Long_Integer) return Long_Integer
renames System_Types."rem";
function "**" (Left : Long_Integer; Right : Integer) return Long_Integer
renames System_Types."**";
function "=" (L, R : Long_Integer) return Boolean renames System_Types."=";
function "<" (L, R : Long_Integer) return Boolean renames System_Types."<";
function "=" (L, R : Numeric_Literals.Sign_Type) return Boolean
renames Numeric_Literals."=";
subtype Sign_Type is Numeric_Literals.Sign_Type;
Plus : constant Sign_Type := Numeric_Literals.Plus;
Minus : constant Sign_Type := Numeric_Literals.Minus;
-- subtype Negative_Long is Long_Integer range Long_Integer'First .. 0;
subtype Negative_Long is Long_Integer;
subtype Long_Base_Type is Long_Integer range 2 .. 16;
function Max (Left, Right : in Integer) return Integer is
begin
if Left > Right then
return Left;
else
return Right;
end if;
end Max;
pragma Inline (Max);
function Value (Literal : in Numeric_Literal) return Long_Integer is
S_First : constant Natural := 1;
S_Index : Natural := S_First;
S_Last : constant Natural := Literal.L;
Sign : Sign_Type := Plus;
Pound_Sign : Character;
Mantissa : Negative_Long := 0;
Base : Long_Base_Type := 10;
Exponent : Integer;
Result : Long_Integer;
begin
-- Start with base or mantissa, we don't know which
if Literal.V (S_Index) = '-' then
Sign := Minus;
S_Index := S_Index + 1;
elsif Literal.V (S_Index) = '+' then
S_Index := S_Index + 1;
end if;
while S_Index <= S_Last loop
case Literal.V (S_Index) is
when '0' .. '9' =>
-- An overflow here indicates the number is too large:
Mantissa := Mantissa * 10 -
(Character'Pos (Literal.V (S_Index)) -
Character'Pos ('0'));
when '_' =>
null;
when others =>
exit;
end case;
S_Index := S_Index + 1;
end loop;
-- Based literal next?
if S_Index < S_Last and then (Literal.V (S_Index) = '#' or else
Literal.V (S_Index) = ':') then
Pound_Sign := Literal.V (S_Index);
S_Index := S_Index + 1;
Base := -Mantissa;
-- ^ Might raise Constraint_Error or Numeric_Error
Mantissa := 0;
while Literal.V (S_Index) /= Pound_Sign loop
declare
C : constant Character := Literal.V (S_Index);
Addin : Long_Integer;
begin
if C /= '_' then
-- An overflow in this block
-- indicates the value is too large:
Mantissa := Mantissa * Base;
if C in '0' .. '9' then
Addin := Character'Pos (C) - Character'Pos ('0');
elsif C in 'a' .. 'f' then
Addin := Character'Pos (C) -
(Character'Pos ('a') - 10);
elsif C in 'A' .. 'F' then
Addin := Character'Pos (C) -
(Character'Pos ('A') - 10);
else
raise Input_Value_Error;
end if;
if Addin < Base then
Mantissa := Mantissa - Addin;
else
raise Input_Value_Error;
end if;
end if;
end;
S_Index := S_Index + 1;
end loop;
S_Index := S_Index + 1;
end if;
Exponent := 0;
if S_Index < S_Last and then (Literal.V (S_Index) = 'e' or
Literal.V (S_Index) = 'E') then
-- Exponent is in base 10
S_Index := S_Index + 1;
if Literal.V (S_Index) = '-' then
-- Negative exponents not allowed for integers
raise Input_Value_Error;
elsif Literal.V (S_Index) = '+' then
S_Index := S_Index + 1;
end if;
while S_Index <= S_Last loop
case Literal.V (S_Index) is
when '0' .. '9' =>
-- An overflow here indicates the number is too large:
-- An overflow here indicates the value is too large:
Exponent := Exponent * 10 +
Character'Pos (Literal.V (S_Index)) -
Character'Pos ('0');
when '_' =>
null;
when others =>
exit;
end case;
S_Index := S_Index + 1;
end loop;
end if;
-- Now we're done.
-- Convert the numeric information returned by parse to a value of type
-- num. This conversion fails by raising Numeric_Error or
-- Constraint_Error. We don't check Exact, since by definition, this
-- calculation will overflow if the literal cannot be exactly
-- represented as a Long_Integer.
-- An overflow here indicates the value is too large:
Result := Mantissa * (Long_Integer (Base) ** Exponent);
if Sign = Plus then
-- I know this seems backwards, but it needs to work this way if
-- if we are to be able to read -16#8000_0000# but blow
-- up on 16#8000_0000#.
-- An overflow here indicates the value is too large:
Result := -Result;
end if;
-- Trace ("I_Convert result from " & Literal.V (S_First .. S_Last) &
-- " is " & Long_Integer'Image (Result));
return Result;
exception
-- Transform all overflows into the proper I/O error
when Constraint_Error | Numeric_Error =>
raise Input_Value_Error;
end Value;
-- Beware: The result string's 'First might not be 1!
function Image (Value : in Long_Integer;
Width : in Field;
Base : in Number_Base) return String is
V : Long_Integer;
-- ^ Actually, V will fit in Long_Integer'First .. 0
Long_Base : constant Long_Integer := Long_Integer (Base);
Is_Negative : constant Boolean := Value < 0;
Digit : Integer range 0 .. 15;
Result : String (1 .. Max (Width, 64 + 4 + 1));
-- Large enough to hold the largest image: 64 digits + 16## + a sign
Ptr : Natural := Result'Last + 1;
Pad : Integer;
procedure Output (C : in Character) is
begin
Ptr := Ptr - 1;
Result (Ptr) := C;
end Output;
pragma Inline (Output);
begin
-- We make V a negative number to avoid overflow problems with
-- Long_Integer'FIRST
if Is_Negative then
V := Value;
else
V := -Value;
end if;
-- Now we construct the image from right to left
if Base /= 10 then
Output ('#');
end if;
if V = 0 then
Output ('0');
else
while V /= 0 loop
Digit := -Integer (V rem Long_Base);
if Digit < 10 then
Output (Character'Val (Character'Pos ('0') + Digit));
else
Output (Character'Val (Character'Pos ('A') - 10 + Digit));
end if;
V := V / Long_Base;
end loop;
end if;
if Base /= 10 then
Output ('#');
if Base > 10 then
Output (Character'Val (Character'Pos ('0') + Base - 10));
Output ('1');
else
Output (Character'Val (Character'Pos ('0') + Base));
end if;
end if;
if Is_Negative then
Output ('-');
end if;
Pad := Width - (Result'Last + 1 - Ptr);
for I in reverse 1 .. Pad loop
Output (' ');
end loop;
return Result (Ptr .. Result'Last);
end Image;
end Integer_Conversions;