1. with Ada.Streams;                       use Ada.Streams; 
  2.  
  3. package Objects is 
  4.  
  5.     -- This is the superclass for all objects. The class provides copying, 
  6.     -- deletion, streaming and stringification procedures. All class should 
  7.     -- extend either the Object class or the Limited_Object class. 
  8.     type Object is abstract tagged private; 
  9.     type A_Object is access all Object'Class; 
  10.     pragma No_Strict_Aliasing( A_Object ); 
  11.  
  12.     -- Adjusts the object's fields as part of a Copy. If this class or an 
  13.     -- ancestor class doesn't support copying then COPY_NOT_ALLOWED will be 
  14.     -- raised. A subclass should call its superclass' Adjust before doing any 
  15.     -- work. When an object is copied, Adjust will be called on the new object 
  16.     -- after the memory copy and Construct will not be called on it. 
  17.     procedure Adjust( this : access Object ); 
  18.  
  19.     -- Constructs the object. A subclass should call its superclass' Construct 
  20.     -- before doing any work. 
  21.     procedure Construct( this : access Object ); 
  22.  
  23.     -- Deletes the object's fields as part of object destruction. A subclass 
  24.     -- should call its superclass' Delete before doing any work. 
  25.     procedure Delete( this : in out Object ); 
  26.  
  27.     -- Returns the name of the instance's class in lower case characters. This 
  28.     -- is defined to be the class' external tag which is not guaranteed to be 
  29.     -- unique across the entire application. If 'full' is True, the fully 
  30.     -- qualified class name which includes a package prefix will be returned. 
  31.     function Get_Class_Name( this : not null access Object'Class; 
  32.                              full : Boolean := False ) return String; 
  33.     pragma Postcondition( Get_Class_Name'Result'Length > 0 ); 
  34.  
  35.     -- Returns a string representation of the object. 
  36.     function To_String( this : access Object ) return String; 
  37.  
  38.     -- Reads the object's representation from a stream. This should be 
  39.     -- overridden to provide streaming support for a subclass. 
  40.     procedure Object_Read( stream : access Root_Stream_Type'Class; obj : out Object ); 
  41.  
  42.     -- Writes the object's representation to a stream. This should be overridden 
  43.     -- to provide streaming support for a subclass. 
  44.     procedure Object_Write( stream : access Root_Stream_Type'Class; obj : Object ); 
  45.  
  46.     -- Returns a copy of 'src'. Not all object classes can be copied. If 'src' 
  47.     -- is not allowed to be copied then COPY_NOT_ALLOWED will be raised. 
  48.     function Copy( src : A_Object ) return A_Object; 
  49.     pragma Postcondition( Copy'Result /= src or else src = null ); 
  50.  
  51.     -- Deletes the object. 
  52.     procedure Delete( this : in out A_Object ); 
  53.     pragma Postcondition( this = null ); 
  54.  
  55.     -- Concatenates the string representation of the object, as returned by the 
  56.     -- To_String function. 
  57.     function "&"( left : A_Object; right : String ) return String; 
  58.  
  59.     -- Concatenates the string representation of the object, as returned by the 
  60.     -- To_String function. 
  61.     function "&"( left : String; right : A_Object ) return String; 
  62.  
  63.     -- Raised when attempting to copy an instance of a class that doesn't 
  64.     -- allow copying. This occurs if a class doesn't support copying but needs 
  65.     -- to be streamed. If a subclass does not allow copying and it is never 
  66.     -- streamed then it should extend the Limited_Object class instead. 
  67.     COPY_NOT_ALLOWED : exception; 
  68.  
  69.     ---------------------------------------------------------------------------- 
  70.  
  71.     -- This is the superclass for all objects that can't be copied or streamed. 
  72.     -- It behaves the same as the Object class except for the restrictions 
  73.     -- imposed by its status as a limited type. 
  74.     type Limited_Object is abstract tagged limited private; 
  75.     type A_Limited_Object is access all Limited_Object'Class; 
  76.     pragma No_Strict_Aliasing( A_Limited_Object ); 
  77.  
  78.     -- Constructs the object. A subclass should call its superclass' Construct 
  79.     -- before doing any work. 
  80.     procedure Construct( this : access Limited_Object ); 
  81.  
  82.     -- Deletes the object's fields as part of object destruction. A subclass 
  83.     -- should call its superclass' Delete before doing any work. 
  84.     procedure Delete( this : in out Limited_Object ); 
  85.  
  86.     -- Returns the name of the instance's class in lower case characters. This 
  87.     -- is defined to be the class' external tag which is not guaranteed to be 
  88.     -- unique across the entire application. If 'full' is True, the fully 
  89.     -- qualified class name which includes a package prefix will be returned. 
  90.     function Get_Class_Name( this : not null access Limited_Object'Class; 
  91.                              full : Boolean := False ) return String; 
  92.     pragma Postcondition( Get_Class_Name'Result'Length > 0 ); 
  93.  
  94.     -- Returns a string representation of the object. 
  95.     function To_String( this : access Limited_Object ) return String; 
  96.  
  97.     -- Deletes the object. 
  98.     procedure Delete( this : in out A_Limited_Object ); 
  99.     pragma Postcondition( this = null ); 
  100.  
  101.     -- Concatenates the string representation of the object, as returned by the 
  102.     -- To_String function. 
  103.     function "&"( left : A_Limited_Object; right : String ) return String; 
  104.  
  105.     -- Concatenates the string representation of the object, as returned by the 
  106.     -- To_String function. 
  107.     function "&"( left : String; right : A_Limited_Object ) return String; 
  108.  
  109.     ---------------------------------------------------------------------------- 
  110.  
  111.     procedure Finalize; 
  112.  
  113. private 
  114.  
  115.     type Object is abstract tagged null record; 
  116.  
  117.     for Object'Read use Object_Read; 
  118.     for Object'Write use Object_Write; 
  119.  
  120.     ---------------------------------------------------------------------------- 
  121.  
  122.     type Limited_Object is abstract tagged limited null record; 
  123.  
  124. end Objects;