lace.events: Add 'event_Sender'.

1-base/lace/source/events/interface/lace-subject.ads

@@ -22,6 +22,7 @@ is
    type fast_Views is array (Positive range <>) of fast_View;
 
 
+
    -------------
    -- Containers
    --
@@ -29,6 +30,7 @@ is
    type Observer_views is array (Positive range <>) of Observer.view;
 
 
+
    -------------
    -- Attributes
    --
@@ -36,6 +38,7 @@ is
    function Name (Self : in Item) return Event.subject_Name is abstract;
 
 
+
    ------------
    -- Observers
    --
@@ -46,14 +49,18 @@ is
    procedure deregister (Self : in out Item;   the_Observer : in Observer.view;
                                                of_Kind      : in Event.Kind) is abstract;
 
-   function  Observers      (Self : in Item;   of_Kind : in Event.Kind) return Observer_views is abstract;
+   function  Observers      (Self : in Item;   of_Kind      : in Event.Kind) return Observer_views is abstract;
-   function  observer_Count (Self : in Item)                            return Natural        is abstract;
+   function  observer_Count (Self : in Item)                                 return Natural        is abstract;
+
 
 
    -------------
    -- Operations
    --
 
+   -- Emit
+   --
+
    procedure emit (Self : access Item;   the_Event : in Event.item'Class := Event.null_Event) is abstract;
    --
    -- Communication errors are ignored.
@@ -66,7 +73,22 @@ is
 
    procedure use_event_Emitter (Self : in out Item) is abstract;
    --
-   -- Delegate event emission to a task to prevent blocking. Useful for reducing lag with DSA.
+   -- Delegate event emission to a task to prevent blocking. Useful for handling lag with DSA.
+
+
+
+   -- Send
+   --
+
+   procedure send (Self : access Item;   the_Event   : in Event.item'Class;
+                                         to_Observer : in Observer.view) is abstract;
+   --
+   -- Communication errors are ignored.
+
+
+   procedure use_event_Sender (Self : in out Item) is abstract;
+   --
+   -- Delegate 'send' to a task to prevent blocking. Useful for handling lag with DSA.
 
 
 

1-base/lace/source/events/mixin/lace-make_subject.adb

@@ -82,6 +82,10 @@ is
 
 
 
+   --------
+   --- Emit
+   --
+
    overriding
    procedure use_event_Emitter (Self : in out Item)
    is
@@ -148,7 +152,7 @@ is
       loop
          begin
             my_Observers (i).receive (the_Event,
-                                      from_Subject => Subject.item'Class (Self.all).Name);
+                                      from_Subject => Subject.view (Self).Name);
             if Subject.Logger /= null
             then
                Subject.Logger.log_Emit (Subject.view (Self),
@@ -169,6 +173,59 @@ is
 
 
 
+
+   --------
+   --- Send
+   --
+
+   overriding
+   procedure use_event_Sender (Self : in out Item)
+   is
+   begin
+      Self.Sender := new event_Sender.item;
+      Self.Sender.define (Self'unchecked_Access);
+   end use_event_Sender;
+
+
+
+   overriding
+   procedure send (Self : access Item;   the_Event   : in Event.item'Class;
+                                         to_Observer : in Observer.view)
+   is
+   begin
+      if Self.Sender = null
+      then
+         begin
+            to_Observer.receive (the_Event,
+                                 from_Subject => Subject.view (Self).Name);
+            if Subject.Logger /= null
+            then
+               Subject.Logger.log_Send (Subject.view (Self),
+                                        to_Observer,
+                                        the_Event);
+            end if;
+
+         exception
+            when system.RPC.communication_Error
+               | storage_Error =>
+
+               if Subject.Logger /= null
+               then
+                  Subject.Logger.log_Send (Subject.view (Self),
+                                           to_Observer,
+                                           the_Event);
+               end if;
+         end;
+
+      else
+         Self.Sender.add (the_Event,
+                          for_Observer => to_Observer,
+                          from_Subject => Self);
+      end if;
+   end send;
+
+
+
    -----------------
    -- Safe Observers
    --

1-base/lace/source/events/mixin/lace-make_subject.ads

@@ -7,6 +7,7 @@ with
 private
 with
      lace.event_Emitter,
+     lace.event_Sender,
 
      ada.Containers.Vectors,
      ada.Containers.indefinite_hashed_Maps;
@@ -29,6 +30,7 @@ is
    procedure destroy (Self : in out Item);
 
 
+
    -------------
    -- Attributes
    --
@@ -40,6 +42,7 @@ is
    function observer_Count (Self : in Item) return Natural;
 
 
+
    -------------
    -- Operations
    --
@@ -51,27 +54,40 @@ is
    procedure deregister (Self : in out Item;   the_Observer : in Observer.view;
                                                of_Kind      : in Event.Kind);
 
-   overriding
+
-   procedure emit (Self : access Item;   the_Event : in Event.item'Class := Event.null_Event);
+   -- Emit
+   --
 
    overriding
-   function  emit (Self : access Item;   the_Event : in Event.item'Class := Event.null_Event)
+   procedure emit (Self : access Item;   the_Event : in Event.item'Class := Event.null_Event);     -- TODO: Rid default.
+
+   overriding
+   function  emit (Self : access Item;   the_Event : in Event.item'Class := Event.null_Event)      -- TODO: Rid default.
                    return subject.Observer_views;
 
    overriding
    procedure use_event_Emitter (Self : in out Item);
+
+
+
+   -- Send
    --
-   -- Delegate event emission to a task to prevent blocking. Useful for reducing lag with DSA.
+   overriding
+   procedure send (Self : access Item;   the_Event   : in Event.item'Class;
+                                         to_Observer : in Observer.view);
+
+   overriding
+   procedure use_event_Sender (Self : in out Item);
 
 
 
 private
 
-   pragma Suppress (Container_Checks);     -- Suppress expensive tamper checks.
+   pragma suppress (container_Checks);     -- Suppress expensive tamper checks.
 
 
-   -------------------------
+   --------------------------
-   -- Event observer vectors
+   -- Event observer vectors.
    --
    use type Observer.view;
 
@@ -81,8 +97,8 @@ private
 
 
 
-   -------------------------------------
+   --------------------------------------
-   -- Event kind Maps of event observers
+   -- Event kind Maps of event observers.
    --
    use type Event.Kind;
    package event_kind_Maps_of_event_observers is new ada.Containers.indefinite_hashed_Maps (Event.Kind,
@@ -121,6 +137,7 @@ private
    --
 
    type event_Emitter_view is access all event_Emitter.item'Class;
+   type event_Sender_view  is access all event_Sender .item'Class;
 
    type Item is abstract limited new T
                                  and Subject.item
@@ -128,6 +145,7 @@ private
       record
          safe_Observers : make_Subject.safe_Observers;
          Emitter        : event_Emitter_view;
+         Sender         : event_Sender_view;
       end record;
 
 end lace.make_Subject;

1-base/lace/source/events/mixin/private/lace-event_sender.adb

@@ -0,0 +1,325 @@
+with
+     ada.Text_IO,
+     ada.Exceptions,
+     ada.unchecked_Deallocation;
+
+
+package body lace.event_Sender
+is
+
+   ---------------
+   --- Containers.
+   --
+
+   package string_Holders is new ada.Containers.indefinite_Holders (Element_type => String);
+   subtype string_Holder  is string_Holders.Holder;
+
+
+   package sender_Vectors  is new ada.Containers.Vectors (Positive,
+                                                          Sender_view);
+   subtype sender_Vector  is sender_Vectors.Vector;
+
+
+
+   -----------------
+   --- Safe senders.
+   --
+
+   protected
+   type safe_Senders
+   is
+      procedure add (new_Sender : in     Sender_view);
+      procedure get (a_Sender   :    out Sender_view);
+
+   private
+      all_Senders : sender_Vector;
+   end safe_Senders;
+
+   type safe_Senders_view is access all safe_Senders;
+
+
+
+
+   -----------
+   --- Sender.
+   --
+
+   task
+   type Sender
+   is
+      entry send (Self         : in Sender_view;
+                  the_Event    : in lace.Event.item'Class;
+                  To           : in lace.Observer.view;
+                  from_Subject : in String;
+                  Senders      : in safe_Senders_view);
+   end Sender;
+
+
+
+   task body Sender
+   is
+      Myself       : Sender_view;
+      Event        : event_Holder;
+      the_Observer : lace.Observer.view;
+      subject_Name : string_Holder;
+      sender_Pool  : safe_Senders_view;
+   begin
+      loop
+         begin
+            select
+               accept send (Self         : in Sender_view;
+                            the_Event    : in lace.Event.item'Class;
+                            To           : in lace.Observer.view;
+                            from_Subject : in String;
+                            Senders      : in safe_Senders_view)
+               do
+                  Event       .replace_Element (the_Event);
+                  subject_Name.replace_Element (from_Subject);
+
+                  Myself       := Self;
+                  the_Observer := To;
+
+                  sender_Pool  := Senders;
+               end send;
+            or
+               terminate;
+            end select;
+
+            the_Observer.receive (Event.Reference,
+                                  from_Subject => subject_Name.Element);
+            sender_Pool.add      (Myself);                                   -- Return the sender to the safe pool.
+
+         exception
+            when E : others =>
+               ada.Text_IO.new_Line;
+               ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E));
+               ada.Text_IO.put_Line ("Error detected in 'lace.event_Sender.Sender' task.");
+               ada.Text_IO.put_Line ("Subject:  '" & subject_Name.Element & "'.");
+               ada.Text_IO.put_Line ("Event:    '" & Event.Element'Image  & "'.");
+               ada.Text_IO.put_Line ("Observer: '" & the_Observer.Name    & "'.");
+               ada.Text_IO.put_Line ("Continuing.");
+               ada.Text_IO.new_Line (2);
+               sender_Pool.add      (Myself);                                -- Return the sender to the safe pool.
+         end;
+      end loop;
+
+   exception
+      when E : others =>
+         ada.Text_IO.new_Line;
+         ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E));
+         ada.Text_IO.put_Line ("Fatal error detected in 'lace.event_Sender.Sender' task.");
+         ada.Text_IO.put_Line ("Subject:  '" & subject_Name.Element & "'.");
+         ada.Text_IO.put_Line ("Event:    '" & Event.Element'Image  & "'.");
+         ada.Text_IO.put_Line ("Observer: '" & the_Observer.Name    & "'.");
+         ada.Text_IO.new_Line (2);
+   end Sender;
+
+
+
+
+   -------------------
+   --- Send delegator.
+   --
+
+   task body send_Delegator
+   is
+      the_subject_Name :         string_Holder;
+
+      the_Senders      : aliased safe_Senders;
+
+      the_Pairs        :         safe_Pairs_view;
+      new_Pairs        :         pair_Vector;
+      Done             :         Boolean     := False;
+
+
+      procedure shutdown
+      is
+         procedure free is new ada.unchecked_Deallocation (Sender,
+                                                           Sender_view);
+         the_Sender : Sender_view;
+      begin
+         loop
+            the_Senders.get (the_Sender);
+            exit when the_Sender = null;
+
+            free (the_Sender);
+         end loop;
+      end shutdown;
+
+
+   begin
+      accept start (Subject : in lace.Subject.view;
+                    Pairs   : in safe_Pairs_view)
+      do
+         the_Pairs := Pairs;
+         the_subject_Name.replace_Element (Subject.Name);
+      end start;
+
+
+      loop
+         select
+            accept stop
+            do
+               Done := True;
+            end stop;
+
+         else
+            null;
+         end select;
+
+
+         exit when     Done
+                   and the_Pairs.is_Empty;
+
+         the_Pairs.get (new_Pairs);
+
+         for each_Pair of new_Pairs
+         loop
+            declare
+               the_Sender : Sender_view;
+            begin
+               the_Senders.get (the_Sender);
+
+               if the_Sender = null
+               then
+                  the_Sender := new Sender;
+               end if;
+
+               the_Sender.send (Self         => the_Sender,
+                                the_Event    => each_Pair.Event.Element,
+                                To           => each_Pair.Observer,
+                                from_Subject => the_subject_Name.Element,
+                                Senders      => the_Senders'unchecked_Access);
+            exception
+               when E : others =>
+                  ada.Text_IO.new_Line;
+                  ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E));
+                  ada.Text_IO.new_Line;
+                  ada.Text_IO.put_Line ("Error detected in 'lace.event_Sender.send_Delegator'.");
+                  ada.Text_IO.put_Line ("Subject  '" & the_subject_Name.Element & "'.");
+                  ada.Text_IO.put_Line ("Observer '" & each_Pair.Observer.Name  & "'.");
+                  ada.Text_IO.put_Line ("Event    '" & each_Pair.Event'Image    & "'.");
+                  ada.Text_IO.put_Line ("Continuing.");
+                  ada.Text_IO.new_Line (2);
+            end;
+         end loop;
+
+         delay 0.001;
+      end loop;
+
+      shutdown;
+
+   exception
+      when E : others =>
+         ada.Text_IO.new_Line;
+         ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E));
+         ada.Text_IO.new_Line;
+         ada.Text_IO.put_Line ("Fatal error detected in 'lace.event_Sender.send_Delegator' for subject '" & the_subject_Name.Element & "'.");
+         ada.Text_IO.new_Line (2);
+
+         shutdown;
+   end send_Delegator;
+
+
+
+
+   ---------------
+   --- Safe Pairs.
+   --
+
+   protected body safe_Pairs
+   is
+
+      procedure add (new_Pair : in event_observer_Pair)
+      is
+      begin
+         all_Pairs.append (new_Pair);
+      end add;
+
+
+
+      procedure get (the_Pairs : out pair_Vector)
+      is
+      begin
+         the_Pairs := all_Pairs;
+         all_Pairs.clear;
+      end get;
+
+
+
+      function is_Empty return Boolean
+      is
+      begin
+         return all_Pairs.is_Empty;
+      end is_Empty;
+
+   end safe_Pairs;
+
+
+
+
+   -----------------
+   --- Safe senders.
+   --
+
+   protected body safe_Senders
+   is
+
+      procedure add (new_Sender : in Sender_view)
+      is
+      begin
+         all_Senders.append (new_Sender);
+      end add;
+
+
+
+      procedure get (a_Sender : out Sender_view)
+      is
+      begin
+         if all_Senders.is_Empty
+         then
+            a_Sender := null;
+         else
+            a_Sender := all_Senders.last_Element;
+            all_Senders.delete_Last;
+         end if;
+      end get;
+
+   end safe_Senders;
+
+
+
+
+   ----------------------
+   --- event_Sender item.
+   --
+
+   procedure define (Self : in out Item;   Subject : in lace.Subject.view)
+   is
+   begin
+      Self.Delegator.start (Subject => Subject,
+                            Pairs   => Self.Pairs'unchecked_Access);
+   end define;
+
+
+
+   procedure destruct (Self : in out Item)
+   is
+   begin
+       Self.Delegator.stop;
+   end destruct;
+
+
+
+   procedure add (Self : in out Item;   new_Event    : in lace.Event.item'Class;
+                                        for_Observer : in lace.Observer.view;
+                                        from_Subject : in lace.Subject.view)
+   is
+      use event_Holders;
+   begin
+      Self.Pairs.add (event_observer_Pair' (Event    => to_Holder (new_Event),
+                                            Observer => for_Observer));
+   end add;
+
+
+end lace.event_Sender;

1-base/lace/source/events/mixin/private/lace-event_sender.ads

@@ -0,0 +1,107 @@
+with
+     lace.Event,
+     lace.Subject,
+     lace.Observer;
+
+
+private
+with
+     ada.Containers.Vectors,
+     ada.Containers.indefinite_Holders;
+
+
+package lace.event_Sender with remote_Types
+is
+
+   type Item is tagged limited private;
+
+
+   procedure define   (Self : in out Item;   Subject   : in lace.Subject.view);
+   procedure destruct (Self : in out Item);
+
+   procedure add      (Self : in out Item;   new_Event    : in lace.Event.item'Class;
+                                             for_Observer : in lace.Observer.view;
+                                             from_Subject : in lace.Subject.view);
+
+
+private
+
+   use type lace.Event.item'Class;
+   package event_Holders  is new ada.Containers.indefinite_Holders (Element_type => lace.Event.item'Class);
+   subtype event_Holder   is event_Holders.Holder;
+
+
+
+   type event_observer_Pair is
+      record
+         Event    : event_Holder;
+         Observer : lace.Observer.view;
+      end record;
+
+
+
+   -----------
+   --- Sender.
+   --
+
+   type Sender;
+   type Sender_view is access Sender;
+
+
+
+   -------------------------------
+   --- event_observer_Pair_Vector.
+   --
+
+   package pair_Vectors is new ada.Containers.Vectors (Positive,
+                                                       event_observer_Pair);
+   subtype pair_Vector  is pair_Vectors.Vector;
+
+
+
+   ---------------
+   --- Safe pairs.
+   --
+
+   protected
+   type safe_Pairs
+   is
+      procedure add (new_Pair  : in     event_observer_Pair);
+      procedure get (the_pairs :    out pair_Vector);
+
+      function  is_Empty return Boolean;
+
+   private
+      all_Pairs : pair_Vector;
+   end safe_Pairs;
+
+   type safe_Pairs_view is access all safe_Pairs;
+
+
+
+   -------------------
+   --- Send delegator.
+   --
+
+   task
+   type send_Delegator
+   is
+      entry start (Subject : in lace.Subject.view;
+                   Pairs   : in safe_Pairs_view);
+      entry stop;
+   end send_Delegator;
+
+
+
+   ---------
+   --- Item.
+   --
+
+   type Item is tagged limited
+      record
+         Pairs     : aliased safe_Pairs;
+         Delegator :         send_Delegator;
+      end record;
+
+
+end lace.event_Sender;

1-base/lace/source/events/utility/lace-event-logger-text.adb

@@ -78,6 +78,10 @@ is
 
 
 
+   function to_Integer is new ada.unchecked_Conversion (lace.Observer.view,
+                                                        long_Integer);
+
+
    overriding
    procedure log_Emit (Self : in out Item;   From      : in Subject .view;
                                              To        : in Observer.view;
@@ -85,10 +89,9 @@ is
    is
       function to_Name return String
       is
-         function to_Integer is new ada.unchecked_Conversion (lace.Observer.view,
-                                                              long_Integer);
       begin
          return To.Name;
+
       exception
             when system.RPC.communication_Error
                | storage_Error =>
@@ -103,12 +106,42 @@ is
 
       new_Line (Self.File);
       put_Line (Self.File,   "Emit     => "
-                           & From.Name & "  sends       " & Name_of (Kind_of (the_Event))
+                           & From.Name & "  emits       " & Name_of (Kind_of (the_Event))
                            & " to "    & to_Name & ".");
    end log_Emit;
 
 
 
+   overriding
+   procedure log_Send (Self : in out Item;   From      : in Subject .view;
+                                             To        : in Observer.view;
+                                             the_Event : in Event.item'Class)
+   is
+      function to_Name return String
+      is
+      begin
+         return To.Name;
+
+      exception
+         when system.RPC.communication_Error
+            | storage_Error =>
+            return "dead Observer (" & to_Integer (To)'Image & ")";
+      end to_Name;
+
+   begin
+      if Self.Ignored.contains (to_Kind (the_Event'Tag))
+      then
+         return;
+      end if;
+
+      new_Line (Self.File);
+      put_Line (Self.File,   "Send     => "
+                           & From.Name & "  sends       " & Name_of (Kind_of (the_Event))
+                           & " to "    & to_Name & ".");
+   end log_Send;
+
+
+
    overriding
    procedure log_Relay (Self : in out Item;   From      : in Observer.view;
                                               To        : in Observer.view;

1-base/lace/source/events/utility/lace-event-logger-text.ads

@@ -61,6 +61,10 @@ is
                                                  To           : in Observer.view;
                                                  the_Event    : in Event.item'Class);
    overriding
+   procedure log_Send     (Self : in out Item;   From         : in Subject .view;
+                                                 To           : in Observer.view;
+                                                 the_Event    : in Event.item'Class);
+   overriding
    procedure log_Relay    (Self : in out Item;   From         : in Observer.view;
                                                  To           : in Observer.view;
                                                  the_Event    : in Event.item'Class);

1-base/lace/source/events/utility/lace-event-logger.ads

@@ -51,6 +51,10 @@ is
                                                  To           : in Observer.view;
                                                  the_Event    : in Event.item'Class) is abstract;
 
+   procedure log_Send     (Self : in out Item;   From         : in Subject .view;
+                                                 To           : in Observer.view;
+                                                 the_Event    : in Event.item'Class) is abstract;
+
    procedure log_Relay    (Self : in out Item;   From         : in Observer.view;
                                                  To           : in Observer.view;
                                                  the_Event    : in Event.item'Class) is abstract;