nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lace.event: Add event sequence to subjects.

Browse Source
This commit is contained in:
Rod Kay
2024-10-10 20:25:35 +11:00
parent 37e3e74783
commit ad38c1ec3d
20 changed files with 263 additions and 133 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
1-base/lace/source/events/concrete/lace-observer-deferred.ads
View File

@@ -1,5 +1,5 @@
with with
lace.make_Observer.deferred, lace.event.make_Observer.deferred,
lace.Any; lace.Any;
private private
@@ -36,8 +36,8 @@ private
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Observer is new lace.make_Observer (Any.limited_item); package Observer is new event.make_Observer (Any.limited_item);
package Deferred is new Observer.deferred (Observer.item); package Deferred is new Observer.deferred (Observer.item);
type Item is limited new Deferred.item with type Item is limited new Deferred.item with
record record

4
1-base/lace/source/events/concrete/lace-observer-instant.ads
View File

@@ -1,5 +1,5 @@
with with
lace.make_Observer, lace.event.make_Observer,
lace.Any; lace.Any;
private private
@@ -35,7 +35,7 @@ private
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Observer is new make_Observer (Any.limited_item); package Observer is new event.make_Observer (Any.limited_item);
type Item is limited new Observer.item with type Item is limited new Observer.item with
record record

4
1-base/lace/source/events/concrete/lace-subject-local.ads
View File

@@ -1,5 +1,5 @@
with with
lace.make_Subject, lace.event.make_Subject,
lace.Any; lace.Any;
private private
@@ -39,7 +39,7 @@ private
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Subject is new make_Subject (Any.limited_item); package Subject is new event.make_Subject (Any.limited_item);
type Item is limited new Subject.item with type Item is limited new Subject.item with
record record

10
1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.ads
View File

@@ -1,8 +1,8 @@
with with
lace.Subject, lace.Subject,
lace.Observer, lace.Observer,
lace.make_Subject, lace.event.make_Subject,
lace.make_Observer.deferred, lace.event.make_Observer.deferred,
lace.Any; lace.Any;
private private
@@ -42,9 +42,9 @@ private
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Subject is new make_Subject (Any.limited_item); package Subject is new event.make_Subject (Any.limited_item);
package Observer is new make_Observer (Subject .item); package Observer is new event.make_Observer (Subject .item);
package Deferred is new Observer.deferred (Observer .item); package Deferred is new Observer.deferred (Observer .item);
type Item is limited new Deferred.item with type Item is limited new Deferred.item with
record record

8
1-base/lace/source/events/concrete/lace-subject_and_instant_observer.ads
View File

@@ -1,6 +1,6 @@
with with
lace.make_Subject, lace.event.make_Subject,
lace.make_Observer, lace.event.make_Observer,
lace.Any, lace.Any,
lace.Subject, lace.Subject,
lace.Observer; lace.Observer;
@@ -39,8 +39,8 @@ private
pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. pragma Suppress (Container_Checks); -- Suppress expensive tamper checks.
package Subject is new make_Subject (Any.limited_item); package Subject is new event.make_Subject (Any.limited_item);
package Observer is new make_Observer (Subject .item); package Observer is new event.make_Observer (Subject .item);
type Item is limited new Observer.item with type Item is limited new Observer.item with
record record

6
1-base/lace/source/events/interface/lace-observer.ads
View File

@@ -29,6 +29,7 @@ is
function Name (Self : in Item) return event.observer_Name is abstract; function Name (Self : in Item) return event.observer_Name is abstract;
------------ ------------
-- Responses -- Responses
-- --
@@ -45,15 +46,18 @@ is
(Self : in out Item; To : in Observer.view) is abstract; (Self : in out Item; To : in Observer.view) is abstract;
------------- -------------
-- Operations -- Operations
-- --
procedure receive (Self : access Item; the_Event : in Event.item'Class; procedure receive (Self : access Item; the_Event : in Event.item'Class;
from_Subject : in event.subject_Name) is abstract; from_Subject : in event.subject_Name;
Sequence : in event.sequence_Id) is abstract;
-- --
-- Accepts an Event from a Subject. -- Accepts an Event from a Subject.
procedure respond (Self : access Item) is abstract; procedure respond (Self : access Item) is abstract;
-- --
-- Performs the Response for (and then removes) each pending Event. -- Performs the Response for (and then removes) each pending Event.

5
1-base/lace/source/events/interface/lace-subject.ads
View File

@@ -35,8 +35,9 @@ is
-- Attributes -- Attributes
-- --
function Name (Self : in Item) return Event.subject_Name is abstract; function Name (Self : in Item) return Event.subject_Name is abstract;
function next_Sequence (Self : in out Item; for_Observer : in Observer.view) return event.sequence_Id is abstract;
-- function next_Sequence (Self : in out Item; for_Observer : in event.observer_Name) return event.sequence_Id is abstract;
------------ ------------

