DataMuseum.dk

top - download

    Length: 6434 (0x1922)
    Types: TextFile
    Names: »B«

└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
    └─ ⟦77aa8350c⟧ »DATA« 
        └─⟦f794ecd1d⟧ 
            └─⟦24d1ddd49⟧ 
                └─⟦this⟧ 

TextFile

--    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 Attribute_Definitions;
with Runtime_Ids;

function Integer_Value (String_Length : Natural;
                        String_Value  : Attribute_Definitions.Short_String)
                       return Integer is
    pragma Routine_Number (Runtime_Ids.Int_Value);

    -- Will raise Constraint_Error if Value is not a valid integer literal
    -- (with optional leading and trailing spaces, and optional leading
    -- sign) or if the number it represents is not in the range of
    -- Integer'First .. Integer'Last.  There is only one Integer_Value routine
    -- no matter how many integer types are available in Standard, it is
    -- up to the caller (i.e., the Middle Pass) to perform an additional
    -- constraint check to make sure the result is in the base type of the
    -- given integer type.

    pragma Suppress (Access_Check);
    pragma Suppress (Index_Check);
    pragma Suppress (Range_Check);
    pragma Suppress (Storage_Check);

    Data           : Attribute_Definitions.Short_String renames String_Value;
    Value          : Integer;
    Exponent       : Integer;
    Radix          : Integer  := 10;
    Had_Minus_Sign : Boolean  := False;
    Hash           : Character;
    Index          : Positive := 1;

    procedure Bump_Index is

        pragma Routine_Number (Runtime_Ids.Internal);

        pragma Suppress (Storage_Check);
        pragma Suppress (Range_Check);

    begin
        if Index = String_Length then
            raise Constraint_Error;
        end if;
        Index := Index + 1;
    end Bump_Index;
    pragma Inline (Bump_Index);

    function Strip_Number (Radix       : Natural := 10;  
                           Syntax_Only : Boolean := False) return Integer is

        pragma Routine_Number (Runtime_Ids.Internal);

        pragma Suppress (Access_Check);
        pragma Suppress (Index_Check);
        pragma Suppress (Range_Check);

        Underbar_Illegal : Boolean := True;
        No_Processing    : Boolean := True;
        C                : Character;
        Digit            : Integer;
        Accumulator      : Integer := 0;

    begin
        while Index <= String_Length loop
            C := Data (Index);
            if C = '_' then
                if Underbar_Illegal then
                    raise Constraint_Error;
                else
                    Underbar_Illegal := True;
                end if;
            else
                case C is
                    when '0' .. '9' =>
                        Digit := Character'Pos (C) - Character'Pos ('0');
                    when 'a' .. 'f' =>
                        Digit := Character'Pos (C) - Character'Pos ('a') + 10;
                    when 'A' .. 'F' =>
                        Digit := Character'Pos (C) - Character'Pos ('A') + 10;
                    when others =>
                        exit;
                end case;
                if Digit >= Radix then
                    exit;
                end if;
                Underbar_Illegal := False;
                if not Syntax_Only then
                    Accumulator := (Accumulator * Radix) - Digit;
                end if;
            end if;
            Index         := Index + 1;
            No_Processing := False;
        end loop;
        if Underbar_Illegal or else No_Processing then
            raise Constraint_Error;
        end if;
        return Accumulator;
    end Strip_Number;

begin
    --
    --  Check for the null string first
    --

    if String_Length = 0 then
        raise Constraint_Error;
    end if;

    --
    --  Remove leading blanks
    --

    while Data (Index) = ' ' loop
        Bump_Index;
    end loop;

    --
    --  Check for a leading + or - sign
    --

    if Data (Index) = '-' then
        Had_Minus_Sign := True;
        Bump_Index;
    elsif Data (Index) = '+' then
        Bump_Index;
    end if;

    Value := Strip_Number;

    if Index <= String_Length then
        Hash := Data (Index);
        if Hash = '#' or else Hash = ':' then
            Bump_Index;
            if Value not in -16 .. -2 then
                raise Constraint_Error;
            end if;
            Radix := -Value;
            Value := Strip_Number (Radix => Radix);
            if Index > String_Length or else Data (Index) /= Hash then
                raise Constraint_Error;
            end if;
            Index := Index + 1;
        end if;
    end if;

    if Index <= String_Length and then
       (Data (Index) = 'E' or else Data (Index) = 'e') then
        Bump_Index;
        if Data (Index) = '+' then
            Bump_Index;
        end if;  
        Exponent := Strip_Number (Syntax_Only => Value = 0);
        for I in Exponent .. -1 loop
            Value := Value * Radix;     --  may cause Numberic_Error
        end loop;
    end if;

    --
    --  Delete any trailing blanks.  Any other characters cause
    --  fatal errors
    --

    while Index <= String_Length loop
        if Data (Index) /= ' ' then
            raise Constraint_Error;
        end if;
        Index := Index + 1;
    end loop;

    --
    --  Now adjust for the sign found at the very begining
    --

    if not Had_Minus_Sign then
        Value := -Value;                --  may cause Numeric_Error
    end if;

    return Value;

exception
    when others =>
        raise Constraint_Error;
end Integer_Value;
pragma Export_Function (Internal => Integer_Value, External => "__INT_VALUE");
pragma Runtime_Unit (Unit_Number         => Runtime_Ids.Runtime_Compunit,
                     Elab_Routine_Number => Runtime_Ids.Internal);