Re: S-expression I/O in Ada

[Shark8 <onewingedshark@gmail.com>]

Natacha,

I took a bit of a stab at writing an SExpression handler, note that
it's not a parser [text-file -> SExpression] but rather what (I think)
you were terming in-memory. It has stream-support so you can directly
save/load an SExpression's structure & contents and it should be easy
to make it "parenthesis preservative" in the parser if you so desire.

I [semi-]plan on making a child-package for the parser "package
SExpression.Text" or somesuch for storing/loading the SExpressions
from text [that is, parsing them].

---------------------------------------------
-- SExpression.ads
---------------------------------------------

With
 Ada.Streams,
 Ada.Streams.Stream_IO;


Package SExpression is

   Type Byte is mod 2**8;
    For Byte'Size use 8;

   Type Binary_Data_Type is Array( Positive Range <> ) Of Byte;
     Pragma Pack(Binary_Data_Type);

   Type Node_Data_Type is ( Binary_Data, String_Data, Number_Data );
   Type Node_Type( Data_Type : Node_Data_Type ) is private;
     Procedure Create( Node: out Node_Type; Data: in
String           );
     Procedure Create( Node: out Node_Type; Data: in
Binary_Data_Type );
     Procedure Create( Node: out Node_Type; Data: in
Long_Integer     );

   Type List_Type;
   Type SExpression_Type(List_Size : Natural) is private;
     Function Is_List ( SExp : in SExpression_Type) Return Boolean;
     Function Create  ( Node : Node_Type ) Return SExpression_Type;
     Procedure Append ( SExp : in out SExpression_Type; Node :
Node_Type );
     Procedure Append ( Front: in out SExpression_Type;
                        Back : in     SExpression_Type );
     Procedure Prepend( SExp : in out SExpression_Type; Node :
Node_Type );
     Procedure Prepend( Front: in     SExpression_Type;
                        Back : in out SExpression_Type );

   Type List_Type is Array(Positive Range <>) of
        Not Null Access SExpression_Type;

     Procedure Create( SExp : out SExpression_Type; List : in
List_Type );

   Package Stream is
      Use Ada.Streams;

      Procedure Write_Bin ( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : in Binary_Data_Type );
      Procedure Read_Bin  ( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : out Binary_Data_Type );

      Procedure Write_Node( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : in Node_Type );
      Procedure Read_Node ( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : out Node_Type );

      Procedure Write_Sexp( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : in SExpression_Type );
      Procedure Read_SExp ( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : out SExpression_Type );

      Procedure Write_List( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : in List_Type );
      Procedure Read_List ( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : out List_Type );

   end Stream;


private


   Type Node_Type( Data_Type : Node_Data_Type ) is Record
      case Data_Type is
         when Binary_Data => B : Access Binary_Data_Type;
         when String_Data => S : Access String;
         when Number_Data => N : Long_Integer;
      end case;
   end record;

    For Node_Type'Write use Stream.Write_Node;
    For Node_Type'Read  use Stream.Read_Node;

   Type SExpression_Type(List_Size : Natural) is Record
      case List_Size is
         when 0      => Data: Not Null Access Node_Type;
         when others => List: List_Type(1..List_Size);
      end case;
   end record;

    For SExpression_Type'Read  use Stream.Read_SExp;
    For SExpression_Type'Write use Stream.Write_SExp;

    For List_Type'Read  use Stream.Read_List;
    For List_Type'Write use Stream.Write_List;

    For Binary_Data_Type'Read  use Stream.Read_Bin;
    For Binary_Data_Type'Write use Stream.Write_Bin;
end SExpression;

---------------------------------------------
-- SExpression.adb
---------------------------------------------

Package body SExpression is

   -- Internal Node-Creation Functions.
   Function Make_Node( Data: String ) Return Node_Type is
   begin
      Return Result: Node_Type( Data_Type => String_Data ) do
         Result.S:= New String'(Data);
      end Return;
   end Make_Node;

   Function Make_Node( Data: Binary_Data_Type ) Return Node_Type is
   begin
      Return Result: Node_Type( Data_Type => Binary_Data ) do
         Result.B:= New Binary_Data_Type'(Data);
      end Return;
   end Make_Node;

   Function Make_Node( Data: Long_Integer ) Return Node_Type is
   begin
      Return Result: Node_Type( Data_Type => Number_Data ) do
         Result.N:= Data;
      end Return;
   end Make_Node;


   -- Public Node-Creation Procedures {wraps node-creation functions}
   Procedure Create ( Node: out Node_Type; Data: in String ) is
   begin
      Node:= Make_Node(Data);
   end Create;

   Procedure Create ( Node: out Node_Type; Data: in Binary_Data_Type )
is
   begin
      Node:= Make_Node( Data );
   end Create;

   Procedure Create ( Node: out Node_Type; Data: in Long_Integer ) is
   begin
      Node:= Make_Node(Data);
   end Create;