10
1-base/lace/source/events/lace-event.ads
View File

@@ -9,7 +9,7 @@ package lace.Event
is is
pragma Pure; pragma Pure;
type Item is tagged private; type Item is tagged null record;
subtype subject_Name is String; subtype subject_Name is String;
@@ -31,15 +31,7 @@ is
function Hash (the_Kind : in Kind) return ada.Containers.Hash_type; function Hash (the_Kind : in Kind) return ada.Containers.Hash_type;
private
type sequence_Id is range 0 .. 2**32 - 1; type sequence_Id is range 0 .. 2**32 - 1;
type Item is tagged
record
s_Id : sequence_Id;
end record;
end lace.Event; end lace.Event;

8
1-base/lace/source/events/mixin/lace-make_observer.adb → 1-base/lace/source/events/mixin/lace-event-make_observer.adb
View File

@@ -2,11 +2,10 @@ with
lace.Event.Logger, lace.Event.Logger,
lace.Event.utility, lace.Event.utility,
ada.unchecked_Conversion,
ada.unchecked_Deallocation; ada.unchecked_Deallocation;
package body lace.make_Observer package body lace.event.make_Observer
is is
use type Event.Logger.view; use type Event.Logger.view;
@@ -64,7 +63,8 @@ is
overriding overriding
procedure receive (Self : access Item; the_Event : in Event.item'Class; procedure receive (Self : access Item; the_Event : in Event.item'Class;
from_Subject : in Event.subject_Name) from_Subject : in Event.subject_Name;
Sequence : in sequence_Id)
is is
begin begin
Self.Responses.receive (Self, the_Event, from_Subject); Self.Responses.receive (Self, the_Event, from_Subject);
@@ -248,4 +248,4 @@ is
end safe_Responses; end safe_Responses;
end lace.make_Observer; end lace.event.make_Observer;

9
1-base/lace/source/events/mixin/lace-make_observer.ads → 1-base/lace/source/events/mixin/lace-event-make_observer.ads
View File

