Re: S-expression I/O in Ada

[Natasha Kerensikova <lithiumcat@gmail.com>]

Hello,

Here is my third attempt, hopefully avoiding the mistakes I did before.

I wanted to have a go at an access-based implementation, and while it
seems to end up without roughly the same complexity as my previous
Doubly_Linked_List-based attempt, I felt incredibly much more at home
with it. Is it genuinely more simple in some way, or is it just my
pointer-juggling experience from C?

The interface is relatively limited, but it's enough for all the needs I
ever had. 

The limited interface long with the Container objects make me pretty
confident in the correctness of the memory management.

I'm still not satisfied with the indentation, it still feels much too
shallow for my tastes, and the general look of my sources feels it needs
much more spacing out.


As usual, all comments that can help me writing better Ada code and/or
becoming a better Ada noob are warmly welcome.

Thanks in advance for your help,
Natasha




with Ada.Finalization;

private with Ada.Containers.Vectors;



package Sexp is

   type Container is tagged limited private;
      -- container that keeps tracks of allocated data

   type Cursor is private;
      -- object that refers to a S-expression node
      -- it's the only way a client can interact with S-expression contents

   type Node_Kind is (Atom_Node, List_Node);
      -- a node is either an atom or a list

   type Octet is range 0 .. 255;
   type Atom_Data is array (Positive range <>) of Octet;
      -- publicly defined to allow object conversion anywhere



   ---------------
   -- Constants --
   ---------------

   No_Element : constant Cursor;



   ---------------------
   -- Atom converters --
   ---------------------

   procedure Atom_To_String(Data : in Atom_Data; Image : out String);
   procedure String_To_Atom(Image : in String; Data : out Atom_Data);
      -- conversion between existing objects, assumed to be of equal length

   function To_String(Data : in Atom_Data) return String;
   function To_Atom(Image : in String) return Atom_Data;
      -- constructing one type from the other



   -----------------------
   -- Container methods --
   -----------------------

   procedure Reset(Universe : in out Container);
      -- reset the container using an empty list node as the new root
   procedure Reset(Universe : in out Container; Root_Atom : in Atom_Data);
      -- reset the container using the given atom data as root
   procedure Reset(Universe : in out Container; Root_Atom : in String);
      -- reset the container using the given string as root atom



   -----------------------
   -- Cursor management --
   -----------------------

   function Root(From : in Container) return Cursor;

   function Next(Position : in Cursor) return Cursor;
   procedure Next(Position : in out Cursor);



   --------------------
   -- Node accessors --
   --------------------

   function Is_Atom(Position : in Cursor) return Boolean;
   function Is_List(Position : in Cursor) return Boolean;

   function Kind(Position : in Cursor) return Node_Kind;
      -- raise Constraint_Error when Position is No_Element



   --------------------
   -- Atom accessors --
   --------------------
      -- They all raise Constraint_Error when the given Cursor does not refer
      -- to an atom node.

   function To_Atom(Position : in Cursor) return Atom_Data;
   function To_String(Position : in Cursor) return String;

   procedure Query_Atom
     (Position : in Cursor;
      Process  : not null access procedure(Data : in Atom_Data));

   function Atom_Length(Position : in Cursor) return Natural;


   -------------------
   -- List accessor --
   -------------------

   function Sublist(Position : in Cursor) return Cursor;
      -- raise Constraint_Error when Position does not refer to a list



   -----------------------
   -- Node constructors --
   -----------------------
      -- They all raise Constraint_Error when Position is No_Element

   procedure Append_Empty_List
     (Universe : in out Container;
      Position : in     Cursor);

   procedure Append
     (Universe : in out Container;
      Position : in     Cursor;
      Atom     : in     Atom_Data);

   procedure Append
     (Universe : in out Container;
      Position : in     Cursor;
      Image    : in     String);



   ---------------
   -- Iterators --
   ---------------

   procedure Iterate
     (Start        : in Cursor;
      Process_Atom : access procedure(Data : in Atom_Data);
      Process_List : access procedure(First : in Cursor));

   procedure Iterate_Over_Atoms
     (Start   : in Cursor;
      Process : not null access procedure(Data : in Atom_Data));

   procedure Iterate_Over_Lists
     (Start   : in Cursor;
      Process : not null access procedure(First : in Cursor));

   procedure Iterate_Over_Commands
     (Start   : in Cursor;
      Execute : not null access procedure(Command   : in String;
                                          Arguments : in Cursor));



