Re: S-expression I/O in Ada

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

(The same again, if you can be bothered, untabified and after
ada-remove-trailing-spaces.)

with Ada.Finalization;  use Ada;

package S_Expressions is

    pragma Preelaborate (S_Expressions);

    --
    --  Provide definitions typical of Lisp (ad hoc; no Lisp expert
    --  here.)
    --

    type EQ_Type is limited Interface;

    function EQ (Left, Right : EQ_Type) return Boolean is abstract;
    -- objects of the same kind may be compared in specific ways

    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.


    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 := "";  -- (static)
    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
       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;