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