@@ -1,5 +1,4 @@
with with
lace.Event,
lace.Response, lace.Response,
lace.Observer; lace.Observer;
@@ -12,7 +11,7 @@ with
generic generic
type T is abstract tagged limited private; type T is abstract tagged limited private;
package lace.make_Observer package lace.event.make_Observer
-- --
-- Makes a user class T into an event Observer. -- Makes a user class T into an event Observer.
-- --
@@ -49,7 +48,8 @@ is
overriding overriding
procedure receive (Self : access Item; the_Event : in Event.item'Class; procedure receive (Self : access Item; the_Event : in Event.item'Class;
from_Subject : in Event.subject_Name); from_Subject : in Event.subject_Name;
Sequence : in sequence_Id);
overriding overriding
procedure respond (Self : access Item); procedure respond (Self : access Item);
@@ -63,7 +63,6 @@ private
---------------------- ----------------------
-- Event response maps -- Event response maps
-- --
use type event.Kind;
use type Response.view; use type Response.view;
package event_response_Maps is new ada.Containers.indefinite_hashed_Maps (key_type => Event.Kind, package event_response_Maps is new ada.Containers.indefinite_hashed_Maps (key_type => Event.Kind,
@@ -139,4 +138,4 @@ private
Responses : safe_Responses; Responses : safe_Responses;
end record; end record;
end lace.make_Observer; end lace.event.make_Observer;

88
1-base/lace/source/events/mixin/lace-make_subject.adb → 1-base/lace/source/events/mixin/lace-event-make_subject.adb
View File

@@ -5,7 +5,7 @@ with
ada.unchecked_Deallocation; ada.unchecked_Deallocation;
package body lace.make_Subject package body lace.event.make_Subject
is is
use type Event.Logger.view; use type Event.Logger.view;
@@ -49,6 +49,18 @@ is
overriding
function next_Sequence (Self : in out Item; for_Observer : in Observer.view) return event.sequence_Id
is
Sequence : sequence_Id;
begin
Self.sequence_Id_Map.get_Next (Sequence,
for_Observer);
return Sequence;
end next_Sequence;
------------- -------------
-- Operations -- Operations
-- --
@@ -58,7 +70,8 @@ is
of_Kind : in Event.Kind) of_Kind : in Event.Kind)
is is
begin begin
Self.safe_Observers.add (the_Observer, of_Kind); Self.safe_Observers .add (the_Observer, of_Kind);
Self.sequence_Id_Map.add (the_Observer);
if Subject.Logger /= null if Subject.Logger /= null
then then
@@ -110,12 +123,18 @@ is
declare declare
use lace.Event.utility; use lace.Event.utility;
my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag)); my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag));
Sequence : sequence_Id;
begin begin
for i in my_Observers'Range for i in my_Observers'Range
loop loop
begin begin
Self.sequence_Id_Map.get_Next (Sequence,
for_Observer => my_Observers (i));
my_Observers (i).receive (the_Event, my_Observers (i).receive (the_Event,
from_Subject => Subject.item'Class (Self.all).Name); from_Subject => Subject.item'Class (Self.all).Name,
Sequence => Sequence);
if Subject.Logger /= null if Subject.Logger /= null
then then
Subject.Logger.log_Emit (Subject.view (Self), Subject.Logger.log_Emit (Subject.view (Self),
@@ -152,12 +171,19 @@ is
my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag)); my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag));
bad_Observers : Subject.Observer_views (my_Observers'Range); bad_Observers : Subject.Observer_views (my_Observers'Range);
bad_Count : Natural := 0; bad_Count : Natural := 0;
s_Id : sequence_Id;
begin begin
for i in my_Observers'Range for i in my_Observers'Range
loop loop
begin begin
Self.sequence_Id_Map.get_Next (s_Id,
for_Observer => my_Observers (i));
my_Observers (i).receive (the_Event, my_Observers (i).receive (the_Event,
from_Subject => Subject.view (Self).Name); from_Subject => Subject.view (Self).Name,
Sequence => s_Id);
if Subject.Logger /= null if Subject.Logger /= null
then then
Subject.Logger.log_Emit (Subject.view (Self), Subject.Logger.log_Emit (Subject.view (Self),
@@ -197,12 +223,18 @@ is
procedure send (Self : access Item; the_Event : in Event.item'Class; procedure send (Self : access Item; the_Event : in Event.item'Class;
to_Observer : in Observer.view) to_Observer : in Observer.view)
is is
s_Id : sequence_Id;
begin begin
if Self.Sender = null if Self.Sender = null
then then
Self.sequence_Id_Map.get_Next (s_Id,
for_Observer => to_Observer);
begin begin
to_Observer.receive (the_Event, to_Observer.receive (the_Event,
from_Subject => Subject.view (Self).Name); from_Subject => Subject.view (Self).Name,
Sequence => s_Id);
if Subject.Logger /= null if Subject.Logger /= null
then then
Subject.Logger.log_Send (Subject.view (Self), Subject.Logger.log_Send (Subject.view (Self),
@@ -231,6 +263,46 @@ is
------------------------
-- Safe sequence Id map.
--
protected
body safe_sequence_Id_Map
is
procedure add (the_Observer : in Observer.view)
is
begin
if not the_Map.Contains (the_Observer.Name)
then
the_Map.insert (the_Observer.Name,
new_Item => 0);
end if;
end add;
procedure rid (the_Observer : in Observer.view)
is
begin
the_Map.delete (the_Observer.Name);
end rid;
procedure get_Next (Id : out event.sequence_Id;
for_Observer : in Observer.view)
is
next_Id : name_Maps_of_sequence_Id.Reference_type renames the_Map (for_Observer.Name);
begin
Id := next_Id;
next_Id := next_Id + 1;
end get_Next;
end safe_sequence_Id_Map;
----------------- -----------------
-- Safe Observers -- Safe Observers
-- --
@@ -265,8 +337,8 @@ is
use event_Observer_Vectors, use event_Observer_Vectors,
event_kind_Maps_of_event_observers; event_kind_Maps_of_event_observers;
Cursor : constant event_kind_Maps_of_event_observers.Cursor := the_Observers.find (of_Kind); Cursor : constant event_kind_Maps_of_event_observers.Cursor := the_Observers.find (of_Kind);
the_event_Observers : event_Observer_Vector_view; the_event_Observers : event_Observer_Vector_view;
begin begin
if has_Element (Cursor) if has_Element (Cursor)
then then
@@ -334,4 +406,4 @@ is
end safe_Observers; end safe_Observers;
end lace.make_Subject; end lace.event.make_Subject;

43
1-base/lace/source/events/mixin/lace-make_subject.ads → 1-base/lace/source/events/mixin/lace-event-make_subject.ads
View File

@@ -1,5 +1,4 @@
with with
lace.Event,
lace.Subject, lace.Subject,
lace.Observer; lace.Observer;
@@ -9,6 +8,7 @@ with
lace.event_Emitter, lace.event_Emitter,
lace.event_Sender, lace.event_Sender,
ada.Strings.Hash,
ada.Containers.Vectors, ada.Containers.Vectors,
ada.Containers.indefinite_hashed_Maps; ada.Containers.indefinite_hashed_Maps;
@@ -16,7 +16,7 @@ with
generic generic
type T is abstract tagged limited private; type T is abstract tagged limited private;
package lace.make_Subject package lace.event.make_Subject
-- --
-- Makes a user class T into an event Subject. -- Makes a user class T into an event Subject.
-- --
@@ -41,6 +41,8 @@ is
overriding overriding
function observer_Count (Self : in Item) return Natural; function observer_Count (Self : in Item) return Natural;
overriding
function next_Sequence (Self : in out Item; for_Observer : in Observer.view) return event.sequence_Id;
------------- -------------
@@ -86,6 +88,33 @@ private
pragma suppress (container_Checks); -- Suppress expensive tamper checks. pragma suppress (container_Checks); -- Suppress expensive tamper checks.
---------------------------
-- Name map of sequence Id.
--
package name_Maps_of_sequence_Id is new ada.Containers.indefinite_hashed_Maps (event.observer_Name,
event.sequence_Id,
ada.Strings.Hash,
"=");
subtype name_Map_of_sequence_Id is name_Maps_of_sequence_Id.Map;
------------------------
-- Safe sequence Id map.
--
protected
type safe_sequence_Id_Map
is
procedure add (the_Observer : in Observer.view);
procedure rid (the_Observer : in Observer.view);
procedure get_Next (Id : out event.sequence_Id;
for_Observer : in Observer.view);
private
the_Map : name_Map_of_sequence_Id;
end safe_sequence_Id_Map;
-------------------------- --------------------------
-- Event observer vectors. -- Event observer vectors.
-- --
@@ -100,7 +129,6 @@ 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, package event_kind_Maps_of_event_observers is new ada.Containers.indefinite_hashed_Maps (Event.Kind,
event_Observer_Vector_view, event_Observer_Vector_view,
Event.Hash, Event.Hash,
@@ -142,9 +170,10 @@ private
and Subject.item and Subject.item
with with
record record
safe_Observers : make_Subject.safe_Observers; safe_Observers : make_Subject.safe_Observers;
Emitter : event_Emitter_view; sequence_Id_Map : safe_sequence_Id_Map;
Sender : event_Sender_view; Emitter : event_Emitter_view;
Sender : event_Sender_view;
end record; end record;
end lace.make_Subject; end lace.event.make_Subject;

38
1-base/lace/source/events/mixin/private/lace-event_emitter.adb
View File

@@ -4,9 +4,7 @@ with
ada.Text_IO, ada.Text_IO,
ada.Exceptions, ada.Exceptions,
ada.unchecked_Deallocation, ada.unchecked_Deallocation;
ada.Containers.Vectors,
ada.Containers.indefinite_Holders;
package body lace.event_Emitter package body lace.event_Emitter
@@ -20,10 +18,6 @@ is
subtype string_Holder is string_Holders.Holder; subtype string_Holder is string_Holders.Holder;
package event_Holders is new ada.Containers.indefinite_Holders (Element_type => lace.Event.item'Class);
subtype event_Holder is event_Holders.Holder;
package emitter_Vectors is new ada.Containers.Vectors (Positive, package emitter_Vectors is new ada.Containers.Vectors (Positive,
Emitter_view); Emitter_view);
subtype emitter_Vector is emitter_Vectors.Vector; subtype emitter_Vector is emitter_Vectors.Vector;
@@ -60,6 +54,7 @@ is
the_Event : in lace.Event.item'Class; the_Event : in lace.Event.item'Class;
To : in lace.Observer.view; To : in lace.Observer.view;
from_Subject : in String; from_Subject : in String;
Sequence : in event.sequence_Id;
Emitters : in safe_Emitters_view); Emitters : in safe_Emitters_view);
end Emitter; end Emitter;
@@ -68,10 +63,12 @@ is
task body Emitter task body Emitter
is is
Myself : Emitter_view; Myself : Emitter_view;
s_Id : event.sequence_Id;
Event : event_Holder; Event : event_Holder;
the_Observer : lace.Observer.view; the_Observer : lace.Observer.view;
subject_Name : string_Holder; subject_Name : string_Holder;
emitter_Pool : safe_Emitters_view; emitter_Pool : safe_Emitters_view;
begin begin
loop loop
begin begin
@@ -80,6 +77,7 @@ is
the_Event : in lace.Event.item'Class; the_Event : in lace.Event.item'Class;
To : in lace.Observer.view; To : in lace.Observer.view;
from_Subject : in String; from_Subject : in String;
Sequence : in lace.event.sequence_Id;
Emitters : in safe_Emitters_view) Emitters : in safe_Emitters_view)
do do
Event .replace_Element (the_Event); Event .replace_Element (the_Event);
@@ -88,6 +86,7 @@ is
Myself := Self; Myself := Self;
the_Observer := To; the_Observer := To;
s_Id := Sequence;
emitter_Pool := Emitters; emitter_Pool := Emitters;
end emit; end emit;
or or
@@ -95,8 +94,10 @@ is
end select; end select;
the_Observer.receive (Event.Reference, the_Observer.receive (Event.Reference,
from_Subject => subject_Name.Element); from_Subject => subject_Name.Element,
emitter_Pool.add (Myself); -- Return the emitter to the safe pool. Sequence => s_Id);
emitter_Pool.add (Myself); -- Return the emitter to the safe pool.
exception exception
when E : others => when E : others =>
@@ -108,6 +109,7 @@ is
ada.Text_IO.put_Line ("Observer: '" & the_Observer.Name & "'."); ada.Text_IO.put_Line ("Observer: '" & the_Observer.Name & "'.");
ada.Text_IO.put_Line ("Continuing."); ada.Text_IO.put_Line ("Continuing.");
ada.Text_IO.new_Line (2); ada.Text_IO.new_Line (2);
emitter_Pool.add (Myself); -- Return the emitter to the safe pool. emitter_Pool.add (Myself); -- Return the emitter to the safe pool.
end; end;
end loop; end loop;
@@ -161,8 +163,8 @@ is
accept start (Subject : in lace.Subject.view; accept start (Subject : in lace.Subject.view;
Events : in safe_Events_view) Events : in safe_Events_view)
do do
the_Subject := Subject; the_Subject := Subject;
the_Events := Events; the_Events := Events;
the_subject_Name.replace_Element (Subject.Name); the_subject_Name.replace_Element (Subject.Name);
end start; end start;
@@ -191,11 +193,14 @@ is
use lace.Event.utility; use lace.Event.utility;
the_Observers : constant lace.Subject.Observer_views := the_Subject.Observers (of_Kind => Kind_of (each_Event)); the_Observers : constant lace.Subject.Observer_views := the_Subject.Observers (of_Kind => Kind_of (each_Event));
begin begin
for each_Observer of the_Observers for each_Observer of the_Observers
loop loop
declare declare
the_Emitter : Emitter_view; the_Emitter : Emitter_view;
Sequence : constant event.sequence_Id := the_Subject.next_Sequence (for_Observer => each_Observer);
begin begin
the_Emitters.get (the_Emitter); the_Emitters.get (the_Emitter);
@@ -208,6 +213,7 @@ is
the_Event => each_Event, the_Event => each_Event,
To => each_Observer, To => each_Observer,
from_Subject => the_subject_Name.Element, from_Subject => the_subject_Name.Element,
Sequence => Sequence,
Emitters => the_Emitters'unchecked_Access); Emitters => the_Emitters'unchecked_Access);
exception exception
when E : others => when E : others =>
@@ -251,7 +257,11 @@ is
is is
procedure add (new_Event : in lace.Event.item'Class) procedure add (new_Event : in lace.Event.item'Class)
-- Sequence : in event.sequence_Id)
is is
-- use event_Holders;
-- the_Details : constant event_Details := (Event => to_Holder (new_Event),
-- Sequence => Sequence);
begin begin
all_Events.append (new_Event); all_Events.append (new_Event);
end add; end add;
@@ -331,10 +341,12 @@ is
procedure add (Self : in out Item; new_Event : lace.Event.item'Class) procedure add (Self : in out Item; new_Event : in lace.Event.item'Class)
-- Sequence : in event.sequence_Id)
is is
begin begin
Self.Events.add (new_Event); Self.Events.add (new_Event);
-- Sequence);
end add; end add;

