Limited Types

Declarations

    
    
    
        
with Interfaces;
package Multiprocessor_Mutex is
   subtype Id_T is String (1 .. 4);
   -- prevent copying of a lock
   type Limited_T is limited record
      Flag : Interfaces.Unsigned_8;
   end record;
   type Also_Limited_T is record
      Lock : Limited_T;
      Id   : Id_T;
   end record;
   procedure Lock (This : in out Also_Limited_T) is null;
   procedure Unlock (This : in out Also_Limited_T) is null;
end Multiprocessor_Mutex;

Creating Values

    
    
    
        
with Interfaces;
package Multiprocessor_Mutex is
   subtype Id_T is String (1 .. 4);
   -- prevent copying of a lock
   type Limited_T is limited record
      Flag : Interfaces.Unsigned_8;
   end record;
   type Also_Limited_T is record
      Lock : Limited_T;
      Id   : Id_T;
   end record;
   procedure Lock (This : in out Also_Limited_T);
   procedure Unlock (This : in out Also_Limited_T);
   function Create (Flag : Interfaces.Unsigned_8;
                    Id   : Id_T)
                    return Also_Limited_T;
end Multiprocessor_Mutex;

    
        
package body Multiprocessor_Mutex is
   procedure Lock (This : in out Also_Limited_T) is null;
   procedure Unlock (This : in out Also_Limited_T) is null;
   Global_Lock : Also_Limited_T := (Lock => (Flag => 0), Id => "GLOB");
   function Create (Flag : Interfaces.Unsigned_8;
                    Id   : Id_T)
                    return Also_Limited_T is
      Local_Lock : Also_Limited_T := (Lock => (Flag => 1), Id => "LOCA");
   begin
      Global_Lock.Lock.Flag := Flag;
      Local_Lock.Id         := Id;
      -- Compile error
      -- return Local_Lock;
      -- Compile error
      -- return Global_Lock;
      return (Lock => (Flag => Flag), Id => Id);
   end Create;
end Multiprocessor_Mutex;

    
        
with Ada.Text_IO;          use Ada.Text_IO;
with Multiprocessor_Mutex; use Multiprocessor_Mutex;
procedure Perform_Lock is
   Lock1 : Also_Limited_T := (Lock => (Flag => 2), Id => "LOCK");
   Lock2 : Also_Limited_T;
begin
   -- Lock2 := Create ( 3, "CREA" ); -- illegal
   Put_Line (Lock1.Id & Lock1.Lock.Flag'Image);
end Perform_Lock;

Extended Return Statements

    
    
    
        
with Interfaces; use Interfaces;
package Multiprocessor_Mutex is
   subtype Id_T is String (1 .. 4);
   -- prevent copying of a lock
   type Limited_T is limited record
      Flag : Interfaces.Unsigned_8;
   end record;
   type Also_Limited_T is record
      Lock : Limited_T;
      Id   : Id_T;
   end record;
   procedure Lock (This : in out Also_Limited_T);
   procedure Unlock (This : in out Also_Limited_T);
   function Create (Id : Id_T) return Also_Limited_T;
end Multiprocessor_Mutex;

    
        
package body Multiprocessor_Mutex is
   procedure Lock (This : in out Also_Limited_T) is null;
   procedure Unlock (This : in out Also_Limited_T) is null;

   Global_Lock_Counter : Interfaces.Unsigned_8 := 0;
   function Create (Id : Id_T) return Also_Limited_T is
   begin
      return Ret_Val : Also_Limited_T do
         if Global_Lock_Counter = Interfaces.Unsigned_8'Last then
            return;
         end if;
         Global_Lock_Counter := Global_Lock_Counter + 1;
         Ret_Val.Id          := Id;
         Ret_Val.Lock.Flag   := Global_Lock_Counter;
      end return;
   end Create;
end Multiprocessor_Mutex;

    
        
with Ada.Text_IO;          use Ada.Text_IO;
with Multiprocessor_Mutex; use Multiprocessor_Mutex;
procedure Perform_Lock is
   Lock1 : constant Also_Limited_T := Create ("One ");
   Lock2 : constant Also_Limited_T := Create ("Two ");
begin
   Put_Line (Lock1.Id & Lock1.Lock.Flag'Image);
   Put_Line (Lock2.Id & Lock2.Lock.Flag'Image);
end Perform_Lock;

Combining Limited And Private Views

    
    
    
        
with Interfaces; use Interfaces;
package Multiprocessor_Mutex is
   type Limited_T is limited private;
   procedure Lock (This : in out Limited_T);
   procedure Unlock (This : in out Limited_T);
   function Create return Limited_T;
private
   type Limited_T is limited -- no internal copying allowed
   record
      Flag : Interfaces.Unsigned_8; -- users cannot see this
   end record;
end Multiprocessor_Mutex;

    
        
package body Multiprocessor_Mutex is
   procedure Lock (This : in out Limited_T) is null;
   procedure Unlock (This : in out Limited_T) is null;

   Global_Lock_Counter : Interfaces.Unsigned_8 := 0;
   function Create return Limited_T is
   begin
      return Ret_Val : Limited_T do
         Global_Lock_Counter := Global_Lock_Counter + 1;
         Ret_Val.Flag        := Global_Lock_Counter;
      end return;
   end Create;
end Multiprocessor_Mutex;

    
        
with Multiprocessor_Mutex; use Multiprocessor_Mutex;
package Use_Limited_Type is
   type Legal is limited private;
   type Also_Legal is limited private;
   -- type Not_Legal is private;
   -- type Also_Not_Legal is private;
private
   type Legal is record
      S : Limited_T;
   end record;
   type Also_Legal is limited record
      S : Limited_T;
   end record;
   -- type Not_Legal is limited record
   --    S : Limited_T;
   -- end record;
   -- type Also_Not_Legal is record
   --    S : Limited_T;
   -- end record;
end Use_Limited_Type;