DataMuseum.dk Presents historical artifacts from the history of: Rational R1000/400

This is an automatic "excavation" of a thematic subset of artifacts from Datamuseum.dk's BitArchive. See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software.

top - metrics - download

⟦90452da0b⟧ Ada Source

    Length: 23552 (0x5c00)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Dynamic_Value, seg_0474d7

Derivation

└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
    └─⟦cfc2e13cd⟧ »Space Info Vol 2« 
        └─⟦this⟧ 

with Unbounded_String, Generic_List, Text_Io;

package body Dynamic_Value is

    package Value_String is new Unbounded_String (1);
    function Are_Equal (S1, S2 : Value_String.Variable_String) return Boolean;

    package String_List is new Generic_List (Value_String.Variable_String,
                                             Are_Equal, Value_String.Copy);
    type Acces_Str_List is access String_List.Object;

    type Value (What : Kinds := Unknown) is
        record
            case What is
                when Integer_Number =>
                    I : Integer;
                when String_Of_Characters =>
                    S : Value_String.Variable_String;
                when Vocabulary_Word =>
                    W : Value_String.Variable_String;
                when Boolean_Number =>
                    B : Boolean;  
                when Set_Of_Words =>
                    Sw : Acces_Str_List;  
                when others =>
                    null;
            end case;
        end record;

    function Are_Equal (S1, S2 : Value_String.Variable_String) return Boolean is

    begin
        return ((Value_String.Image (S1)) = (Value_String.Image (S2)));
    end Are_Equal;

    procedure Dispose (Obj : in out Object) is
    begin
        Obj := null;    -- le ramasse miette fait eventuellement le reste
    end Dispose;


    function Are_Equal (Obj1, Obj2 : in Object) return Boolean is  
        Kind1, Kind2 : Kinds;
    begin  
        Kind1 := Get_Kind (Obj1);
        Kind2 := Get_Kind (Obj2);
        if (Kind1 = Kind2) then  
            case Kind1 is
                when Integer_Number =>
                    return (Obj1.all.I = Obj2.all.I);
                when String_Of_Characters =>
                    return (Value_String.Image (Obj1.all.S) =
                            Value_String.Image (Obj2.all.S));
                when Vocabulary_Word =>
                    return (Value_String.Image (Obj1.all.W) =
                            Value_String.Image (Obj2.all.W));
                when Boolean_Number =>
                    return (Obj1.all.B = Obj2.all.B);
                when others =>
                    return True;  
            end case;
        else
            return False;
        end if;
    end Are_Equal;


    function Get_Kind (Obj : in Object) return Kinds is
    begin
        if (Obj = null) then
            return Unknown;
        else
            return Obj.all.What;
        end if;
    end Get_Kind;


    function Get_Value (Obj : in Object) return Integer is
    begin
        if (Get_Kind (Obj) = Integer_Number) then
            return Obj.all.I;
        else
            raise Type_Clash;
        end if;
    end Get_Value;


    procedure Set_Value (Obj : in out Object; Val : Integer) is
    begin
        if (Obj = null) then
            Obj := new Value'(What => Integer_Number, I => Val);
        else
            Obj.all := (What => Integer_Number, I => Val);
        end if;
    end Set_Value;


    function Get_Value (Obj : in Object) return String is
    begin
        if (Get_Kind (Obj) = String_Of_Characters) then
            return Value_String.Image (Obj.all.S);
        else
            if (Get_Kind (Obj) = Vocabulary_Word) then
                return Value_String.Image (Obj.all.W);
            else
                raise Type_Clash;
            end if;
        end if;
    end Get_Value;


    procedure Set_Value (Obj : in out Object;
                         Val : String;
                         Is_A_Vocabulary_Word : Type_Value := String_Value) is
    begin  
        if (Is_A_Vocabulary_Word = Voca_Value) then  
            if (Obj = null) then
                Obj := new Value'(What => Vocabulary_Word,
                                  W => Value_String.Value (Val));
            else
                Obj.all := (What => Vocabulary_Word,
                            W => Value_String.Value (Val));
            end if;
        else
            if (Obj = null) then
                Obj := new Value'(What => String_Of_Characters,
                                  S => Value_String.Value (Val));
            else
                Obj.all := (What => String_Of_Characters,
                            S => Value_String.Value (Val));
            end if;
        end if;
    end Set_Value;


    function Get_Value (Obj : in Object) return Boolean is
    begin
        if (Get_Kind (Obj) = Boolean_Number) then
            return Obj.all.B;
        else
            raise Type_Clash;
        end if;
    end Get_Value;


    procedure Set_Value (Obj : in out Object; Val : in Boolean) is
    begin
        if (Obj = null) then
            Obj := new Value'(What => Boolean_Number, B => Val);
        else
            Obj.all := (What => Boolean_Number, B => Val);
        end if;
    end Set_Value;

    procedure Deep_Copy (Source : in Object; Target : in out Object) is
        I : Integer;
        B : Boolean;  
        S : Value_String.Variable_String;  
        W : Value_String.Variable_String;
    begin
        case Get_Kind (Source) is
            when Integer_Number =>
                I := Get_Value (Source);
                Set_Value (Target, I);
            when Boolean_Number =>
                B := Get_Value (Source);
                Set_Value (Target, B);
            when String_Of_Characters =>
                S := Value_String.Value (Get_Value (Source));
                Set_Value (Target, Value_String.Image (S));
            when Vocabulary_Word =>
                W := Value_String.Value (Get_Value (Source));
                Set_Value (Target, Value_String.Image (W), Voca_Value);
            when Set_Of_Words =>
                if (Target = null) then
                    Create (Target);
                end if;
                String_List.Deep_Copy (Source.Sw.all, Target.Sw.all);  
            when Unknown =>
                null;
        end case;
    end Deep_Copy;


    procedure Light_Copy (Source : in Object; Target : in out Object) is
    begin
        Target := Source;
    end Light_Copy;


    procedure Print (Obj : in Object) is

        procedure Print_Set (Set : in Object) is
            It : String_List.Iterator;
            Cpt_Mot : Natural;
        begin  
            if Set = null then
                raise Set_Does_Not_Exist;
            end if;
            if (Get_Kind (Set) /= Set_Of_Words) then
                raise Type_Clash;
            end if;
            String_List.Initialize (It, Set.Sw.all);
            Cpt_Mot := 0;
            while not String_List.At_End (It) loop
                if Cpt_Mot = 3 then
                    Cpt_Mot := 0;
                    Text_Io.New_Line;
                end if;
                Cpt_Mot := Cpt_Mot + 1;
                Text_Io.Put
                   (Value_String.Image (String_List.Consult (It)) & "   ");

                String_List.Next (It);
            end loop;
        end Print_Set;

    begin
        case Get_Kind (Obj) is
            when Integer_Number =>
                Text_Io.Put (Integer'Image (Obj.all.I));
            when String_Of_Characters =>
                Text_Io.Put (Value_String.Image (Obj.all.S));
            when Vocabulary_Word =>
                Text_Io.Put (Value_String.Image (Obj.all.W));
            when Boolean_Number =>
                Text_Io.Put (Boolean'Image (Obj.all.B));
            when Set_Of_Words =>
                Print_Set (Obj);  
            when Unknown =>
                Text_Io.Put ("unknown");
        end case;
    end Print;


    -- procedure d'evaluation des objets

    -- *** operations valables sur plusieurs types selon le sens commun  ***

    procedure Are_Equal (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                Set_Value (Result, Left.all.I = Right.all.I);
            when String_Of_Characters =>
                Set_Value (Result, Value_String.Image (Left.all.S) =
                                      Value_String.Image (Right.all.S));
            when Vocabulary_Word =>
                Set_Value (Result, Value_String.Image (Left.all.W) =
                                      Value_String.Image (Right.all.W));
            when Boolean_Number =>
                Set_Value (Result, Left.all.B = Right.all.B);
            when others =>  
                raise Type_Clash;
        end case;
    end Are_Equal;


    procedure Is_Less (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                Set_Value (Result, Left.all.I < Right.all.I);
            when String_Of_Characters =>
                Set_Value (Result, Value_String.Image (Left.all.S) <
                                      Value_String.Image (Right.all.S));
            when Vocabulary_Word =>
                Set_Value (Result, Value_String.Image (Left.all.W) <
                                      Value_String.Image (Right.all.W));
            when others =>
                raise Type_Clash;
        end case;
    end Is_Less;

    procedure Is_Less_Equal (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                Set_Value (Result, Left.all.I <= Right.all.I);
            when String_Of_Characters =>
                Set_Value (Result, Value_String.Image (Left.all.S) <=
                                      Value_String.Image (Right.all.S));
            when Vocabulary_Word =>
                Set_Value (Result, Value_String.Image (Left.all.W) <=
                                      Value_String.Image (Right.all.W));
            when others =>
                raise Type_Clash;
        end case;
    end Is_Less_Equal;


    procedure Is_More (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                Set_Value (Result, Left.all.I > Right.all.I);
            when String_Of_Characters =>
                Set_Value (Result, Value_String.Image (Left.all.S) >
                                      Value_String.Image (Right.all.S));
            when Vocabulary_Word =>
                Set_Value (Result, Value_String.Image (Left.all.W) >
                                      Value_String.Image (Right.all.W));

            when others =>
                raise Type_Clash;
        end case;
    end Is_More;


    procedure Is_More_Equal (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                Set_Value (Result, Left.all.I >= Right.all.I);
            when String_Of_Characters =>
                Set_Value (Result, Value_String.Image (Left.all.S) >=
                                      Value_String.Image (Right.all.S));
            when Vocabulary_Word =>
                Set_Value (Result, Value_String.Image (Left.all.W) >=
                                      Value_String.Image (Right.all.W));
            when others =>
                raise Type_Clash;
        end case;
    end Is_More_Equal;


    procedure Is_Different (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                Set_Value (Result, Left.all.I /= Right.all.I);
            when String_Of_Characters =>
                Set_Value (Result, Value_String.Image (Left.all.S) /=
                                      Value_String.Image (Right.all.S));
            when Vocabulary_Word =>
                Set_Value (Result, Value_String.Image (Left.all.W) /=
                                      Value_String.Image (Right.all.W));
            when Boolean_Number =>
                Set_Value (Result, Left.all.B /= Right.all.B);
            when others =>
                raise Type_Clash;
        end case;
    end Is_Different;

    -- *** les entiers ***


    procedure Change_Sign (Obj : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Obj) /= Integer_Number) then
            raise Type_Clash;
        else
            Set_Value (Result, -Obj.all.I);
        end if;
    end Change_Sign;

    procedure Add (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                Set_Value (Result, Left.all.I + Right.all.I);
            when others =>
                raise Type_Clash;
        end case;
    end Add;

    procedure Substract (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                Set_Value (Result, Left.all.I - Right.all.I);
            when others =>
                raise Type_Clash;
        end case;
    end Substract;

    procedure Multiply (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                Set_Value (Result, Left.all.I * Right.all.I);
            when others =>
                raise Type_Clash;
        end case;
    end Multiply;

    procedure Divide (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        case Get_Kind (Left) is
            when Integer_Number =>
                if (Right.all.I = 0) then
                    raise Division_By_Zero;
                end if;
                Set_Value (Result, Left.all.I / Right.all.I);
            when others =>
                null;
        end case;
    end Divide;

    --  *** les booleens ***

    procedure Logical_And (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        if (Get_Kind (Left) /= Boolean_Number) then
            raise Type_Clash;
        end if;
        Set_Value (Result, Left.all.B and Right.all.B);
    end Logical_And;

    procedure Logical_Or (Left, Right : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Left) /= Get_Kind (Right)) then
            raise Type_Clash;
        end if;
        if (Get_Kind (Left) /= Boolean_Number) then
            raise Type_Clash;
        end if;
        Set_Value (Result, Left.all.B or Right.all.B);
    end Logical_Or;

    procedure Logical_Not (Obj : in Object; Result : in out Object) is
    begin
        if (Get_Kind (Obj) /= Boolean_Number) then
            raise Type_Clash;
        end if;
        Set_Value (Result, not (Obj.all.B));
    end Logical_Not;


    -- *** les ensembles ***

    procedure Create (Set : in out Object) is
        Tmp_List : Acces_Str_List;
    begin  
        Tmp_List := new String_List.Object;
        String_List.Free (Tmp_List.all);
        Set := new Value'(What => Set_Of_Words, Sw => Tmp_List);  
    end Create;


    procedure In_Set (Set : in Object;
                      Element : in String;
                      Result : in out Object) is  
        Exist : Boolean;
    begin
        if (Set = null) then
            raise Set_Does_Not_Exist;
        end if;
        if (Get_Kind (Set) /= Set_Of_Words) then
            raise Type_Clash;
        end if;
        Exist := String_List.Is_In_List
                    (Set.Sw.all, Value_String.Value (Element));
        Set_Value (Result, Exist);  
    end In_Set;


    procedure Append_To_Set (Set : in out Object; Element : in String) is
        Tmp_List : Acces_Str_List;
    begin  
        if (Set = null) then
            Tmp_List := new String_List.Object;
            String_List.Free (Tmp_List.all);
            Set := new Value'(What => Set_Of_Words, Sw => Tmp_List);  
        end if;
        if (Get_Kind (Set) /= Set_Of_Words) then  
            raise Type_Clash;
        end if;
        String_List.Add (Set.Sw.all, Value_String.Value (Element));
    end Append_To_Set;


    procedure Delete_From_Set (Set : in out Object; Element : in String) is  
        Tmp_List : Acces_Str_List;
    begin
        if (Set = null) then
            raise Set_Does_Not_Exist;
        end if;
        if (Get_Kind (Set) /= Set_Of_Words) then
            raise Type_Clash;
        end if;
        String_List.Delete (Set.Sw.all, Value_String.Value (Element));
        -- si element pas dans liste, rien n'est fait
    end Delete_From_Set;


    procedure Purge_Set (Set : in out Object) is
    begin  
        if Set = null then
            raise Set_Does_Not_Exist;
        end if;
        if (Get_Kind (Set) /= Set_Of_Words) then  
            raise Type_Clash;
        end if;
        String_List.Free (Set.Sw.all);
    end Purge_Set;


end Dynamic_Value;

    nblk1=16
    nid=f
    hdr6=2a
        [0x00] rec0=1b rec1=00 rec2=01 rec3=018
        [0x01] rec0=01 rec1=00 rec2=08 rec3=01c
        [0x02] rec0=1c rec1=00 rec2=14 rec3=074
        [0x03] rec0=26 rec1=00 rec2=10 rec3=006
        [0x04] rec0=1d rec1=00 rec2=0d rec3=004
        [0x05] rec0=20 rec1=00 rec2=11 rec3=000
        [0x06] rec0=19 rec1=00 rec2=07 rec3=032
        [0x07] rec0=21 rec1=00 rec2=12 rec3=00a
        [0x08] rec0=1d rec1=00 rec2=16 rec3=070
        [0x09] rec0=02 rec1=00 rec2=04 rec3=05c
        [0x0a] rec0=1a rec1=00 rec2=02 rec3=00a
        [0x0b] rec0=16 rec1=00 rec2=09 rec3=07a
        [0x0c] rec0=18 rec1=00 rec2=06 rec3=004
        [0x0d] rec0=1c rec1=00 rec2=0a rec3=006
        [0x0e] rec0=18 rec1=00 rec2=0b rec3=078
        [0x0f] rec0=1f rec1=00 rec2=05 rec3=018
        [0x10] rec0=1e rec1=00 rec2=13 rec3=018
        [0x11] rec0=1f rec1=00 rec2=15 rec3=01a
        [0x12] rec0=22 rec1=00 rec2=0c rec3=00c
        [0x13] rec0=1e rec1=00 rec2=03 rec3=006
        [0x14] rec0=0b rec1=00 rec2=0e rec3=000
        [0x15] rec0=01 rec1=00 rec2=0f rec3=000
    tail 0x2174aaf9886538ff648dd 0x42a00088462060003
Free Block Chain:
  0xf: 0000  00 00 00 07 80 01 3b 01 00 00 00 20 20 20 20 20  ┆      ;         ┆