private

   ----------------------
   -- Type definitions --
   ----------------------

   type Node(<>);
   type Atom_Access is access Atom_Data;
   type Node_Access is access Node;

   type Node (Kind : Node_Kind) is
      record
         Next : Node_Access;
         case Kind is
            when Atom_Node => Atom  : Atom_Access;
            when List_Node => Child : Node_Access;
         end case;
      end record;

   package Nodes is
      new Ada.Containers.Vectors
        (Index_Type   => Positive,
         Element_Type => Node_Access);

   package Atoms is
      new Ada.Containers.Vectors
        (Index_Type   => Positive,
         Element_Type => Atom_Access);

   type Container is
      new Ada.Finalization.Limited_Controlled with record
         List_Node : Nodes.Vector;
         Atom_List : Atoms.Vector;
         Root      : Node_Access;
      end record;

   type Cursor is
      record
         Parent : Node_Access;
         Node   : Node_Access;
      end record;



   -----------------------
   -- Container methods --
   -----------------------

   procedure Clean_Atoms(Universe : in out Container);
   procedure Clean_Nodes(Universe : in out Container);

   overriding
   procedure Finalize(This : in out Container);

   procedure Make_Atom
     (Maker : in out Container;
      Atom  :    out Atom_Access;
      Data  : in     Atom_Data);

   procedure Make_Atom
     (Maker : in out Container;
      Atom  :    out Atom_Access;
      Image : in     String);

   procedure Make_Node
     (Maker : in out Container;
      Node  :    out Node_Access;
      Kind  : in     Node_Kind);

   procedure Make_Node_Atom
     (Maker : in out Container;
      Node  :    out Node_Access;
      Data  : in     Atom_Data);

   procedure Make_Node_Atom
     (Maker : in out Container;
      Node  :    out Node_Access;
      Image : in     String);

   procedure Make_Node_List
     (Maker  : in out Container;
      Node   :    out Node_Access;
      Child  : in     Node_Access := null);



   ---------------
   -- Constants --
   ---------------

   No_Element : constant Cursor := (Parent => null, Node => null);

end Sexp;





with Ada.Unchecked_Deallocation;



