1. -- 
  2. -- Copyright (c) 2012-2013 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. with Interfaces;                        use Interfaces; 
  11.  
  12. private with Ada.Finalization; 
  13.  
  14. package Values is 
  15.  
  16.     -- Defines the different primitive value types 
  17.     type Value_Type is 
  18.     ( 
  19.         V_NULL, 
  20.         V_BOOLEAN, 
  21.         V_NUMBER, 
  22.         V_STRING, 
  23.         V_ID, 
  24.         V_LIST, 
  25.         V_ASSOCIATION, 
  26.         V_ERROR 
  27.     ); 
  28.  
  29.     ---------------------------------------------------------------------------- 
  30.  
  31.     -- A Value represents a generic value of one of the primitive types. The 
  32.     -- value can be converted to other types in some cases. Instances of the 
  33.     -- Value class can be copied and written to a stream. 
  34.     type Value is abstract tagged private; 
  35.     type Value_Ptr is tagged private; 
  36.  
  37.     function Clone( this : access Value ) return Value_Ptr'Class is abstract; 
  38.  
  39.     -- Compares 'this' to 'other', returning -1 if this is less than 'other', 
  40.     -- zero if this equals 'other', and 1 if this is greater than 'other'. If 
  41.     -- 'this' and 'other' are of different value types, then the comparison is 
  42.     -- based on the values' relative positions in the Value_Type enumeration. 
  43.     function Compare( this : Value; other : Value'Class ) return Integer is abstract; 
  44.     function Compare( this : Value'Class; other : access Value'Class ) return Integer; 
  45.  
  46.     -- Returns the primitive type of the value. 
  47.     function Get_Type( this : Value ) return Value_Type is abstract; 
  48.  
  49.     -- Returns a depiction of the value as a string. 
  50.     function Image( this : Value ) return String is abstract; 
  51.  
  52.     -- Streaming 
  53.     function Value_Input( stream : access Root_Stream_Type'Class ) return Value is abstract; 
  54.     procedure Value_Read( stream : access Root_Stream_Type'Class; obj : out Value ) is abstract; 
  55.     procedure Value_Write( stream : access Root_Stream_Type'Class; obj : Value ) is abstract; 
  56.  
  57.     -- Relational operators based on Compare() 
  58.     overriding 
  59.     function "="( this : Value; other : Value ) return Boolean; 
  60.     function "<"( this : Value'Class; other : Value'Class ) return Boolean; 
  61.     function ">"( this : Value'Class; other : Value'Class ) return Boolean; 
  62.     function "<="( this : Value'Class; other : Value'Class ) return Boolean; 
  63.     function ">="( this : Value'Class; other : Value'Class ) return Boolean; 
  64.  
  65.     ---------------------------------------------------------------------------- 
  66.  
  67.     function To_Ptr( val : access Value'Class ) return Value_Ptr; 
  68.  
  69.     -- Returns a copy of the target value, or Nul if the pointer has no target. 
  70.     function Clone( this : Value_Ptr'Class ) return Value_Ptr; 
  71.  
  72.     function Get( this : Value_Ptr ) return access Value'Class; 
  73.     pragma Inline( Get ); 
  74.  
  75.     function Refcount( this : Value_Ptr'Class ) return Natural; 
  76.  
  77.     function Image( this : Value_Ptr'Class ) return String; 
  78.  
  79.     function Is_Null( this : Value_Ptr'Class ) return Boolean; 
  80.  
  81.     function Not_Null( this : Value_Ptr'Class ) return Boolean; 
  82.  
  83.     procedure Set( this : in out Value_Ptr; target : access Value'Class ); 
  84.  
  85.     function Value_Ptr_Input( stream : access Root_Stream_Type'Class ) return Value_Ptr; 
  86.  
  87.     procedure Value_Ptr_Output( stream : access Root_Stream_Type'Class; this : Value_Ptr ); 
  88.  
  89.     -- Thee following comparison operators map to Value equivalence comparison 
  90.     -- operators. The null pointer cases are handled safely. 
  91.     function "="( l, r : Value_Ptr ) return Boolean; 
  92.     function "<"( l, r : Value_Ptr ) return Boolean; 
  93.     function ">"( l, r : Value_Ptr ) return Boolean; 
  94.     function "<="( l, r : Value_Ptr ) return Boolean; 
  95.     function ">="( l, r : Value_Ptr ) return Boolean; 
  96.  
  97.     Nul : constant Value_Ptr; 
  98.  
  99.     -- Raise when an abstract Value can't be cast to a specific Value class 
  100.     Cast_Exception : exception; 
  101.  
  102. private 
  103.  
  104.     use Ada.Finalization; 
  105.  
  106.     function "<"( l, r : Value_Type ) return Boolean; 
  107.  
  108.     ---------------------------------------------------------------------------- 
  109.  
  110.     type Value is abstract tagged 
  111.         record 
  112.             refs : aliased Integer_32 := 0; 
  113.         end record; 
  114.     type A_Naked_Value is access all Value'Class; 
  115.  
  116.     procedure Delete( this : in out Value ) is null; 
  117.  
  118.     ---------------------------------------------------------------------------- 
  119.  
  120.     type Value_Ptr is new Ada.Finalization.Controlled with 
  121.         record 
  122.             target : A_Naked_Value := null; 
  123.         end record; 
  124.  
  125.     for Value_Ptr'Input use Value_Ptr_Input; 
  126.     for Value_Ptr'Output use Value_Ptr_Output; 
  127.  
  128.     overriding 
  129.     procedure Adjust( this : in out Value_Ptr ); 
  130.  
  131.     overriding 
  132.     procedure Finalize( this : in out Value_Ptr ); 
  133.  
  134.     procedure Value_Ptr_Read( stream : access Root_Stream_Type'Class; this : out Value_Ptr ); 
  135.     for Value_Ptr'Read use Value_Ptr_Read; 
  136.  
  137.     procedure Value_Ptr_Write( stream : access Root_Stream_Type'Class; this : Value_Ptr ); 
  138.     for Value_Ptr'Write use Value_Ptr_Write; 
  139.  
  140.     Nul : constant Value_Ptr := (Controlled with target => null); 
  141.  
  142. end Values;