Pragma Inline( Create );

   Function Is_List(SExp : in SExpression_Type) Return Boolean is
   begin
      Return SExp.List_Size > 0;
   end Is_List;
   Pragma Inline(Is_List);

   Function Create( List : in List_Type ) Return SExpression_Type is
   begin
      Return Result: SExpression_Type( List_Size => List'Length ) do
         Result.List:= List;
      end return;
   end Create;

   Procedure Create( SExp : out SExpression_Type; List : in
List_Type ) is
   begin
      SExp:= Create( List );
   end Create;

   Function Create( Node : Node_Type ) Return SExpression_Type is
   begin
      Return Result : SExpression_Type( List_Size => 0 ) do
         Result.Data:= New Node_Type'( Node );
      end return;
   end Create;

   Procedure Append ( SExp : in out SExpression_Type; Node :
Node_Type ) is
   begin
      if Is_List(SExp) then
         SExp:= Create( Sexp.List & New
SExpression_Type'(Create(Node)) );
      else
         SExp:= Create(   New
SExpression_Type'(Create(SExp.Data.All))
			& New SExpression_Type'(Create(Node))
		      );
      end if;
   end Append;

   Procedure Prepend( SExp : in out SExpression_Type; Node :
Node_Type ) is
   begin
      if Is_List(SExp) then
         SExp:= Create( New SExpression_Type'(Create(Node)) &
Sexp.List);
      else
         SExp:= Create(   New SExpression_Type'(Create(Node))
			& New SExpression_Type'(Create(SExp.Data.All))
		      );
      end if;
   end Prepend;

   Procedure Append ( Front: in out SExpression_Type;
		      Back : in     SExpression_Type ) is
   begin
      if Is_List(Back) then
         Front:= Create( Front.List & Back.List);
      else
         Append( SExp => Front, Node => Back.Data.All );
      end if;
   end Append;

   Procedure Prepend( Front: in     SExpression_Type;
		      Back : in out SExpression_Type ) is
   begin
      if Is_List(Front) then
         Back:= Create( Front.List & Back.List);
      else
         Prepend( SExp => Back, Node => Front.Data.All );
      end if;
   end Prepend;

   package body Stream is
      Procedure Write_Bin ( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : in Binary_Data_Type ) is
      begin
         Positive'Write( Stream, Item'Length );
         For Index in Item'Range loop
            Byte'Write( Stream, Item(Index) );
         end loop;
      end Write_Bin;

      Procedure Read_Bin  ( Stream: Not Null Access
Root_Stream_Type'Class;
                           Item : out Binary_Data_Type ) is

         Function Get_Elements( Length: Positive ) Return
Binary_Data_Type is
         begin
            Return Result: Binary_Data_Type(1..Length) do
               For Index in Result'Range loop
                  Byte'Read( Stream, Result(Index) );
               end loop;
            end Return;
         end Get_Elements;

         Length: Positive;
      begin
         Positive'Read( Stream, Length );
         Item:= Get_Elements( Length );
      end Read_Bin;


      Procedure Write_Node( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : in Node_Type ) is
      begin
         Node_Data_Type'Write( Stream, Item.Data_Type );

         Case Item.Data_Type is
            When Binary_Data => Binary_Data_Type'Write( Stream,
Item.B.All );
            When String_Data => String'Write( Stream, Item.S.All );
            When Number_Data => Long_Integer'Write( Stream, Item.N );
         end Case;
      end Write_Node;

      Procedure Read_Node ( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : out Node_Type ) is
         Data_Type : Node_Data_Type;
      begin
         Node_Data_Type'Read( Stream, Data_Type );

            Case Data_Type is
            When Binary_Data =>
               Item.B:= New Binary_Data_Type'( 1..0 => <> );
               Declare
                  Binary_Temp  : Access Binary_Data_Type:=
                    New Binary_Data_Type'( 1..0 => 16#FF# );
               Begin
                  Binary_Data_Type'Read( Stream, Binary_Temp.All );
                  Item:= Make_Node( Data => Binary_Temp.All );
               End;
            When String_Data =>
               declare
                  String_Temp  : Access String:= New String'("");
               begin
                  String'Read( Stream, String_Temp.All);
                  Item:= Make_Node( Data => String_Temp.All );
               end;
            When Number_Data =>
               declare
                  Temp : Long_Integer;
               begin
                  Long_Integer'Read( Stream, Temp );
                  Item:= Make_Node( Temp );
               end;
            end Case;
      end Read_Node;




      Procedure Write_SExp( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : in SExpression_Type ) is
      begin
         Natural'Write( Stream, Item.List_Size );
         if Item.List_Size = 0 then
            Node_Type'Write( Stream, Item.Data.All );
         else
            List_Type'Write( Stream, Item.List );
         end if;
      end Write_SExp;

      Procedure Read_SExp ( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : out SExpression_Type ) is
         List_Size : Natural;
      begin
         Natural'Read( Stream, List_Size );
         if List_Size = 0 then
            Declare
               Temp : Access Node_Type:= New
Node_Type'( Make_Node(0) );
            Begin
               Node_Type'Read( Stream, Temp.All );
               Item:= Create( Temp.All );
            End;
         else
            Declare
               Dummy: Aliased SExpression_Type:=
Create(Make_Node(0));
               Temp : List_Type:= (1..List_Size =>
Dummy'Unchecked_Access );
            Begin
               List_Type'Read( Stream, Temp );
               Item:= Create( Temp );
            End;
         end if;
      end Read_SExp;


      Procedure Write_List( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : in List_Type ) is
      begin
         Positive'Write(Stream, Item'Length);
         For Index in Item'Range loop
            SExpression_Type'Write( Stream, Item(Index).All );
         end loop;
      end Write_List;

      Procedure Read_List ( Stream: Not Null Access
Root_Stream_Type'Class;
			    Item : out List_Type ) is

         Function Get_Elements( Length: Positive ) Return List_Type is
            Working : Access SExpression_Type;
         begin
            Working:= New SExpression_Type'( Create(Make_Node(0)) );
            Return Result: List_Type(1..Length) do
               For Index in Result'Range loop
                  SExpression_Type'Read( Stream, Working.All );
                  Result(Index):= New
SExpression_Type'( Working.All );
               end loop;
            end Return;
         end Get_Elements;

         Length : Positive;
      begin
         Positive'Read(Stream, Length);
         Item:= Get_Elements( Length );
      end Read_List;


   end Stream;

end SExpression;