28
1-base/lace/source/events/mixin/private/lace-event_emitter.ads
View File

@@ -5,7 +5,9 @@ with
private private
with with
lace.Subject, lace.Subject,
ada.Containers.indefinite_Vectors; ada.Containers.indefinite_Holders,
ada.Containers.indefinite_Vectors,
ada.Containers.Vectors;
private private
@@ -15,10 +17,11 @@ is
type Item is tagged limited private; type Item is tagged limited private;
procedure define (Self : in out Item; Subject : in lace.Subject.view); procedure define (Self : in out Item; Subject : in lace.Subject.view);
procedure destroy (Self : in out Item); procedure destroy (Self : in out Item);
procedure add (Self : in out Item; new_Event : in lace.Event.item'Class); procedure add (Self : in out Item; new_Event : in lace.Event.item'Class);
-- Sequence : in event.sequence_Id);
@@ -36,10 +39,22 @@ private
--------------- ---------------
--- Containers. --- Containers.
-- --
use type Event.item'Class;
package event_Holders is new ada.Containers.Indefinite_Holders (Event.item'Class);
subtype event_Holder is event_Holders.Holder;
-- type event_Details is
-- record
-- Sequence : event.sequence_Id;
-- Event : event_Holder;
-- end record;
use type lace.Event.item'Class;
package event_Vectors is new ada.Containers.indefinite_Vectors (Positive, package event_Vectors is new ada.Containers.indefinite_Vectors (Positive,
lace.Event.item'Class); lace.Event.item'Class);
-- package event_Vectors is new ada.Containers.Vectors (Positive,
-- event_Details);
subtype event_Vector is event_Vectors.Vector; subtype event_Vector is event_Vectors.Vector;
@@ -52,6 +67,7 @@ private
type safe_Events type safe_Events
is is
procedure add (new_Event : in lace.Event.item'Class); procedure add (new_Event : in lace.Event.item'Class);
-- Sequence : in event.sequence_Id);
procedure get (the_Events : out event_Vector); procedure get (the_Events : out event_Vector);
function is_Empty return Boolean; function is_Empty return Boolean;
@@ -71,8 +87,8 @@ private
task task
type emit_Delegator type emit_Delegator
is is
entry start (Subject : in lace.Subject.view; entry start (Subject : in lace.Subject.view;
Events : in safe_Events_view); Events : in safe_Events_view);
entry stop; entry stop;
end emit_Delegator; end emit_Delegator;

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

@@ -51,6 +51,7 @@ is
the_Event : in lace.Event.item'Class; the_Event : in lace.Event.item'Class;
To : in lace.Observer.view; To : in lace.Observer.view;
from_Subject : in String; from_Subject : in String;
Sequence : in event.sequence_Id;
Senders : in safe_Senders_view); Senders : in safe_Senders_view);
end Sender; end Sender;
@@ -62,6 +63,7 @@ is
Event : event_Holder; Event : event_Holder;
the_Observer : lace.Observer.view; the_Observer : lace.Observer.view;
subject_Name : string_Holder; subject_Name : string_Holder;
the_Sequence : lace.event.sequence_Id;
sender_Pool : safe_Senders_view; sender_Pool : safe_Senders_view;
begin begin
loop loop
@@ -71,11 +73,13 @@ is
the_Event : in lace.Event.item'Class; the_Event : in lace.Event.item'Class;
To : in lace.Observer.view; To : in lace.Observer.view;
from_Subject : in String; from_Subject : in String;
Sequence : in lace.event.sequence_Id;
Senders : in safe_Senders_view) Senders : in safe_Senders_view)
do do
Event .replace_Element (the_Event); Event .replace_Element (the_Event);
subject_Name.replace_Element (from_Subject); subject_Name.replace_Element (from_Subject);
the_Sequence := Sequence;
Myself := Self; Myself := Self;
the_Observer := To; the_Observer := To;
@@ -86,7 +90,8 @@ is
end select; end select;
the_Observer.receive (Event.Reference, the_Observer.receive (Event.Reference,
from_Subject => subject_Name.Element); from_Subject => subject_Name.Element,
Sequence => the_Sequence);
sender_Pool.add (Myself); -- Return the sender to the safe pool. sender_Pool.add (Myself); -- Return the sender to the safe pool.
exception exception
@@ -126,8 +131,8 @@ is
the_subject_Name : string_Holder; the_subject_Name : string_Holder;
the_Senders : aliased safe_Senders; the_Senders : aliased safe_Senders;
the_Pairs : safe_Pairs_view; the_send_Details : safe_send_Details_view;
new_Pairs : pair_Vector; new_send_Details : send_Details_Vector;
Done : Boolean := False; Done : Boolean := False;
@@ -148,11 +153,11 @@ is
begin begin
accept start (Subject : in lace.Subject.view; accept start (Subject : in lace.Subject.view;
Pairs : in safe_Pairs_view) send_Details : in safe_send_Details_view)
do do
the_Pairs := Pairs;
the_subject_Name.replace_Element (Subject.Name); the_subject_Name.replace_Element (Subject.Name);
the_send_Details := send_Details;
end start; end start;
@@ -169,11 +174,11 @@ is
exit when Done exit when Done
and the_Pairs.is_Empty; and the_send_Details.is_Empty;
the_Pairs.get (new_Pairs); the_send_Details.get (new_send_Details);
for each_Pair of new_Pairs for Each of new_send_Details
loop loop
declare declare
the_Sender : Sender_view; the_Sender : Sender_view;
@@ -186,9 +191,10 @@ is
end if; end if;
the_Sender.send (Self => the_Sender, the_Sender.send (Self => the_Sender,
the_Event => each_Pair.Event.Element, the_Event => Each.Event.Element,
To => each_Pair.Observer, To => Each.Observer,
from_Subject => the_subject_Name.Element, from_Subject => the_subject_Name.Element,
Sequence => Each.Sequence,
Senders => the_Senders'unchecked_Access); Senders => the_Senders'unchecked_Access);
exception exception
when E : others => when E : others =>
@@ -197,8 +203,8 @@ is
ada.Text_IO.new_Line; ada.Text_IO.new_Line;
ada.Text_IO.put_Line ("Error detected in 'lace.event_Sender.send_Delegator'."); 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 ("Subject '" & the_subject_Name.Element & "'.");
ada.Text_IO.put_Line ("Observer '" & each_Pair.Observer.Name & "'."); ada.Text_IO.put_Line ("Observer '" & Each.Observer.Name & "'.");
ada.Text_IO.put_Line ("Event '" & each_Pair.Event'Image & "'."); ada.Text_IO.put_Line ("Event '" & Each.Event'Image & "'.");
ada.Text_IO.put_Line ("Continuing."); ada.Text_IO.put_Line ("Continuing.");
ada.Text_IO.new_Line (2); ada.Text_IO.new_Line (2);
end; end;
@@ -223,26 +229,26 @@ is
--------------- ------------------------
--- Safe Pairs. --- Safe 'send_Details'.
-- --
protected body safe_Pairs protected body safe_send_Details
is is
procedure add (new_Pair : in event_observer_Pair) procedure add (new_send_Details : in send_Details)
is is
begin begin
all_Pairs.append (new_Pair); all_the_send_Details.append (new_send_Details);
end add; end add;
procedure get (the_Pairs : out pair_Vector) procedure get (all_send_Details : out send_Details_Vector)
is is
begin begin
the_Pairs := all_Pairs; all_send_Details := all_the_send_Details;
all_Pairs.clear; all_the_send_Details.clear;
end get; end get;
@@ -250,10 +256,10 @@ is
function is_Empty return Boolean function is_Empty return Boolean
is is
begin begin
return all_Pairs.is_Empty; return all_the_send_Details.is_Empty;
end is_Empty; end is_Empty;
end safe_Pairs; end safe_send_Details;
@@ -297,8 +303,8 @@ is
procedure define (Self : in out Item; Subject : in lace.Subject.view) procedure define (Self : in out Item; Subject : in lace.Subject.view)
is is
begin begin
Self.Delegator.start (Subject => Subject, Self.Delegator.start (Subject => Subject,
Pairs => Self.Pairs'unchecked_Access); send_Details => Self.send_Details'unchecked_Access);
end define; end define;
@@ -317,8 +323,9 @@ is
is is
use event_Holders; use event_Holders;
begin begin
Self.Pairs.add (event_observer_Pair' (Event => to_Holder (new_Event), Self.send_Details.add (send_Details' (Event => to_Holder (new_Event),
Observer => for_Observer)); Observer => for_Observer,
Sequence => from_Subject.next_Sequence (for_Observer => for_Observer)));
end add; end add;

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

