DataMuseum.dk

top - download

    Length: 5680 (0x1630)
    Types: TextFile
    Notes: R1k Text-file segment

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

TextFile

with Unbounded_String;

package Dynamic_Value is

    Bad_Kind : exception;  -- a renommer type_clash
    Type_Clash : exception;
    Division_By_Zero : exception;
    
    type Kinds is (Unknown, Integer_Number, String_Of_Characters);

    type Object is private;

    procedure Dispose (Obj : in out Object);
    function Are_Equal (Obj1, Obj2 : in Object) return Boolean;
    function Get_Kind (Obj : in Object) return Kinds;
    function Get_Value (Obj : in Object) return Integer;  
    procedure Set_Value (Obj : in out Object; Val : Integer);
    function Get_Value (Obj : in Object) return String;  
    procedure Set_Value (Obj : in out Object; Val : String);

    procedure Copy( source : in Object; target : in out Object);

    procedure Change_Sign(Obj: in Object; result : in out Object);
    procedure Add (left,right: in object;result: in out object);
    procedure Substract(left,right:in object; result: in out object);
    procedure Multiply(left,right:in object; result: in out object);
    procedure Divide (left,right:in object; result: in out object);


private

    package Value_String is new Unbounded_String (1);

    type Value(What: Kinds := Unknown);
    type Object is access Value;
    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 others =>
                    null;
            end case;
        end record;

end Dynamic_Value;


package body Dynamic_Value is

    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 Unknown =>
                    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 Bad_Kind;
        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
            raise Bad_Kind;
        end if;
    end Get_Value;

    procedure Set_Value (Obj : in out Object; Val : String) is
    begin
      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 Set_Value;

    procedure Copy ( source: in Object; target: in out Object) is
    i: integer;
    begin
      case Get_Kind(Source) is
        when Integer_Number =>
           I:=get_Value(source);
           Set_Value(target,i);
        when others => null;   -- pour l'instant
      end case;
    end Copy; 

    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 Bad_Kind; 
      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 Bad_Kind; 
      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 Bad_Kind; 
      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 Bad_Kind; 
      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;


end Dynamic_Value