Re: S-expression I/O in Ada

[Georg Bauhaus <rm-host.bauhaus@maps.futureapps.de>]

On 8/1/10 2:17 PM, Natacha Kerensikova wrote:

> My question here is about how to represent the atoms in Ada. In C it
> was merely a void pointer and a size, but it seems more difficult in
> Ada because of the strong typing. Because it's up to the application
> to make sense (i.e. type) out of the raw sequences of bits in atoms,
> the S-expression library has to handle them as a sort of untyped
> memory chunk. Do you know of a way to handle that?

Maybe there is a reasonably simple way of a different
kind---one that emphasizes the type system and leaves
distinguishing types to the compiler and the plain old
run-time system.

First, to represent an atom, I'd choose Ada's limited types,
since they imply no copying and no predefined equality
operators:  Each object of such a type will be unique
by definition of "limited". Then I'd derive types for symbols,
numbers, ..., from this type.  And use construction functions
to make symbols, numbers, ...

Second, to perform I/O of objects of such a type (Atom
or derived from Atom; also List) via textual representation
of S-expressions, Ada's Generic_Dispatching_Constructor seems
ideal: textual representations of S-expressions will include
a tag that guides the I/O routines. This is completely portable,
and transparent too, unlike 'Input and 'Output attributes or
similar.

A.k.a. "Object factory functions", there is more in the Rationale
http://www.adaic.com/standards/05rat/html/Rat-2-6.html

Some ad hoc definitions and a test case for the Lisp stuff,
just to illustrate the idea involving limited types
(I couldn't resist):


with Ada.Finalization;  use Ada;

package S_Expressions is
    
    pragma Preelaborate (S_Expressions);
    
    --
    --  Provide definitions typical of Lisp (ad hoc)
    --
    
    type EQ_Type is limited Interface;
    --   Force EQ of Common Lisp.
    
    function EQ (Left, Right : EQ_Type) return Boolean is abstract;
    --  Objects of the same kind may be compared in specific ways,
    --  e.g. by numeric value.

    function "=" (Left, Right: EQ_Type'Class) return Boolean;
    -- General comparison operation for each object in the system,
    -- dispatches to EQ if Left'Tag = Right'Tag. False otherwise.
    
    
    subtype Defined is Finalization.Limited_Controlled;
    --  Every object in the system is unique and has no "=",
    --  since all objects are limited.  Also adds hooks for
    --  garbage collection.
    
    
    --
    --  Root of everything not a list
    --
    
    type Atom is abstract new Defined and EQ_Type with private;
    --  Symbols, Numbers, Character strings, ...
    
    function EQ (Left, Right : Atom) return Boolean is abstract;


    -- Kinds of atoms, with construction functions:
    
    type Symbol(<>) is new Atom with private;
    
    function Make_Symbol (Name : String) return Symbol;
    
    
    type Numeric is range 0 .. 666;   -- or something better suited
    type Number(<>) is new Atom with private;
    
    function Make_Number (Initial : Numeric) return Number;
    
    
    --
    --  Lists, construction and access to elements:
    --
    
    type List is new Defined and EQ_Type with private;
    
    Nil: constant Symbol;
    
    function Cons (Car, Cdr : Defined'Class) return List;
    
    type Ptr is access constant Defined'Class;
    -- read-only access to elements of lists
    function Car (L : List) return Ptr;
    function Cdr (L : List) return Ptr;
    
private
    --
    --  Equality functions of all types that need to implement EQ_Type
    --
    function EQ (Left, Right : Symbol) return Boolean;
    function EQ (Left, Right : Number) return Boolean;
    function EQ (Left, Right : List) return Boolean;
    -- ...

    type Atom is abstract new Defined and EQ_Type with null record;
    
    
    type Symbol_Chars is access constant String;
    type Symbol(Name : Symbol_Chars) is new Atom with null record;
    
    Nil_Chars : aliased constant String := "";
    Nil: constant Symbol := Symbol'(Atom with Name => Nil_Chars'Access);
    
    type Number(Value : Numeric) is new Atom with null record;
    
    
    type List is new Defined and EQ_Type with
       record
	 Info : Ptr;
	 Next : Ptr;
       end record;
    
    
end S_Expressions;


with S_Expressions; use S_Expressions;
procedure S_Test is
    
    A: Symbol := Make_Symbol("Foo");
    B: Symbol := Make_Symbol("Foo");
    
    M: Number := Make_Number(42);
    N: Number := Make_Number(42);
    
    S : List := Cons(Make_Number(1),
			  Cons(Make_Number(2),
			       Cons(Make_Number(3), Nil)));
    Sx : List := Cons(Make_Number(1),
			  Cons(Make_Number(2),
			       Cons(Make_Number(3), Nil)));
begin
    if A /= B then   -- same name!!
       raise Program_Error;
    end if;
    
    if M /= N then   -- same value!!
       raise Program_Error;
    end if;
    
    if A = N then   -- different kinds of atoms!!
       raise Program_Error;
    end if;
    
    if S = Sx then  -- different lists (even though same values)!!
       raise Program_Error;
    end if;
  
    if S /= S then   --  same object!!
       raise Program_Error;
    end if;
  
    declare
       Cadr : constant Ptr := Car (List( Cdr (S).all));
    begin
       if Number(Cadr.all) /= Make_Number(2) then  -- same value!!
	 raise Program_Error;
       end if;
    end;
end S_Test;



with Ada.Tags;
with System;
package body S_Expressions is
    
    -- Comparison
    
    function EQ (Left, Right : Symbol) return Boolean is
    begin
       return Left.Name.all = Right.Name.all;
    end EQ;
    
    function EQ (Left, Right : Number) return Boolean is
    begin
       return Left.Value = Right.Value;
    end EQ;
    
    function EQ (Left, Right : List) return Boolean is
       use type System.Address;
    begin
       return Left'Address = Right'Address;
    end EQ;
    
    function "=" (Left, Right: EQ_Type'Class) return Boolean is
       use type Ada.Tags.Tag;
    begin
       if Left'Tag /= Right'Tag then
	 return False;
       else
	 return EQ (Left, Right);
       end if;
    end "=";
    
    -- Making atoms
    
    function Make_Number (Initial : Numeric) return Number is
    begin
       return Number'(Defined with
		       Value => Initial);
    end Make_Number;

    function Make_Symbol (Name : String) return Symbol is
    begin
       return Symbol'(Defined with
		       Name => new String'(Name));
    end Make_Symbol;
    
    
    -- Lists
    
    function Cons (Car, Cdr : Defined'Class) return List is
    begin
       return List'(Defined with
		     Info => Car'Unchecked_Access,
		   Next => Cdr'Unchecked_Access);
    end Cons;
    
    function Car (L : List) return Ptr is
    begin
       return L.Info;
    end Car;
    
    function Cdr (L : List) return Ptr is
    begin
       return L.Next;
    end Cdr;
    
end S_Expressions;


-- Georg