⟦977ff995c⟧

TextFile

separate (Generic_Fact_Base)
package body Class is

    type Instance (Size : Instance_Size := 0) is
        record  
            Value : Slots (1 .. Size);
        end record;

    Null_Instance : constant Instance :=
       (Size => 0, Value => (others => Slot.Null_Object));

    type Instance_Collection is array (Instance_Name range <>) of Instance;

    type Slot_Images (Size : Instance_Size := 0) is
        record  
            Value : Slot_Names_Images (1 .. Size);
        end record;

    type Object_Structure (Class_Size : Instance_Name) is
        record
            Class_Name    : Class_Names;
            Last_Instance : Instance_Name := Null_Instance_Name;
            Instances     : Instance_Collection (1 .. Class_Size) :=
               (others => Null_Instance);  
            Images        : Slot_Images;
        end record;

    function As_User_Object
                (The_Instance : Instance_Name; For_Class : Class.Object)
                return User_Object is
    begin
        return User_Object'(Isa => For_Class, Name => The_Instance);
    end As_User_Object;


    function Class_Of (The_Object : User_Object) return Class.Object is
    begin
        return The_Object.Isa;
    end Class_Of;


    function Class_Name_Of (The_Object : Object) return Class_Names is
    begin  
        if The_Object /= Null_Class then
            return The_Object.Class_Name;  
        else
            return Null_Class_Name;
        end if;
    end Class_Name_Of;


    function Class_Name_Of (The_Object : User_Object) return Class_Names is
    begin  
        return Class_Name_Of (The_Object.Isa);
    end Class_Name_Of;

    function Last_Instance (Of_Class : Object) return Instance_Name is
    begin
        return Of_Class.Last_Instance;
    end Last_Instance;


    function Is_Valid_Instance
                (The_Instance : Instance_Name; Of_Class : Class.Object)
                return Boolean is
    begin
        return Of_Class /= Null_Class and then
                  The_Instance /= Null_Instance_Name and then
                  The_Instance <= Of_Class.Last_Instance;
    end Is_Valid_Instance;

    function No_User_Objects return User_Objects is
    begin
        return (1 .. 0 => Null_User_Object);
    end No_User_Objects;

    function Make (Name       : Class_Names;
                   Class_Size : Natural;
                   Names      : Slot_Names_Images) return Object is
    begin
        return new Object_Structure'
                      (Class_Size    => Instance_Name (Class_Size),
                       Class_Name    => Name,
                       Last_Instance => 0,
                       Instances     => (others => Null_Instance),
                       Images        => (Size => Names'Length, Value => Names));
    end Make;

    procedure Make_Empty (The_Class : in out Class.Object) is
    begin
        The_Class.Last_Instance := Null_Instance_Name;  
        The_Class.Instances     := (others => Null_Instance);
    end Make_Empty;


    function Match (The_Slots : Slots; Against : Query.Patterns)
                   return Boolean is
    begin
        for I in The_Slots'Range loop  
            if not Predicate_Match (The_Slots (I), Against (I)) then  
                return False;
            end if;
        end loop;
        return True;
    end Match;


    function Match (The_Instance     : Instance_Name;
                    Against_Patterns : Query.Patterns;
                    Using_Class      : Class.Object) return Boolean is
        Instances : Instance_Collection renames Using_Class.Instances;
    begin
        return Instances (The_Instance).Size /= 0 and then
                  Match (The_Slots => Instances (The_Instance).Value,
                         Against   => Against_Patterns);
    end Match;


    function Slot_Name_Image (From_Class : Class.Object; For_Slot : Slot_Names)
                             return String is
        The_String_Object : Constant_String.Object;
    begin
        The_String_Object := From_Class.Images.Value (For_Slot);
        return Constant_String.Image (The_String_Object);
    end Slot_Name_Image;


    function Get (The_Object : User_Object) return Slots is
        The_Class    : Object        renames The_Object.Isa;
        The_Instance : Instance_Name renames The_Object.Name;
    begin
        return The_Class.Instances (The_Instance).Value;
    end Get;

    function Get (The_Object : User_Object; The_Slot : Slot_Names)
                 return Slot.Object is
        The_Class    : Object        renames The_Object.Isa;
        The_Instance : Instance_Name renames The_Object.Name;
    begin
        return The_Class.Instances (The_Instance).Value (The_Slot);
    end Get;


    procedure Add (To_Class : Class.Object; The_Instance : Slots) is
        Content       : Instance_Collection renames To_Class.Instances;
        Last_Instance : Instance_Name       renames To_Class.Last_Instance;
    begin
        for I in Content'Range loop
            if Content (I) = Null_Instance then
                Content (I) := Instance'(Size  => The_Instance'Length,
                                         Value => The_Instance);
                if I > Last_Instance then
                    Last_Instance := I;
                end if;
                return;
            end if;
        end loop;
        raise Overflow;
    end Add;


    procedure Delete (The_Object : User_Object) is
        The_Instance  : Instance_Name renames The_Object.Name;
        Content       : Instance_Collection renames The_Object.Isa.Instances;
        Last_Instance : Instance_Name renames The_Object.Isa.Last_Instance;
    begin
        Content (The_Instance) := Null_Instance;
        if Last_Instance = The_Instance then  
            Last_Instance := Last_Instance - 1;
            for I in reverse 1 .. Last_Instance loop
                exit when Content (I) /= Null_Instance;
                Last_Instance := I;
            end loop;
        end if;
    end Delete;


    procedure Change (The_Object : User_Object; To_Value : Slots) is
        The_Class    : Object        renames The_Object.Isa;
        The_Instance : Instance_Name renames The_Object.Name;
    begin
        The_Class.Instances (The_Instance) :=
           Instance'(Size => To_Value'Length, Value => To_Value);
    end Change;

    procedure Change (The_Object : User_Object;
                      The_Slot   : Slot_Names;
                      To_Value   : Slot.Object) is
        The_Class    : Object        renames The_Object.Isa;
        The_Instance : Instance_Name renames The_Object.Name;
    begin
        The_Class.Instances (The_Instance).Value (The_Slot) := To_Value;
    end Change;


    procedure Put_Slots (The_Slots  : Slots;
                         The_Images : Slot_Names_Images;
                         Where      : Output_Stream.Object :=
                            Output_Stream.Standard_Output) is
        First : Boolean := True;
        use Output_Stream;
    begin
        for I in The_Slots'Range loop
            if not First then
                Put (", ", Where);
                if I mod 2 /= 0 then
                    New_Line (Where);
                end if;
            else
                First := False;
            end if;
            Put (Constant_String.Image (The_Images (I)) & " =>", Where);
            Slot.Put (The_Slots (I), Where);
        end loop;
    end Put_Slots;


    procedure Put_Instance (The_Class    : Class.Object;
                            The_Instance : Instance;
                            Where        : Output_Stream.Object) is
        use Output_Stream;
    begin
        if The_Instance /= Null_Instance then
            Put_Line (Class_Names'Image (The_Class.Class_Name) & "'(", Where);
            Indent_Right (Where);
            Put_Slots (The_Slots  => The_Instance.Value,
                       The_Images => The_Class.Images.Value,
                       Where      => Where);
            Indent_Left (Where);
            Put_Line (")", Where);
        end if;
    end Put_Instance;


    procedure Default_Put (The_Object : User_Object;
                           Where      : Output_Stream.Object) is  
        The_Instance : Instance_Name renames The_Object.Name;
        The_Class    : Class.Object  renames The_Object.Isa;
        use Output_Stream;
    begin
        if Is_Valid_Instance (The_Instance, The_Class) then
            Put_Line (Class_Names'Image (The_Class.Class_Name) & "'(", Where);
            Indent_Right (Where);
            Put_Slots (The_Slots  => The_Class.Instances (The_Instance).Value,
                       The_Images => The_Class.Images.Value,
                       Where      => Where);
            Indent_Left (Where);
            Put_Line (")", Where);
        else
            Put_Line ("null_object", Where);
        end if;
    end Default_Put;


    procedure Default_Put (The_Collection : User_Objects;
                           Where          : Output_Stream.Object) is
        use Output_Stream;
    begin  
        Put_Line ("Collection'(", Where);
        Indent_Right (Where);
        if The_Collection'Length /= 0 then
            for I in The_Collection'Range loop
                Default_Put (The_Collection (I), Where);
            end loop;
        end if;
        Indent_Left (Where);
        New_Line (Where);
        Put_Line (")", Where);
    end Default_Put;


    procedure Generic_Put (The_Class : Class.Object;
                           Where     : Output_Stream.Object) is
        use Output_Stream;
    begin
        if The_Class /= Null_Class then
            Put_Line ("Class'(", Where);
            Indent_Right (Where);
            Put_Line
               ("Kind      => " & Class_Names'Image (The_Class.Class_Name),
                Where);
            Put_Line
               ("Size      => " & Instance_Name'Image (The_Class.Last_Instance),
                Where);

            Put_Line ("Instances => Collection'(", Where);
            Indent_Right (Where);
            for I in 1 .. Last_Instance (The_Class) loop
                Put (Integer (I), Where);
                Put (" => ", Where);
                Put (User_Object'(Isa => The_Class, Name => I), Where);
            end loop;
            Indent_Left (Where);
            Put_Line (")", Where);
            Indent_Left (Where);
            Put_Line (")", Where);
        end if;
    end Generic_Put;

    procedure Default_Put (The_Class : Class.Object;
                           Where     : Output_Stream.Object) is
        procedure Default_Class_Put is new Generic_Put;
    begin
        Default_Class_Put (The_Class, Where);
    end Default_Put;

end Class;
DataMuseum.dk

Rational R1000/400 Tapes

⟦977ff995c⟧ TextFile

Derivation

TextFile