@@ -16,12 +16,12 @@ is
type Item is tagged limited private; type Item is tagged limited private;
procedure define (Self : in out Item; Subject : in lace.Subject.view); procedure define (Self : in out Item; Subject : in lace.Subject.view);
procedure destroy (Self : in out Item); procedure destroy (Self : in out Item);
procedure add (Self : in out Item; new_Event : in lace.Event.item'Class; procedure add (Self : in out Item; new_Event : in lace.Event.item'Class;
for_Observer : in lace.Observer.view; for_Observer : in lace.Observer.view;
from_Subject : in lace.Subject.view); from_Subject : in lace.Subject.view);
private private
@@ -32,10 +32,11 @@ private
type event_observer_Pair is type send_Details is
record record
Event : event_Holder; Event : event_Holder;
Observer : lace.Observer.view; Observer : lace.Observer.view;
Sequence : lace.event.sequence_Id;
end record; end record;
@@ -49,33 +50,33 @@ private
------------------------------- --------------------------
--- event_observer_Pair_Vector. --- 'send_Details' Vector.
-- --
package pair_Vectors is new ada.Containers.Vectors (Positive, package send_Details_Vectors is new ada.Containers.Vectors (Positive,
event_observer_Pair); send_Details);
subtype pair_Vector is pair_Vectors.Vector; subtype send_Details_Vector is send_Details_Vectors.Vector;
--------------- ------------------------
--- Safe pairs. --- Safe 'send_Detail's.
-- --
protected protected
type safe_Pairs type safe_send_Details
is is
procedure add (new_Pair : in event_observer_Pair); procedure add (new_send_Details : in send_Details);
procedure get (the_pairs : out pair_Vector); procedure get (all_send_Details : out send_Details_Vector);
function is_Empty return Boolean; function is_Empty return Boolean;
private private
all_Pairs : pair_Vector; all_the_send_Details : send_Details_Vector;
end safe_Pairs; end safe_send_Details;
type safe_Pairs_view is access all safe_Pairs; type safe_send_Details_view is access all safe_send_Details;
@@ -86,8 +87,8 @@ private
task task
type send_Delegator type send_Delegator
is is
entry start (Subject : in lace.Subject.view; entry start (Subject : in lace.Subject.view;
Pairs : in safe_Pairs_view); send_Details : in safe_send_Details_view);
entry stop; entry stop;
end send_Delegator; end send_Delegator;
@@ -99,8 +100,8 @@ private
type Item is tagged limited type Item is tagged limited
record record
Pairs : aliased safe_Pairs; send_Details : aliased safe_send_Details;
Delegator : send_Delegator; Delegator : send_Delegator;
end record; end record;