package body Sexp is

   procedure Free is
      new Ada.Unchecked_Deallocation(Node, Node_Access);

   procedure Free is
      new Ada.Unchecked_Deallocation(Atom_Data, Atom_Access);



   ------------------------------------
   -- String vs Atom_Data converters --
   ------------------------------------

   procedure String_To_Atom(Image : in String; Data : out Atom_Data) is
   begin
      for i in Image'Range loop
         Data(i - Image'First + Data'First) := Character'Pos(Image(i));
      end loop;
   end String_To_Atom;



   procedure Atom_To_String(Data : in Atom_Data; Image : out String) is
   begin
      for i in Data'Range loop
         Image(i - Data'First + Image'First) := Character'Val(Data(i));
      end loop;
   end Atom_To_String;



   function To_Atom(Image : in String) return Atom_Data is
      Data : Atom_Data(1 .. Image'Length);
   begin
      String_To_Atom(Image, Data);
      return Data;
   end To_Atom;



   function To_String(Data : in Atom_Data) return String is
      Image : String(Data'Range);
   begin
      Atom_To_String(Data, Image);
      return Image;
   end To_String;



   -------------------------------
   -- Container private methods --
   -------------------------------


   procedure Clean_Atoms(Universe : in out Container) is
      Current : Atoms.Cursor := Atoms.First(Universe.Atom_List);
      Atom : Atom_Access;
   begin
      while Atoms.Has_Element(Current) loop
         Atom := Atoms.Element(Current);
         Free(Atom);
         Atoms.Next(Current);
      end loop;
      Atoms.Clear(Universe.Atom_List);
   end Clean_Atoms;



   procedure Clean_Nodes(Universe : in out Container) is
      Current : Nodes.Cursor := Nodes.First(Universe.List_Node);
      Node : Node_Access;
   begin
      while Nodes.Has_Element(Current) loop
         Node := Nodes.Element(Current);
         Free(Node);
         Nodes.Next(Current);
      end loop;
      Nodes.Clear(Universe.List_Node);
   end Clean_Nodes;



   overriding
   procedure Finalize(This : in out Container) is
   begin
      Clean_Nodes(This);
      Clean_Atoms(This);
   end Finalize;



   procedure Make_Atom
     (Maker : in out Container;
      Atom  :    out Atom_Access;
      Data  : in     Atom_Data) is
   begin
      Atom := new Atom_Data(Data'Range);
      Atom.All := Data;
      Atoms.Append(Maker.Atom_List, Atom);
   end Make_Atom;



   procedure Make_Atom
     (Maker : in out Container;
      Atom  :    out Atom_Access;
      Image : in     String) is
   begin
      Atom := new Atom_Data(1 .. Image'Length);
      String_To_Atom(Image, Atom.All);
      Atoms.Append(Maker.Atom_List, Atom);
   end Make_Atom;



   procedure Make_Node
     (Maker : in out Container;
      Node  :    out Node_Access;
      Kind  : in     Node_Kind) is
   begin
      Node := new Sexp.Node(Kind);
      Nodes.Append(Maker.List_Node, Node);
   end Make_Node;



   procedure Make_Node_Atom
     (Maker : in out Container;
      Node  :    out Node_Access;
      Data  : in     Atom_Data) is
   begin
      Make_Node(Maker, Node, Atom_Node);
      Make_Atom(Maker, Node.Atom, Data);
   end Make_Node_Atom;



   procedure Make_Node_Atom
     (Maker : in out Container;
      Node  :    out Node_Access;
      Image : in     String) is
   begin
      Make_Node(Maker, Node, Atom_Node);
      Make_Atom(Maker, Node.Atom, Image);
   end Make_Node_Atom;



   procedure Make_Node_List
     (Maker  : in out Container;
      Node   :    out Node_Access;
      Child  : in     Node_Access := null) is
   begin
      Make_Node(Maker, Node, List_Node);
      Node.Child := Child;
   end Make_Node_List;



   ------------------------------
   -- Container public methods --
   ------------------------------


   procedure Reset(Universe : in out Container) is
   begin
      Clean_Nodes(Universe);
      Clean_Atoms(Universe);
      Make_Node_List(Universe, Universe.Root);
   end Reset;



   procedure Reset(Universe : in out Container; Root_Atom : in Atom_Data) is
   begin
      Clean_Nodes(Universe);
      Clean_Atoms(Universe);
      Make_Node_Atom(Universe, Universe.Root, Root_Atom);
   end Reset;



   procedure Reset(Universe : in out Container; Root_Atom : in String) is
   begin
      Clean_Nodes(Universe);
      Clean_Atoms(Universe);
      Make_Node_Atom(Universe, Universe.Root, Root_Atom);
   end Reset;



   -----------------------
   -- Cursor management --
   -----------------------

   function Root(From : in Container) return Cursor is
      Result : Cursor := (Parent => null, Node => From.Root);
   begin
      return Result;
   end Root;



   function Next(Position : in Cursor) return Cursor is
      Result : Cursor := No_Element;
   begin
      if Position.Node /= null and then Position.Node.Next /= null then
         Result.Parent := Position.Node;
         Result.Node   := Position.Node.Next;
      end if;
      return Result;
   end Next;



   procedure Next(Position : in out Cursor) is
   begin
      if Position.Node /= null then
         if Position.Node.Next /= null then
            Position.Parent := Position.Node;
            Position.Node   := Position.Parent.Next;
         else
            Position := No_Element;
         end if;
      end if;
   end Next;



   --------------------
   -- Node accessors --
   --------------------


   function Is_Atom(Position : in Cursor) return Boolean is
   begin
      return Position.Node /= null and then Position.Node.Kind = Atom_Node;
   end Is_Atom;



   function Is_List(Position : in Cursor) return Boolean is
   begin
      return Position.Node /= null and then Position.Node.Kind = List_Node;
   end Is_List;



   function Kind(Position : in Cursor) return Node_Kind is
   begin
      if Position.Node = null then
         raise Constraint_Error with "Position cursor has no element";
      end if;
      return Position.Node.Kind;
   end Kind;



   --------------------
   -- Atom accessors --
   --------------------


   function To_Atom(Position : in Cursor) return Atom_Data is
   begin
      if not Is_Atom(Position) then
         raise Constraint_Error with "Position cursor is not an atom";
      end if;
      return Position.Node.Atom.all;
   end To_Atom;



   function To_String(Position : in Cursor) return String is
   begin
      if not Is_Atom(Position) then
         raise Constraint_Error with "Position cursor is not an atom";
      end if;
      return To_String(Position.Node.Atom.all);
   end To_String;



   procedure Query_Atom
     (Position : in Cursor;
      Process  : not null access procedure(Data : in Atom_Data)) is
   begin
      if not Is_Atom(Position) then
         raise Constraint_Error with "Position cursor is not an atom";
      end if;
      Process(Position.Node.Atom.all);
   end Query_Atom;



   function Atom_Length(Position : in Cursor) return Natural is
   begin
      if not Is_Atom(Position) then
         raise Constraint_Error with "Position cursor is not an atom";
      end if;
      return Position.Node.Atom'Length;
   end Atom_Length;



   -------------------
   -- List accessor --
   -------------------


   function Sublist(Position : in Cursor) return Cursor is
      Result : Cursor;
   begin
      if not Is_List(Position) then
         raise Constraint_Error with "Position cursor is not a list";
      end if;
      Result.Parent := Position.Node;
      Result.Node   := Position.Node.Child;
      return Result;
   end Sublist;



   -----------------------
   -- Node constructors --
   -----------------------


   procedure Append_Empty_List
     (Universe : in out Container;
      Position : in     Cursor)
   is
      Current : Node_Access := Position.Node;
   begin
      if Current /= null then
         raise Constraint_Error with "Position cursor has no element";
      end if;
      while Current.Next /= null loop
         Current := Current.Next;
      end loop;
      Make_Node_List(Universe, Current.Next);
   end Append_Empty_List;



   procedure Append
     (Universe : in out Container;
      Position : in     Cursor;
      Atom     : in     Atom_Data)
   is
      Current : Node_Access := Position.Node;
   begin
      if Current /= null then
         raise Constraint_Error with "Position cursor has no element";
      end if;
      while Current.Next /= null loop
         Current := Current.Next;
      end loop;
      Make_Node_Atom(Universe, Current.Next, Atom);
   end Append;



   procedure Append
     (Universe : in out Container;
      Position : in     Cursor;
      Image    : in     String)
   is
      Current : Node_Access := Position.Node;
   begin
      if Current /= null then
         raise Constraint_Error with "Position cursor has no element";
      end if;
      while Current.Next /= null loop
         Current := Current.Next;
      end loop;
      Make_Node_Atom(Universe, Current.Next, Image);
   end Append;



   ---------------
   -- Iterators --
   ---------------

   procedure Iterate
     (Start        : in Cursor;
      Process_Atom : access procedure(Data : in Atom_Data);
      Process_List : access procedure(First : in Cursor))
   is
      Current : Node_Access := Start.Node;
      First   : Cursor;
   begin
      if Process_Atom = null then
         if Process_List /= null then
            Iterate_Over_Lists(Start, Process_List);
         end if;
      elsif Process_List = null then
         Iterate_Over_Atoms(Start, Process_Atom);
      else
         while Current /= null loop
            case Current.Kind is
               when Atom_Node =>
                  Process_Atom(Current.Atom.all);
               when List_Node =>
                  First.Parent := Current;
                  First.Node   := Current.Child;
                  Process_List(First);
            end case;
            Current := Current.Next;
         end loop;
      end if;
   end Iterate;



   procedure Iterate_Over_Atoms
     (Start   : in Cursor;
      Process : not null access procedure(Data : in Atom_Data))
   is
      Current : Node_Access := Start.Node;
   begin
      while Current /= null loop
         if Current.Kind = Atom_Node then
            Process(Current.Atom.all);
         end if;
      end loop;
   end Iterate_Over_Atoms;



   procedure Iterate_Over_Lists
     (Start   : in Cursor;
      Process : not null access procedure(First : in Cursor))
   is
      Current : Node_Access := Start.Node;
      First   : Cursor;
   begin
      while Current /= null loop
         if Current.Kind = List_Node then
            First.Parent := Current;
            First.Node   := Current.Child;
            Process(First);
         end if;
      end loop;
   end Iterate_Over_Lists;



   procedure Iterate_Over_Commands
     (Start   : in Cursor;
      Execute : not null access procedure(Command   : in String;
                                          Arguments : in Cursor))
   is
      Current : Node_Access := Start.Node;
      Arg : Cursor;
   begin
      while Current /= null loop
         if Current.Kind = Atom_Node then
            Execute(To_String(Current.Atom.all), No_Element);
         elsif Current.Child.Kind = Atom_node then
            Arg.Parent := Current.Child;
            Arg.Node   := Current.Child.Next;
            Execute(To_String(Current.Child.Atom.all), Arg);
         end if;
      end loop;
   end Iterate_Over_Commands;

end Sexp;