tupplespacepackage-realtupples.adb

with Ada.Strings.Unbounded, Ada.Unchecked_Deallocation;
use Ada.Strings.Unbounded;

package body tupplespacepackage.RealTupples is
    use type Ada.Containers.Count_Type;
    procedure Finalize (Finale: in out FinalizedType) is
        procedure Free is new Ada.Unchecked_Deallocation (Stream_Type, AccessStream);
    begin
        Free (Finale.Stream);
    end Finalize;

 ------------------------------------------------------------------
 -- Protected tuple space
 ------------------------------------------------------------------
    protected body RealtuppleSpace is
        procedure Matches (T: Tupple'Class; QueueAccess: out AccessToProtected)  is
        begin
            if not The_Map.Contains (T'Tag) then
                The_Map.Insert (Key => T'Tag, New_Item => new LockedQueue);
            end if;
            QueueAccess := The_Map.Element(T'Tag);
        end Matches;
        procedure Out_Operation (T: Tupple'Class) is
            M: AccessToProtected;
        begin
            Matches (T, M);
            M.Out_Operation (T);
        end Out_Operation;
        entry In_Operation (Result: out Tupple'Class) when True is
            M: AccessToProtected;
        begin
            Matches (Result, M);
            requeue M.In_Operation with abort;
        end In_Operation;

        entry RD_Operation
            (Result  : out Tupple'Class) when True is
            M: AccessToProtected;
        begin
            Matches (Result, M);
            requeue M.RD_Operation with abort;
        end RD_Operation;

       procedure Inp_Operation
         (Result  : out Tupple'Class) is
            M: AccessToProtected;
        begin
            Matches (Result, M);
            select
                M.In_Operation (Result);
            else
                raise No_Immediate_Message;
            end select;
        end Inp_Operation;

        procedure RDP_Operation (Result  : out Tupple'Class) is
            M: AccessToProtected;
        begin
            Matches (Result, M);
            select
                M.RD_Operation (Result);
            else
                raise No_Immediate_Message;
            end select;
        end RDP_Operation;
    end RealtuppleSpace;
  ------------------------------------------------------------------
   -- Locked Queue
   ------------------------------------------------------------------

   protected body LockedQueue is

      procedure Out_Operation (T : Tupple'Class) is
      begin
         PatternQueue.Set_Length (PatternQueue.Length + 1);
         Tupple'Class'Output(PatternQueue.Last_Element.Stream, T);
      end Out_Operation;

      entry In_Operation (Result : out Tupple'Class)
        when PatternQueue.Length > 0 is
      begin
         Result := Tupple'Class'Input(PatternQueue.First_Element.Stream);
         PatternQueue.Delete_First;
      end In_Operation;

      entry RD_Operation (Result : out Tupple'Class)
        when PatternQueue.Length > 0 is
      begin
         Result := Tupple'Class'Input(PatternQueue.First_Element.Stream);
         Tupple'Class'Output(PatternQueue.First_Element.Stream, Result);
      end RD_Operation;

   end LockedQueue;

end tupplespacepackage.RealTupples;