0
1-base/lace/source/events/mixin/ravenscar/lace-make_observer-deferred.adb → 1-base/lace/source/events/mixin/ravenscar/lace-event-make_observer-deferred.adb
View File

2
1-base/lace/source/events/mixin/ravenscar/lace-make_observer-deferred.ads → 1-base/lace/source/events/mixin/ravenscar/lace-event-make_observer-deferred.ads
View File

@@ -16,7 +16,7 @@ with ada.Containers.indefinite_Vectors,
generic generic
type T is abstract new lace.make_Observer.item with private; type T is abstract new lace.make_Observer.item with private;
package lace.make_Observer.deferred package lace.event.make_Observer.deferred
-- --
-- Makes a user class T into a deferred event Observer. -- Makes a user class T into a deferred event Observer.
-- --

7
1-base/lace/source/events/mixin/xgc/lace-make_observer-deferred.adb → 1-base/lace/source/events/mixin/xgc/lace-event-make_observer-deferred.adb
View File

@@ -4,7 +4,7 @@ with
ada.unchecked_Deallocation; ada.unchecked_Deallocation;
package body lace.make_Observer.deferred package body lace.event.make_Observer.deferred
is is
use type Event.Logger.view; use type Event.Logger.view;
@@ -24,7 +24,8 @@ is
overriding overriding
procedure receive (Self : access Item; the_Event : in Event.item'Class; procedure receive (Self : access Item; the_Event : in Event.item'Class;
from_Subject : in Event.subject_Name) from_Subject : in Event.subject_Name;
Sequence : in sequence_Id)
is is
begin begin
Self.pending_Events.add (the_Event, from_Subject); Self.pending_Events.add (the_Event, from_Subject);
@@ -264,4 +265,4 @@ is
end safe_subject_Map_of_safe_events; end safe_subject_Map_of_safe_events;
end lace.make_Observer.deferred; end lace.event.make_Observer.deferred;

