Multiple User Programs

Policy/Switches
-------
USER_LINK_BLOCK: 080200000

Link.des
--------------
OPTIONS
    MAP;
    ORIGIN ${USER_LINK_BLOCK}; -- updated to point to start of user program
END OPTIONS;
OBJECTS
    -- Board specific user configuration initialization.
    v_usr_conf;
    v_usr_data;
    v_usr_local;
END OBJECTS;
GROUP program_text IS
    text;
END GROUP;
FOR program_text USE AT *;
GROUP program_const IS
    const;
END GROUP;
FOR program_const USE AT *;
GROUP program_data IS
    data;
END GROUP;
GROUP program_data_image IS IMAGE program_data;
FOR program_data USE AT *;
FOR program_data_image USE AT *;
GROUP program_bss IS
    bss;
END GROUP;
FOR program_bss USE AT *;

Policy/Switches
--------------------------
USER_LINK_BLOCK2: 080180000

Link.des
---------------
OPTIONS
    MAP;
    ORIGIN ${USER_LINK_BLOCK2};             <-------  changed for user_n 
program  ---
END OPTIONS;END OPTIONS;
OBJECTS
    -- Board specific user configuration initialization.
    v_usr_conf;
    v_usr_data;
    v_usr_local;
END OBJECTS;
GROUP program_text IS
    text;
END GROUP;
FOR program_text USE AT *;
GROUP program_const IS
    const;
END GROUP;
FOR program_const USE AT *;
GROUP program_data IS
    data;
END GROUP;
GROUP program_data_image IS IMAGE program_data;
FOR program_data USE AT *;
FOR program_data_image USE AT *;
GROUP program_bss IS
    bss;
END GROUP;
FOR program_bss USE AT *;

V_Xtasking.Start_Program(
   Link_Block_Address => System.Address'Ref(16#80180000#),
    Key => Arg'Address,
    Terminate_Callout => System.No_Addr);

procedure Bind_Object
       (Name : in String;
        Object_Address : in System.Address);

procedure Resolve_Object
       (Name : in String;
        Object_Address : out System.Address;
        Wait_Time : in Duration := Wait_Forever);
function Resolve_Object
       (Name : in String;
        Wait_Time : in Duration := Wait_Forever)
         Return System.Address;

user_1 program
--------------
with V_Semaphores; use V_Semaphores;
package body User_1_Pkg is
    Shared_Semaphore : Binary_Semaphore_Id;
...
begin
    Shared_Semaphore := Create_Semaphore;
    Bind_Semaphore("Shared_Semaphore", Shared_Semaphore);
end;

user_2 program
--------------
with V_Semaphores; use V_Semaphores;
package body User_2_Pkg is
    Shared_Semaphore : Binary_Semaphore_Id;
...
begin
    -- Will wait until User_1 does a Bind_Semaphore().
    Shared_Semaphore := Resolve_Semaphore("Shared_Semaphore", Wait_Forever);
end;

procedure Bind_Procedure
   (Name : in String;
    Procedure_Address : in System.Address);
procedure Bind_Procedure
   (name : in String;
    Procedure_Program : in System.Program_Id;
    Procedure_Address : in System.Address);

procedure Resolve_Procedure
   (Name : in String;
    Procedure_Program : out System.Program_Id;
    Procedure_Address : out System.Address;
    Wait_Time : in Duration := Wait_Forever);

procedure Inter_Program_Call
    (Procedure_Program : in System.Program_Id;
     Procedure_Address : in System.Address;
     Argument : in System.Address);

procedure Called_Procedure(Argument : System.Address);

user_1 program
--------------
with System;        use System;
with V_Names;       use V_Names;
package body User_1_Pkg is
    procedure Shared_Proc(Arg : Address) is
    begin
        ...
    end Shared_Proc;
    ...
