DataMuseum.dk

top - download

    Length: 6204 (0x183c)
    Types: TextFile
    Names: »B«

└─⟦149519bd4⟧ Bits:30000546 8mm tape, Rational 1000, !projects 93-07-13
    └─ ⟦124ff5788⟧ »DATA« 
        └─⟦this⟧ 
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─ ⟦129cab021⟧ »DATA« 
        └─⟦this⟧ 
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
    └─ ⟦6f12a12be⟧ »DATA« 
        └─⟦this⟧ 
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
    └─ ⟦d65440be7⟧ »DATA« 
        └─⟦this⟧ 

TextFile

with System;
with Text_Io;

package body Ihm is

    procedure Init_C;
    pragma Interface (C, Init_C);
    pragma Interface_Information (Init_C, ".InitFrame");

    procedure Action_C (Fid : Integer;
                        Fctn : System.Address;
                        Field : System.Address;
                        Value : System.Address);
    pragma Interface (C, Action_C);
    pragma Interface_Information (Action_C, ".Action");

    procedure Action (Wid : Window_Id;
                      Fctn : String;
                      Field : String;
                      Value : String) is
        C_Fctn : constant String := Fctn & Ascii.Nul;
        C_Field : constant String := Field & Ascii.Nul;
        C_Value : constant String := Value & Ascii.Nul;
    begin
        Action_C (Wid, C_Fctn (C_Fctn'First)'Address,
                  C_Field (C_Field'First)'Address,
                  C_Value (C_Value'First)'Address);
    end Action;

    function String_Length_C (Ptr : System.Address) return Integer;
    pragma Interface (C, String_Length_C);
    pragma Interface_Information (String_Length_C, ".strlen");

    function String_C_To_Ada (S : System.Address) return String is
        Str : String (1 .. String_Length_C (S));
        for Str use at S;
        --Ptr : array (1 .. String_Length_C (S)) of Character;
        --for Ptr use at S;
        --Str : String (1 .. String_Length_C (S));
    begin
        --for I in Str'Range loop
        --    Str (I) := Ptr (I);
        --end loop;
        return Str;
    end String_C_To_Ada;


    package body Window is

        function Get_Id_C (Window_Name : System.Address) return Integer;
        pragma Interface (C, Get_Id_C);
        pragma Interface_Information (Get_Id_C, ".GetFrameId");

        function Get_Name_C (Local_Frame : Integer) return System.Address;
        pragma Interface (C, Get_Name_C);
        pragma Interface_Information (Get_Name_C, ".GetFrameName");

        function Nb_Wid_C return Integer;
        pragma Interface (C, Nb_Wid_C);
        pragma Interface_Information (Nb_Wid_C, ".MaxFrame");

        procedure Put_Event_C (Fid : Integer;
                               Fctn : System.Address;
                               Field : System.Address;
                               Value : System.Address);
        pragma Interface (C, Put_Event_C);
        pragma Interface_Information (Put_Event_C, ".PutEventAda");

        ------------------------------------------------------------

        function Name (Wid : Window_Id) return String is
        begin
            return String_C_To_Ada (Get_Name_C (Wid));
        end Name;

        function Nb_Wid return Window_Id is
        begin
            return Nb_Wid_C;
        end Nb_Wid;

        function Open (Name : String) return Window_Id is
            C_Message : constant String := Name & Ascii.Nul;
            Wid : Window_Id;
        begin
            Wid := Get_Id_C (C_Message (C_Message'First)'Address);
            Action (Wid, "OpenWindow", Name, "");
            return Wid;
        end Open;

        procedure Close (Wid : Window_Id) is
        begin
            Action (Wid, "CloseWindow", "", "");
        end Close;

        procedure Put_Field (Wid : Window_Id; Field : String; Value : String) is
            C_Fctn : constant String := "PutField" & Ascii.Nul;
            C_Field : constant String := Field & Ascii.Nul;
            C_Value : constant String := Value & Ascii.Nul;
        begin
            Put_Event_C (Wid, C_Fctn (C_Fctn'First)'Address,
                         C_Field (C_Field'First)'Address,
                         C_Value (C_Value'First)'Address);
        end Put_Field;

        procedure Display_Field
                     (Wid : Window_Id; Field : String; Value : String) is
        begin
            Action (Wid, "PutField", Field, Value);
        end Display_Field;

    end Window;

    package body Event is

        function Empty_C (Wid : Integer) return Integer;
        pragma Interface (C, Empty_C);
        pragma Interface_Information (Empty_C, ".Empty");

        function Get_Type_C (Wid : Integer) return System.Address;
        pragma Interface (C, Get_Type_C);
        pragma Interface_Information (Get_Type_C, ".GetType");

        function Get_Field_C (Wid : Integer) return System.Address;
        pragma Interface (C, Get_Field_C);
        pragma Interface_Information (Get_Field_C, ".GetField");

        function Get_Value_C (Fid : Integer) return System.Address;
        pragma Interface (C, Get_Value_C);
        pragma Interface_Information (Get_Value_C, ".GetValue");

        procedure Next_C (Wid : Integer);
        pragma Interface (C, Next_C);
        pragma Interface_Information (Next_C, ".Next");


        function Get_Event (Wid : Window_Id) return Kind is
            Event_String : constant String :=
               String_C_To_Ada (Get_Type_C (Wid));
        begin
            if Event_String = "PushButton" then
                return Pushbutton;
            elsif Event_String = "FieldEnter" then
                return Fieldenter;
            elsif Event_String = "PutField" then
                return Putfield;
            end if;
            return Unknown;
        end Get_Event;

        function Get_Field (Wid : Window_Id) return String is
        begin
            return String_C_To_Ada (Get_Field_C (Wid));
        end Get_Field;

        function Get_Value (Wid : Window_Id) return String is
        begin
            return String_C_To_Ada (Get_Value_C (Wid));
        end Get_Value;

        procedure Next (Wid : Window_Id) is
        begin
            Next_C (Wid);
        end Next;

        function Empty (Wid : Window_Id) return Boolean is
        begin
            if Empty_C (Wid) = 1 then
                return True;
            else
                return False;
            end if;
        end Empty;

    end Event;

    package body Xt is

        procedure Process_Event_C;
        pragma Interface (C, Process_Event_C);
        pragma Interface_Information (Process_Event_C, ".ProcessEvent");

        procedure Process_Event is
        begin
            Process_Event_C;
        end Process_Event;

    end Xt;

begin
    Init_C;

end Ihm;