14
1-base/lace/source/events/mixin/xgc/lace-make_observer-deferred.ads → 1-base/lace/source/events/mixin/xgc/lace-event-make_observer-deferred.ads
View File

@@ -1,6 +1,3 @@
with
lace.Event;
private private
with with
ada.Containers.indefinite_Vectors, ada.Containers.indefinite_Vectors,
@@ -9,9 +6,9 @@ with
generic generic
type T is abstract new lace.make_Observer.item with private; type T is abstract new lace.event.make_Observer.item with private;
package lace.make_Observer.deferred package lace.event.make_Observer.deferred
-- --
-- Makes a user class T into a deferred event Observer. -- Makes a user class T into a deferred event Observer.
-- --
@@ -32,7 +29,8 @@ is
overriding overriding
procedure receive (Self : access Item; the_Event : in Event.item'Class; procedure receive (Self : access Item; the_Event : in Event.item'Class;
from_Subject : in Event.subject_Name); from_Subject : in Event.subject_Name;
Sequence : in sequence_Id);
overriding overriding
procedure respond (Self : access Item); procedure respond (Self : access Item);
@@ -45,8 +43,6 @@ private
---------------- ----------------
-- Event Vectors -- Event Vectors
-- --
use type Event.item;
package event_Vectors is new ada.Containers.indefinite_Vectors (Positive, Event.item'Class); package event_Vectors is new ada.Containers.indefinite_Vectors (Positive, Event.item'Class);
subtype event_Vector is event_Vectors.Vector; subtype event_Vector is event_Vectors.Vector;
type event_Vector_view is access all event_Vector; type event_Vector_view is access all event_Vector;
@@ -120,4 +116,4 @@ private
pending_Events : safe_subject_Map_of_safe_events; pending_Events : safe_subject_Map_of_safe_events;
end record; end record;
end lace.make_Observer.deferred; end lace.event.make_Observer.deferred;