DataMuseum.dk

top - download

    Length: 5157 (0x1425)
    Types: TextFile
    Names: »B«

└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
    └─ ⟦d65440be7⟧ »DATA« 
        └─⟦this⟧ 

TextFile

with Class_String;
with Bounded_String;

package body Object is

    function Create (Class : E_Class; Object : Index) return Reference is
    begin
        return Reference'(Id_Class => Class, Id_Object => Object);
    end Create;

    function Get (From : Reference) return E_Class is
    begin
        return From.Id_Class;
    end Get;

    function Get (From : Reference) return Index is
    begin
        return From.Id_Object;
    end Get;

    procedure Put (This : E_Class; Into : out Reference) is
    begin
        Into.Id_Class := This;
    end Put;

    procedure Put (This : Index; Into : out Reference) is
    begin
        Into.Id_Object := This;
    end Put;

    function Create return Keyword is
    begin
        return Void_Keyword;
    end Create;

    function Get (From : Keyword) return Tiny_String is
    begin
        return Message_Name.First (From.Name);
    end Get;

    function Get (From : Keyword) return Reference is
    begin
        return Message_Argument.First (From.Argument);
    end Get;

    procedure Put (This : Tiny_String;
                   And_This : Reference;
                   Into : in out Keyword) is
    begin
        Into.Name := Message_Name.Make (This, Into.Name);
        Into.Argument := Message_Argument.Make (And_This, Into.Argument);
    end Put;

    procedure Put (This : Tiny_String; Into : in out Keyword) is
    begin
        Into.Name := Message_Name.Make (This, Into.Name);
    end Put;

    procedure Put (This : Reference; Into : in out Keyword) is
    begin  
        Into.Argument := Message_Argument.Make (This, Into.Argument);
    end Put;

    procedure Next (From : in out Keyword) is
    begin
        From.Name := Message_Name.Rest (From.Name);
        From.Argument := Message_Argument.Rest (From.Argument);
    end Next;

    function Is_Empty (This : Keyword) return Boolean is
    begin
        return Message_Name.Is_Empty (This.Name) or
                  Message_Argument.Is_Empty (This.Argument);
    end Is_Empty;

    function Is_Empty_Name (This : Keyword) return Boolean is
    begin
        return Message_Name.Is_Empty (This.Name);
    end Is_Empty_Name;

    function Is_Empty_Argument (This : Keyword) return Boolean is
    begin
        return Message_Argument.Is_Empty (This.Argument);
    end Is_Empty_Argument;

    procedure Free (This : in out Keyword) is
    begin
        Message_Name.Free (This.Name);
        Message_Argument.Free (This.Argument);
    end Free;

    function Create return Binary is
    begin
        return Void_Binary;
    end Create;

    function Get (From : Binary) return Tiny_String is
    begin
        return From.Name;
    end Get;

    function Get (From : Binary) return Reference is
    begin
        return From.Argument;
    end Get;

    procedure Put (This : Tiny_String; Into : out Binary) is
    begin
        Into.Name := This;
    end Put;

    procedure Put (This : Reference; Into : out Binary) is
    begin
        Into.Argument := This;
    end Put;

    function Create return Unary is
        Message : Unary;
    begin
        return Message;
    end Create;

    function Get (From : Unary) return Tiny_String is
    begin
        return From;
    end Get;

    procedure Put (This : Tiny_String; Into : out Unary) is
    begin
        Into := This;
    end Put;

    function Send (This_Message : Keyword; To : Reference) return Reference is
        package Name renames Object.Message_Name;
        package Argument renames Object.Message_Argument;
    begin
        case To.Id_Class is
            when Integer_Class =>
                null;
            when Boolean_Class =>
                null;
            when String_Class =>
                return Class_String.Send (This_Message, To);
            when Turtle_Class =>
                null;
            when Pen_Class =>
                null;
            when Block_Class =>
                null;
            when Void_Class =>
                return To;
        end case;
    end Send;

    function Send (This_Message : Binary; To : Reference) return Reference is
    begin
        case To.Id_Class is
            when Integer_Class =>
                null;
            when Boolean_Class =>
                null;
            when String_Class =>
                return Class_String.Send (This_Message, To);
            when Turtle_Class =>
                null;
            when Pen_Class =>
                null;
            when Block_Class =>
                null;
            when Void_Class =>
                return To;
        end case;
    end Send;

    function Send (This_Message : Unary; To : Reference) return Reference is
    begin
        case To.Id_Class is
            when Integer_Class =>
                null;
            when Boolean_Class =>
                null;
            when String_Class =>
                return Class_String.Send (This_Message, To);
            when Turtle_Class =>
                null;
            when Pen_Class =>
                null;
            when Block_Class =>
                null;
            when Void_Class =>
                return To;
        end case;
    end Send;
end Object;