begin
    -- Shared_Proc() can be called after this package completes
    -- its elaboration
    Bind_Procedure("Shared_Proc", Shared_Proc'Address);
end User_1_Pkg;

user_2 program
--------------
with System;        use System;
with V_Names;       use V_Names;
with V_Xtasking;    use V_Xtasking;
package body User_2_Pkg is
    Shared_Proc_Prg : Program_Id;
    Shared_Proc_Addr : Address;
    procedure Call_It is
        Arg : Address := No_Addr;
    begin
        ...
        Inter_Program_Call(Shared_Proc_Prg, Shared_Proc_Addr, Arg);
        ...
    end Call_It;
    ...
begin
    -- Will wait until user_1 does a Bind_Procedure().
    Resolve_Procedure("Shared_Proc", Shared_Proc_Prg,
                      Shared_Proc_Addr, Wait_Forever);
end User_2_Pkg;

USER_LINK_BLOCK2: 080180000
LINKER_DESCRIPTION_FILE: <view>/Link.des

% cd .../krn_conf.ss/<target_view>
% apex_download -v v_krn_main
% cd .../widget_server.ss/<target_view>
% apex_download -v widget_server
% cd .../widget_test.ss/<target_view>
% apex_execute -v widget_test

** MAIN PROGRAM ABANDONED -- EXCEPTION "NAME_RESOLVE_TIMED_OUT" RAISED

-----------------------
---  widget.1.ada  ---
-----------------------
with Widget_Status;
use Widget_Status;
with Widget_Types;
package Widget is
    --
    -- Interface to the WIDGET services
    --

    subtype Widget_Id is Widget_Types.Widget_Id;
    No_Widget_Id : constant Widget_Id := Widget_Types.No_Widget_Id;

    -- Each service has two variations: one that raises an exception and
    -- another that returns status.

    function Create return Widget_Id;
    procedure Create (W : out Widget_Id; Status : out Status_T);

    procedure Delete (W : in out Widget_Id);
    procedure Delete (W : in out Widget_Id; Status : out Status_T);

    procedure Do_It (W : Widget_Id; In_Arg : Integer; Out_Arg : out Integer);
    procedure Do_It (W : Widget_Id;
                     In_Arg : Integer;
                     Out_Arg : out Integer;
                     Status : out Status_T);
end Widget;
-----------------------
---  widget.2.ada  ---
-----------------------
with System;
with System.Runtime;
with V_Names;
with V_Xtasking;
with Widget_Ipi;
use Widget_Ipi;
with Widget_Status;
use Widget_Status;
with Widget_Types;
package body Widget is

    -- Program_Id and Address of the Widget_Server's Dispatch procedure.
    -- Updated during elaboration by the call to V_Names.Resolve_Procedure.
    Service_Program_Id : System.Runtime.Program_Id;
    Service_Address : System.Address;

    -- Calls the corresponding service in the Widget_Server
    procedure Service (Params_Address : System.Address) is
    begin
        V_Xtasking.Inter_Program_Call (Procedure_Program => 
Service_Program_Id,
                                       Procedure_Address => Service_Address,
                                       Argument => Params_Address);
    end Service;
    pragma Inline_Only (Service);

    -- Each service has two variations: one that raises an exception and
    -- another that returns status.

    function Create return Widget_Id is
        W : Widget_Id;
        Status : Status_T;
    begin
        Create (W, Status);
        Check_Status (Status);   -- if status /= OK, then, raise an exception
        return W;
    end Create;

    procedure Create (W : out Widget_Id; Status : out Status_T) is
        Params : Widget_Ipi.Params_T (Svc_Create);
    begin
        Service (Params'Address);    -- do interprogram call
        W := Params.W;
        Status := Params.Status;
    end Create;

    procedure Delete (W : in out Widget_Id) is
        Status : Status_T;
    begin
        Delete (W, Status);
        Check_Status (Status);   -- if status /= OK, then, raise an exception
    end Delete;

    procedure Delete (W : in out Widget_Id; Status : out Status_T) is
        Params : Widget_Ipi.Params_T (Svc_Delete);
    begin
        Params.W := W;
        Service (Params'Address);    -- do interprogram call
        Status := Params.Status;
        W := No_Widget_Id;
    end Delete;

    procedure Do_It (W : Widget_Id; In_Arg : Integer; Out_Arg : out Integer) 
is
        Status : Status_T;
    begin
        Do_It (W, In_Arg, Out_Arg, Status);
        Check_Status (Status);   -- if status /= OK, then, raise an exception
    end Do_It;

    procedure Do_It (W : Widget_Id;
                     In_Arg : Integer;
                     Out_Arg : out Integer;
                     Status : out Status_T) is
        Params : Widget_Ipi.Params_T (Svc_Do_It);
    begin
        Params.W := W;
        Params.In_Arg := In_Arg;
        Service (Params'Address);    -- do interprogram call
        Out_Arg := Params.Out_Arg;
        Status := Params.Status;
    end Do_It;
begin
    -- Get the Program_Id and Address of the Widget_Server's Dispatch
    -- procedure. Give the Widget_Server at lease 10.0 seconds to
    -- complete its elaboration before it does a V_Names.Bind_Procedure().
    --
    -- If the Widget_Server program wasn't started, the exception,
    -- Name_Resolve_Timed_Out, will be raised after 10.0 seconds.
    V_Names.Resolve_Procedure (Name => Widget_Ipi.Service_Name,
                               Procedure_Program => Service_Program_Id,
                               Procedure_Address => Service_Address,
                               Wait_Time => 10.0);
end Widget;
-----------------------
---  widget_ipi.1.ada  ---
-----------------------
with System;
with Unchecked_Conversion;
with Widget_Status;
with Widget_Types;
package Widget_Ipi is
    --
    -- Interprogram interface between Widget clients and Widget server
    -- program
    --

    -- Name bound to the Widget_Server's Dispatch procedure
    Service_Name : constant String := "widget";

    -- Widget service id
    type Svc_Id_T is (Svc_Create, Svc_Delete, Svc_Do_It);

    -- variant record with the Widget service Id as the discriminant
    -- for passing parameters to the Dispatch procedure in the Widget_Server
    type Params_T (Svc_Id : Svc_Id_T) is
        record
            W : Widget_Types.Widget_Id;     -- in parameter
            Status : Widget_Status.Status_T;     -- out parameter

            case Svc_Id is
                when Svc_Create =>
                    null;
                when Svc_Delete =>
                    null;
                when Svc_Do_It =>
                    In_Arg : Integer;        -- in parameter
                    Out_Arg : Integer;        -- out parameter
            end case;
        end record;
    type A_Params_T is access Params_T;

    function To_A_Params_T is new Unchecked_Conversion
                                     (System.Address, A_Params_T);
end Widget_Ipi;
-----------------------
---  widget_status.1.ada  ---
-----------------------
package Widget_Status is
    --
    -- Exceptions and status codes for the Widget services
    --

    Widget_No_Memory, Widget_Invalid_Operation,
    Widget_Bad_Arg, Widget_System_Error : exception;

    type Status_T is (Ok, No_Memory, Invalid_Operation, Bad_Arg, 
System_Error);

    --
    -- Raise the exception corresponding to the specified status code.
    --
    procedure Check_Status (Status : Status_T);
    pragma Inline_Only (Check_Status);

end Widget_Status;
-----------------------
---  widget_status.2.ada  ---
-----------------------
package body Widget_Status is
    procedure Raise_Error (Status : Status_T) is
    begin
        case Status is
            when Ok =>
                null;
            when Invalid_Operation =>
                raise Widget_Invalid_Operation;
            when No_Memory =>
                raise Widget_No_Memory;
            when Bad_Arg =>
                raise Widget_Bad_Arg;
            when System_Error =>
                raise Widget_System_Error;
        end case;
    end Raise_Error;

    procedure Check_Status (Status : Status_T) is
    begin
        if Status /= Ok then
            Raise_Error (Status);
        end if;
    end Check_Status;
end Widget_Status;

-----------------------
---  widget_types.1.ada  ---
-----------------------
with System;
package Widget_Types is
    --
    -- Type definitions for the  Widget services
    --

    type Widget_Id is private;
    No_Widget_Id : constant Widget_Id;
private
    type Widget_Id is new System.Address;
    No_Widget_Id : constant Widget_Id := Widget_Id (System.No_Addr);
end Widget_Types;

-----------------------
---  widget_test.2.ada  ---
-----------------------
with Widget;
use Widget;
with Widget_Status;
with Simple_Io;
use Simple_Io;

procedure Widget_Test is
    W : Widget_Id;
    Out_Arg : Integer;
begin
    --
    -- Test program for calling the Widget services.  The Widget services
    -- are linked in a separate server program started by the kernel.
    --

    W := Create;

    Do_It (W, 10, Out_Arg);
    Do_It (W, 20, Out_Arg);
    Put ("last arg::");
    Put (Out_Arg);
    New_Line;
    if Out_Arg /= 10 then
        Put_Line ("Error!  Do_It returned bad out_arg.");
    end if;

    -- pass Do_It a bad argument
    begin
        Do_It (W, -1, Out_Arg);
        Put_Line ("Error!  Widget_Bads_Arg exception wasn't raised.");
    exception
        when Widget_Status.Widget_Bad_Arg =>
            Put_Line ("Got expected Widget_Bad_Arg exception.");
    end;

    Delete (W);

    -- Any operation on a deleted Widget is invalid
    begin
        Do_It (W, 10, Out_Arg);
        Put_Line ("Error!  Widget_Invalid_Operation exception wasn't 
raised.");
    exception
        when Widget_Status.Widget_Invalid_Operation =>
            Put_Line ("Got expected Widget_Invalid_Operation exception.");
    end;
end Widget_Test;

-------------------------
---  widget_main.2.ada  ---
-------------------------
with Widget_Server; -- include the package containing the Widget services
with V_Xtasking;

procedure Widget_Main is
begin
    --
    -- Main procedure for the Widget_Server program
    --

    -- Mark the Widget_Server as being a server program.  This inhibits
    -- us from exiting until all the client programs exit.
    V_Xtasking.Set_Is_Server_Program;
end Widget_Main;
-------------------------
---  widget_server.1.ada  ---
-------------------------
package Widget_Server is
    -- The Widget services are in the body.  They are made known to the
    -- world via V_Names.Bind_Procedure();

    -- Ada95 requires that for there to be a body to this package, that
    -- the spec must require it.  So we put a dummy procedure spec here.

    procedure Dummy;

end Widget_Server;
---------------------------
---  widget_server.2.ada  ---
---------------------------
with Widget_Ipi;
use Widget_Ipi; -- shared with Widget client
with Widget_Types;
use Widget_Types; -- shared with Widget client
with Widget_Status;
use Widget_Status; -- shared with Widget client
with V_Names;
with V_Xtasking;
with System;
with Unchecked_Conversion;
with Unchecked_Deallocation;

package body Widget_Server is
    --
    -- Widget services located in the server program.
    --

    Magic_Id : constant := 16#1234_5678#;
    type Widget_T is
        record
            Magic : Integer;
            Last_Arg : Integer;
        end record;
    type A_Widget_T is access Widget_T;

    function To_A_Widget_T is new Unchecked_Conversion (Widget_Id, 
A_Widget_T);
    function To_Widget_Id is new Unchecked_Conversion (A_Widget_T, 
Widget_Id);

    -- Forward declarations to the Widget services called by Dispatch().
    -- Unlike the Widget's client package specification, only the exception
    -- raising version of the services are implemented here.

    function Create return A_Widget_T;
    procedure Delete (W : A_Widget_T);
    procedure Do_It (W : A_Widget_T; In_Arg : Integer; Out_Arg : out Integer);

    -- During elaboration, the Widget's service name is bound to Dispatch
    -- via V_Names.Bind_Procedure.  Dispatch is called from the client
    -- programs via V_Xtasking.Inter_Program_Call.  Dispatch is passed the
    -- address of a variant record containing the service parameters.  This
    -- variant record uses the Widget service ID as the discriminant.  Both
    -- in and out parameters are passed in the record.
    --
    -- Exceptions raised by the Widget service routines are mapped to their
    -- corresponding error code and returned to the client program via the
    -- status field in the params record.

    procedure Dispatch (Params_Address : System.Address) is
        Params : A_Params_T := To_A_Params_T (Params_Address);
    begin
        Params.Status := Ok;
        case Params.Svc_Id is
            when Svc_Create =>
                Params.W := To_Widget_Id (Create);
            when Svc_Delete =>
                Delete (To_A_Widget_T (Params.W));
            when Svc_Do_It =>
                Do_It (To_A_Widget_T (Params.W), Params.In_Arg, 
Params.Out_Arg);
        end case;
    exception
        when Widget_Invalid_Operation =>
            Params.Status := Widget_Status.Invalid_Operation;
        when Widget_No_Memory =>
            Params.Status := Widget_Status.No_Memory;
        when Widget_Bad_Arg =>
            Params.Status := Widget_Status.Bad_Arg;
        when others =>
            Params.Status := Widget_Status.System_Error;
    end Dispatch;

    function Create return A_Widget_T is
        W : A_Widget_T;
    begin
        -- Memory is allocated from the Widget_Server program and not the
        -- client program.
        W := new Widget_T'(Magic_Id, 0);
        return W;
    exception
        when Storage_Error =>
            raise Widget_No_Memory;
    end Create;

    procedure Delete (W : A_Widget_T) is
        procedure Free is new Unchecked_Deallocation (Widget_T, A_Widget_T);
        My_W : A_Widget_T := W;
    begin
        if W = null or else W.Magic /= Magic_Id then
            raise Widget_Invalid_Operation;
        end if;
        My_W.Magic := 0;
        -- The freed Widget data structure is returned to the Widget_Server
        -- program and not the client program.
        Free (My_W);
    end Delete;

    procedure Do_It (W : A_Widget_T; In_Arg : Integer; Out_Arg : out Integer) 
is
    begin
        if W = null or else W.Magic /= Magic_Id then
            raise Widget_Invalid_Operation;
        end if;
        -- Since we were called via V_Xtasking.Inter_Program_Call, the
        -- client task and therefore this procedure is inhibited from
        -- being aborted.  However, any tasks we create can be aborted.
        declare
            task A is
                -- task a's parent is the Widget_Server program and not the
                -- client program.
                entry E (I : Integer; O : out Integer);
            end A;
            task body A is
            begin
                accept E (I : Integer; O : out Integer) do
                    if In_Arg < 0 then
                        raise Widget_Bad_Arg;
                    end if;
                    O := W.Last_Arg;
                    W.Last_Arg := I;
                end E;
            end A;
        begin
            A.E (In_Arg, Out_Arg);
        end;
    end Do_It;

    procedure Dummy is
    begin
        null;
    end Dummy;

begin
    --Enabled the Widget services to be called by the client programs.
    V_Names.Bind_Procedure (Name => Widget_Ipi.Service_Name,
                            Procedure_Address => Dispatch'Address);
end Widget_Server;

----------------------
---  v_krn_main.2.ada  ---
----------------------
------------------------------------------------------------------------
-- TASKING or NO TASKING KERNEL program's main procedure
------------------------------------------------------------------------
    with V_Krn_Conf;    -- kernel configuration
    with V_Reset;       -- reset vector
    with V_Start;       -- kernel entry point
    with V_Krn_Srv;     -- kernel service table
    
    -- If you start server programs, then, uncomment the following lines
    with System;
    with V_Krn_Aug;  -- kernel service augmentation
    
    -- With any board specific interrupt handler packages to be linked
    -- into kernel program
    procedure V_Krn_Main is
        pragma Suppress(All_Checks);
        pragma Suppress(Exception_Tables);
    begin
    -- Start the Widget_Server user_n program.
    --
        declare
            Prg: V_Krn_Aug.A_Krn_Pcb_T;
        begin
            Prg := V_Krn_Aug.Program_Start(
                Usr_Link_Block_A    => System.Address'Ref(16#8018_0000#),
                      -- Usr_Link_Block_A must be set to the address
                      -- of the widget server program's link_block.
                Key                 => System.Address'Ref(2),
                Terminate_Callout   => System.No_Addr);
        end;
    end V_Krn_Main;