diff --git a/1-base/lace/source/events/concrete/lace-observer-deferred.ads b/1-base/lace/source/events/concrete/lace-observer-deferred.ads index 55f8a82..17ffb5e 100644 --- a/1-base/lace/source/events/concrete/lace-observer-deferred.ads +++ b/1-base/lace/source/events/concrete/lace-observer-deferred.ads @@ -1,5 +1,5 @@ with - lace.make_Observer.deferred, + lace.event.make_Observer.deferred, lace.Any; private @@ -36,8 +36,8 @@ private pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. - package Observer is new lace.make_Observer (Any.limited_item); - package Deferred is new Observer.deferred (Observer.item); + package Observer is new event.make_Observer (Any.limited_item); + package Deferred is new Observer.deferred (Observer.item); type Item is limited new Deferred.item with record diff --git a/1-base/lace/source/events/concrete/lace-observer-instant.ads b/1-base/lace/source/events/concrete/lace-observer-instant.ads index d0a7b8e..fc2f429 100644 --- a/1-base/lace/source/events/concrete/lace-observer-instant.ads +++ b/1-base/lace/source/events/concrete/lace-observer-instant.ads @@ -1,5 +1,5 @@ with - lace.make_Observer, + lace.event.make_Observer, lace.Any; private @@ -35,7 +35,7 @@ private 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 record diff --git a/1-base/lace/source/events/concrete/lace-subject-local.ads b/1-base/lace/source/events/concrete/lace-subject-local.ads index 3fb8d5e..efc1fc5 100644 --- a/1-base/lace/source/events/concrete/lace-subject-local.ads +++ b/1-base/lace/source/events/concrete/lace-subject-local.ads @@ -1,5 +1,5 @@ with - lace.make_Subject, + lace.event.make_Subject, lace.Any; private @@ -39,7 +39,7 @@ private 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 record diff --git a/1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.ads b/1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.ads index 1e3775e..94f0394 100644 --- a/1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.ads +++ b/1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.ads @@ -1,8 +1,8 @@ with lace.Subject, lace.Observer, - lace.make_Subject, - lace.make_Observer.deferred, + lace.event.make_Subject, + lace.event.make_Observer.deferred, lace.Any; private @@ -42,9 +42,9 @@ private pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. - package Subject is new make_Subject (Any.limited_item); - package Observer is new make_Observer (Subject .item); - package Deferred is new Observer.deferred (Observer .item); + package Subject is new event.make_Subject (Any.limited_item); + package Observer is new event.make_Observer (Subject .item); + package Deferred is new Observer.deferred (Observer .item); type Item is limited new Deferred.item with record diff --git a/1-base/lace/source/events/concrete/lace-subject_and_instant_observer.ads b/1-base/lace/source/events/concrete/lace-subject_and_instant_observer.ads index c6aac49..0ef285c 100644 --- a/1-base/lace/source/events/concrete/lace-subject_and_instant_observer.ads +++ b/1-base/lace/source/events/concrete/lace-subject_and_instant_observer.ads @@ -1,6 +1,6 @@ with - lace.make_Subject, - lace.make_Observer, + lace.event.make_Subject, + lace.event.make_Observer, lace.Any, lace.Subject, lace.Observer; @@ -39,8 +39,8 @@ private pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. - package Subject is new make_Subject (Any.limited_item); - package Observer is new make_Observer (Subject .item); + package Subject is new event.make_Subject (Any.limited_item); + package Observer is new event.make_Observer (Subject .item); type Item is limited new Observer.item with record diff --git a/1-base/lace/source/events/interface/lace-observer.ads b/1-base/lace/source/events/interface/lace-observer.ads index d7d357b..b2bbd4a 100644 --- a/1-base/lace/source/events/interface/lace-observer.ads +++ b/1-base/lace/source/events/interface/lace-observer.ads @@ -29,6 +29,7 @@ is function Name (Self : in Item) return event.observer_Name is abstract; + ------------ -- Responses -- @@ -45,15 +46,18 @@ is (Self : in out Item; To : in Observer.view) is abstract; + ------------- -- Operations -- 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. + procedure respond (Self : access Item) is abstract; -- -- Performs the Response for (and then removes) each pending Event. diff --git a/1-base/lace/source/events/interface/lace-subject.ads b/1-base/lace/source/events/interface/lace-subject.ads index f430d7a..b395898 100644 --- a/1-base/lace/source/events/interface/lace-subject.ads +++ b/1-base/lace/source/events/interface/lace-subject.ads @@ -35,8 +35,9 @@ is -- 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; ------------ diff --git a/1-base/lace/source/events/lace-event.ads b/1-base/lace/source/events/lace-event.ads index 6fc45c0..28e6ba0 100644 --- a/1-base/lace/source/events/lace-event.ads +++ b/1-base/lace/source/events/lace-event.ads @@ -9,7 +9,7 @@ package lace.Event is pragma Pure; - type Item is tagged private; + type Item is tagged null record; subtype subject_Name is String; @@ -31,15 +31,7 @@ is function Hash (the_Kind : in Kind) return ada.Containers.Hash_type; - -private - type sequence_Id is range 0 .. 2**32 - 1; - type Item is tagged - record - s_Id : sequence_Id; - end record; - end lace.Event; diff --git a/1-base/lace/source/events/mixin/lace-make_observer.adb b/1-base/lace/source/events/mixin/lace-event-make_observer.adb similarity index 97% rename from 1-base/lace/source/events/mixin/lace-make_observer.adb rename to 1-base/lace/source/events/mixin/lace-event-make_observer.adb index 22d89bf..0694785 100644 --- a/1-base/lace/source/events/mixin/lace-make_observer.adb +++ b/1-base/lace/source/events/mixin/lace-event-make_observer.adb @@ -2,11 +2,10 @@ with lace.Event.Logger, lace.Event.utility, - ada.unchecked_Conversion, ada.unchecked_Deallocation; -package body lace.make_Observer +package body lace.event.make_Observer is use type Event.Logger.view; @@ -64,7 +63,8 @@ is overriding 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 begin Self.Responses.receive (Self, the_Event, from_Subject); @@ -248,4 +248,4 @@ is end safe_Responses; -end lace.make_Observer; +end lace.event.make_Observer; diff --git a/1-base/lace/source/events/mixin/lace-make_observer.ads b/1-base/lace/source/events/mixin/lace-event-make_observer.ads similarity index 96% rename from 1-base/lace/source/events/mixin/lace-make_observer.ads rename to 1-base/lace/source/events/mixin/lace-event-make_observer.ads index 4dad8f7..3aed909 100644 --- a/1-base/lace/source/events/mixin/lace-make_observer.ads +++ b/1-base/lace/source/events/mixin/lace-event-make_observer.ads @@ -1,5 +1,4 @@ with - lace.Event, lace.Response, lace.Observer; @@ -12,7 +11,7 @@ with generic 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. -- @@ -49,7 +48,8 @@ is overriding 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 procedure respond (Self : access Item); @@ -63,7 +63,6 @@ private ---------------------- -- Event response maps -- - use type event.Kind; use type Response.view; package event_response_Maps is new ada.Containers.indefinite_hashed_Maps (key_type => Event.Kind, @@ -139,4 +138,4 @@ private Responses : safe_Responses; end record; -end lace.make_Observer; +end lace.event.make_Observer; diff --git a/1-base/lace/source/events/mixin/lace-make_subject.adb b/1-base/lace/source/events/mixin/lace-event-make_subject.adb similarity index 79% rename from 1-base/lace/source/events/mixin/lace-make_subject.adb rename to 1-base/lace/source/events/mixin/lace-event-make_subject.adb index 4501e23..126a4dd 100644 --- a/1-base/lace/source/events/mixin/lace-make_subject.adb +++ b/1-base/lace/source/events/mixin/lace-event-make_subject.adb @@ -5,7 +5,7 @@ with ada.unchecked_Deallocation; -package body lace.make_Subject +package body lace.event.make_Subject is 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 -- @@ -58,7 +70,8 @@ is of_Kind : in Event.Kind) is 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 then @@ -110,12 +123,18 @@ is declare use lace.Event.utility; my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag)); + Sequence : sequence_Id; begin for i in my_Observers'Range loop begin + Self.sequence_Id_Map.get_Next (Sequence, + for_Observer => my_Observers (i)); + 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 then 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)); bad_Observers : Subject.Observer_views (my_Observers'Range); bad_Count : Natural := 0; + s_Id : sequence_Id; + begin for i in my_Observers'Range loop begin + Self.sequence_Id_Map.get_Next (s_Id, + for_Observer => my_Observers (i)); + 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 then Subject.Logger.log_Emit (Subject.view (Self), @@ -197,12 +223,18 @@ is procedure send (Self : access Item; the_Event : in Event.item'Class; to_Observer : in Observer.view) is + s_Id : sequence_Id; + begin if Self.Sender = null then + Self.sequence_Id_Map.get_Next (s_Id, + for_Observer => to_Observer); begin to_Observer.receive (the_Event, - from_Subject => Subject.view (Self).Name); + from_Subject => Subject.view (Self).Name, + Sequence => s_Id); + if Subject.Logger /= null then 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 -- @@ -265,8 +337,8 @@ is use event_Observer_Vectors, event_kind_Maps_of_event_observers; - Cursor : constant event_kind_Maps_of_event_observers.Cursor := the_Observers.find (of_Kind); - the_event_Observers : event_Observer_Vector_view; + Cursor : constant event_kind_Maps_of_event_observers.Cursor := the_Observers.find (of_Kind); + the_event_Observers : event_Observer_Vector_view; begin if has_Element (Cursor) then @@ -334,4 +406,4 @@ is end safe_Observers; -end lace.make_Subject; +end lace.event.make_Subject; diff --git a/1-base/lace/source/events/mixin/lace-make_subject.ads b/1-base/lace/source/events/mixin/lace-event-make_subject.ads similarity index 72% rename from 1-base/lace/source/events/mixin/lace-make_subject.ads rename to 1-base/lace/source/events/mixin/lace-event-make_subject.ads index a5243ae..113e77e 100644 --- a/1-base/lace/source/events/mixin/lace-make_subject.ads +++ b/1-base/lace/source/events/mixin/lace-event-make_subject.ads @@ -1,5 +1,4 @@ with - lace.Event, lace.Subject, lace.Observer; @@ -9,6 +8,7 @@ with lace.event_Emitter, lace.event_Sender, + ada.Strings.Hash, ada.Containers.Vectors, ada.Containers.indefinite_hashed_Maps; @@ -16,7 +16,7 @@ with generic 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. -- @@ -41,6 +41,8 @@ is overriding 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. + --------------------------- + -- 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. -- @@ -100,7 +129,6 @@ private -------------------------------------- -- 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, event_Observer_Vector_view, Event.Hash, @@ -142,9 +170,10 @@ private and Subject.item with record - safe_Observers : make_Subject.safe_Observers; - Emitter : event_Emitter_view; - Sender : event_Sender_view; + safe_Observers : make_Subject.safe_Observers; + sequence_Id_Map : safe_sequence_Id_Map; + Emitter : event_Emitter_view; + Sender : event_Sender_view; end record; -end lace.make_Subject; +end lace.event.make_Subject; diff --git a/1-base/lace/source/events/mixin/private/lace-event_emitter.adb b/1-base/lace/source/events/mixin/private/lace-event_emitter.adb index 6096fe7..399e903 100644 --- a/1-base/lace/source/events/mixin/private/lace-event_emitter.adb +++ b/1-base/lace/source/events/mixin/private/lace-event_emitter.adb @@ -4,9 +4,7 @@ with ada.Text_IO, ada.Exceptions, - ada.unchecked_Deallocation, - ada.Containers.Vectors, - ada.Containers.indefinite_Holders; + ada.unchecked_Deallocation; package body lace.event_Emitter @@ -20,10 +18,6 @@ is 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, Emitter_view); subtype emitter_Vector is emitter_Vectors.Vector; @@ -60,6 +54,7 @@ is the_Event : in lace.Event.item'Class; To : in lace.Observer.view; from_Subject : in String; + Sequence : in event.sequence_Id; Emitters : in safe_Emitters_view); end Emitter; @@ -68,10 +63,12 @@ is task body Emitter is Myself : Emitter_view; + s_Id : event.sequence_Id; Event : event_Holder; the_Observer : lace.Observer.view; subject_Name : string_Holder; emitter_Pool : safe_Emitters_view; + begin loop begin @@ -80,6 +77,7 @@ is the_Event : in lace.Event.item'Class; To : in lace.Observer.view; from_Subject : in String; + Sequence : in lace.event.sequence_Id; Emitters : in safe_Emitters_view) do Event .replace_Element (the_Event); @@ -88,6 +86,7 @@ is Myself := Self; the_Observer := To; + s_Id := Sequence; emitter_Pool := Emitters; end emit; or @@ -95,8 +94,10 @@ is end select; the_Observer.receive (Event.Reference, - from_Subject => subject_Name.Element); - emitter_Pool.add (Myself); -- Return the emitter to the safe pool. + from_Subject => subject_Name.Element, + Sequence => s_Id); + + emitter_Pool.add (Myself); -- Return the emitter to the safe pool. exception when E : others => @@ -108,6 +109,7 @@ is ada.Text_IO.put_Line ("Observer: '" & the_Observer.Name & "'."); ada.Text_IO.put_Line ("Continuing."); ada.Text_IO.new_Line (2); + emitter_Pool.add (Myself); -- Return the emitter to the safe pool. end; end loop; @@ -161,8 +163,8 @@ is accept start (Subject : in lace.Subject.view; Events : in safe_Events_view) do - the_Subject := Subject; - the_Events := Events; + the_Subject := Subject; + the_Events := Events; the_subject_Name.replace_Element (Subject.Name); end start; @@ -191,11 +193,14 @@ is use lace.Event.utility; the_Observers : constant lace.Subject.Observer_views := the_Subject.Observers (of_Kind => Kind_of (each_Event)); + begin for each_Observer of the_Observers loop declare - the_Emitter : Emitter_view; + the_Emitter : Emitter_view; + Sequence : constant event.sequence_Id := the_Subject.next_Sequence (for_Observer => each_Observer); + begin the_Emitters.get (the_Emitter); @@ -208,6 +213,7 @@ is the_Event => each_Event, To => each_Observer, from_Subject => the_subject_Name.Element, + Sequence => Sequence, Emitters => the_Emitters'unchecked_Access); exception when E : others => @@ -251,7 +257,11 @@ is is procedure add (new_Event : in lace.Event.item'Class) + -- Sequence : in event.sequence_Id) is + -- use event_Holders; + -- the_Details : constant event_Details := (Event => to_Holder (new_Event), + -- Sequence => Sequence); begin all_Events.append (new_Event); 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 begin Self.Events.add (new_Event); + -- Sequence); end add; diff --git a/1-base/lace/source/events/mixin/private/lace-event_emitter.ads b/1-base/lace/source/events/mixin/private/lace-event_emitter.ads index a3a9f13..9a32996 100644 --- a/1-base/lace/source/events/mixin/private/lace-event_emitter.ads +++ b/1-base/lace/source/events/mixin/private/lace-event_emitter.ads @@ -5,7 +5,9 @@ with private with lace.Subject, - ada.Containers.indefinite_Vectors; + ada.Containers.indefinite_Holders, + ada.Containers.indefinite_Vectors, + ada.Containers.Vectors; private @@ -15,10 +17,11 @@ is 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 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. -- + 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, lace.Event.item'Class); + -- package event_Vectors is new ada.Containers.Vectors (Positive, + -- event_Details); subtype event_Vector is event_Vectors.Vector; @@ -52,6 +67,7 @@ private type safe_Events is procedure add (new_Event : in lace.Event.item'Class); + -- Sequence : in event.sequence_Id); procedure get (the_Events : out event_Vector); function is_Empty return Boolean; @@ -71,8 +87,8 @@ private task type emit_Delegator is - entry start (Subject : in lace.Subject.view; - Events : in safe_Events_view); + entry start (Subject : in lace.Subject.view; + Events : in safe_Events_view); entry stop; end emit_Delegator; diff --git a/1-base/lace/source/events/mixin/private/lace-event_sender.adb b/1-base/lace/source/events/mixin/private/lace-event_sender.adb index 4687803..4b972b2 100644 --- a/1-base/lace/source/events/mixin/private/lace-event_sender.adb +++ b/1-base/lace/source/events/mixin/private/lace-event_sender.adb @@ -51,6 +51,7 @@ is the_Event : in lace.Event.item'Class; To : in lace.Observer.view; from_Subject : in String; + Sequence : in event.sequence_Id; Senders : in safe_Senders_view); end Sender; @@ -62,6 +63,7 @@ is Event : event_Holder; the_Observer : lace.Observer.view; subject_Name : string_Holder; + the_Sequence : lace.event.sequence_Id; sender_Pool : safe_Senders_view; begin loop @@ -71,11 +73,13 @@ is the_Event : in lace.Event.item'Class; To : in lace.Observer.view; from_Subject : in String; + Sequence : in lace.event.sequence_Id; Senders : in safe_Senders_view) do Event .replace_Element (the_Event); subject_Name.replace_Element (from_Subject); + the_Sequence := Sequence; Myself := Self; the_Observer := To; @@ -86,7 +90,8 @@ is end select; 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. exception @@ -126,8 +131,8 @@ is the_subject_Name : string_Holder; the_Senders : aliased safe_Senders; - the_Pairs : safe_Pairs_view; - new_Pairs : pair_Vector; + the_send_Details : safe_send_Details_view; + new_send_Details : send_Details_Vector; Done : Boolean := False; @@ -148,11 +153,11 @@ is begin - accept start (Subject : in lace.Subject.view; - Pairs : in safe_Pairs_view) + accept start (Subject : in lace.Subject.view; + send_Details : in safe_send_Details_view) do - the_Pairs := Pairs; the_subject_Name.replace_Element (Subject.Name); + the_send_Details := send_Details; end start; @@ -169,11 +174,11 @@ is 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 declare the_Sender : Sender_view; @@ -186,9 +191,10 @@ is end if; the_Sender.send (Self => the_Sender, - the_Event => each_Pair.Event.Element, - To => each_Pair.Observer, + the_Event => Each.Event.Element, + To => Each.Observer, from_Subject => the_subject_Name.Element, + Sequence => Each.Sequence, Senders => the_Senders'unchecked_Access); exception when E : others => @@ -197,8 +203,8 @@ is 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 ("Observer '" & Each.Observer.Name & "'."); + ada.Text_IO.put_Line ("Event '" & Each.Event'Image & "'."); ada.Text_IO.put_Line ("Continuing."); ada.Text_IO.new_Line (2); end; @@ -223,26 +229,26 @@ is - --------------- - --- Safe Pairs. + ------------------------ + --- Safe 'send_Details'. -- - protected body safe_Pairs + protected body safe_send_Details is - procedure add (new_Pair : in event_observer_Pair) + procedure add (new_send_Details : in send_Details) is begin - all_Pairs.append (new_Pair); + all_the_send_Details.append (new_send_Details); end add; - procedure get (the_Pairs : out pair_Vector) + procedure get (all_send_Details : out send_Details_Vector) is begin - the_Pairs := all_Pairs; - all_Pairs.clear; + all_send_Details := all_the_send_Details; + all_the_send_Details.clear; end get; @@ -250,10 +256,10 @@ is function is_Empty return Boolean is begin - return all_Pairs.is_Empty; + return all_the_send_Details.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) is begin - Self.Delegator.start (Subject => Subject, - Pairs => Self.Pairs'unchecked_Access); + Self.Delegator.start (Subject => Subject, + send_Details => Self.send_Details'unchecked_Access); end define; @@ -317,8 +323,9 @@ is is use event_Holders; begin - Self.Pairs.add (event_observer_Pair' (Event => to_Holder (new_Event), - Observer => for_Observer)); + Self.send_Details.add (send_Details' (Event => to_Holder (new_Event), + Observer => for_Observer, + Sequence => from_Subject.next_Sequence (for_Observer => for_Observer))); end add; diff --git a/1-base/lace/source/events/mixin/private/lace-event_sender.ads b/1-base/lace/source/events/mixin/private/lace-event_sender.ads index 12cf076..562ef2b 100644 --- a/1-base/lace/source/events/mixin/private/lace-event_sender.ads +++ b/1-base/lace/source/events/mixin/private/lace-event_sender.ads @@ -16,12 +16,12 @@ is 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 add (Self : in out Item; new_Event : in lace.Event.item'Class; - for_Observer : in lace.Observer.view; - from_Subject : in lace.Subject.view); + 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 @@ -32,10 +32,11 @@ private - type event_observer_Pair is + type send_Details is record Event : event_Holder; Observer : lace.Observer.view; + Sequence : lace.event.sequence_Id; end record; @@ -49,33 +50,33 @@ private - ------------------------------- - --- event_observer_Pair_Vector. + -------------------------- + --- 'send_Details' Vector. -- - package pair_Vectors is new ada.Containers.Vectors (Positive, - event_observer_Pair); - subtype pair_Vector is pair_Vectors.Vector; + package send_Details_Vectors is new ada.Containers.Vectors (Positive, + send_Details); + subtype send_Details_Vector is send_Details_Vectors.Vector; - --------------- - --- Safe pairs. + ------------------------ + --- Safe 'send_Detail's. -- protected - type safe_Pairs + type safe_send_Details is - procedure add (new_Pair : in event_observer_Pair); - procedure get (the_pairs : out pair_Vector); + procedure add (new_send_Details : in send_Details); + procedure get (all_send_Details : out send_Details_Vector); function is_Empty return Boolean; private - all_Pairs : pair_Vector; - end safe_Pairs; + all_the_send_Details : send_Details_Vector; + 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 type send_Delegator is - entry start (Subject : in lace.Subject.view; - Pairs : in safe_Pairs_view); + entry start (Subject : in lace.Subject.view; + send_Details : in safe_send_Details_view); entry stop; end send_Delegator; @@ -99,8 +100,8 @@ private type Item is tagged limited record - Pairs : aliased safe_Pairs; - Delegator : send_Delegator; + send_Details : aliased safe_send_Details; + Delegator : send_Delegator; end record; diff --git a/1-base/lace/source/events/mixin/ravenscar/lace-make_observer-deferred.adb b/1-base/lace/source/events/mixin/ravenscar/lace-event-make_observer-deferred.adb similarity index 100% rename from 1-base/lace/source/events/mixin/ravenscar/lace-make_observer-deferred.adb rename to 1-base/lace/source/events/mixin/ravenscar/lace-event-make_observer-deferred.adb diff --git a/1-base/lace/source/events/mixin/ravenscar/lace-make_observer-deferred.ads b/1-base/lace/source/events/mixin/ravenscar/lace-event-make_observer-deferred.ads similarity index 97% rename from 1-base/lace/source/events/mixin/ravenscar/lace-make_observer-deferred.ads rename to 1-base/lace/source/events/mixin/ravenscar/lace-event-make_observer-deferred.ads index f0f53b9..346d146 100644 --- a/1-base/lace/source/events/mixin/ravenscar/lace-make_observer-deferred.ads +++ b/1-base/lace/source/events/mixin/ravenscar/lace-event-make_observer-deferred.ads @@ -16,7 +16,7 @@ with ada.Containers.indefinite_Vectors, generic 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. -- diff --git a/1-base/lace/source/events/mixin/xgc/lace-make_observer-deferred.adb b/1-base/lace/source/events/mixin/xgc/lace-event-make_observer-deferred.adb similarity index 97% rename from 1-base/lace/source/events/mixin/xgc/lace-make_observer-deferred.adb rename to 1-base/lace/source/events/mixin/xgc/lace-event-make_observer-deferred.adb index e95ed47..4bc5312 100644 --- a/1-base/lace/source/events/mixin/xgc/lace-make_observer-deferred.adb +++ b/1-base/lace/source/events/mixin/xgc/lace-event-make_observer-deferred.adb @@ -4,7 +4,7 @@ with ada.unchecked_Deallocation; -package body lace.make_Observer.deferred +package body lace.event.make_Observer.deferred is use type Event.Logger.view; @@ -24,7 +24,8 @@ is overriding 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 begin Self.pending_Events.add (the_Event, from_Subject); @@ -264,4 +265,4 @@ is end safe_subject_Map_of_safe_events; -end lace.make_Observer.deferred; +end lace.event.make_Observer.deferred; diff --git a/1-base/lace/source/events/mixin/xgc/lace-make_observer-deferred.ads b/1-base/lace/source/events/mixin/xgc/lace-event-make_observer-deferred.ads similarity index 92% rename from 1-base/lace/source/events/mixin/xgc/lace-make_observer-deferred.ads rename to 1-base/lace/source/events/mixin/xgc/lace-event-make_observer-deferred.ads index 07aa98a..354f7b2 100644 --- a/1-base/lace/source/events/mixin/xgc/lace-make_observer-deferred.ads +++ b/1-base/lace/source/events/mixin/xgc/lace-event-make_observer-deferred.ads @@ -1,6 +1,3 @@ -with - lace.Event; - private with ada.Containers.indefinite_Vectors, @@ -9,9 +6,9 @@ with 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. -- @@ -32,7 +29,8 @@ is overriding 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 procedure respond (Self : access Item); @@ -45,8 +43,6 @@ private ---------------- -- Event Vectors -- - use type Event.item; - package event_Vectors is new ada.Containers.indefinite_Vectors (Positive, Event.item'Class); subtype event_Vector is event_Vectors.Vector; type event_Vector_view is access all event_Vector; @@ -120,4 +116,4 @@ private pending_Events : safe_subject_Map_of_safe_events; end record; -end lace.make_Observer.deferred; +end lace.event.make_Observer.deferred;