Re: Little tutorial about streams

[Shark8 <onewingedshark@gmail.com>]

I was debating on whether or not to submit to you a little 'toy' LISP
interpreter I've started. I've only got the reading and writing here,
no eval or special-forms like 'if', but since they're Stream-based it
might be appropriate.


---------------------------------
-- Lisp Interpreter in Ada.
-- By Joey Fish

---------------
-- LISP.ADS  --
---------------
With
Ada.Containers.Indefinite_Vectors,
Ada.Streams;

Package LISP is

 
-----------------------------------------------------------------------
   --	In LISP a List is defined as either a single element or an	--
   --	element followed by a lisr; as a consequence of this
definition	--
   --	there is no such thing as an "Empty List."			--
 
-----------------------------------------------------------------------


   Type List is Private;
   -- ToDo: Add primitive functions for list construction/
manipulation.
   -- ToDo: Add primitive functions for determining if it is an
executable list.

Private
   -- Alias Ads.Streams.Root_Stream_Type for ease of use.
   SubType Stream_Root is Ada.Streams.Root_Stream_Type;

   -- Element_Type describes the possible types of an Atom
   --	Note: Empty_Type is the NULL-element.
   Type Element_Type is
     ( Empty_Type, Boolean_Type, Integer_Type, Real_Type,
String_Type );

   -- Type Atom is a record containing the type and value of an
element.
   Type Atom( Element : Element_Type:= Empty_Type ) is record
      Case Element is
         When Empty_Type	=> Null;
         When Boolean_Type	=> Boolean_Value : Boolean:= False;
         When Integer_Type	=> Integer_Value : Integer:= 0;
         When Real_Type		=> Real_Value	 : Float  := 0.0;
         When String_Type	=> Is_Name	 : Boolean:= False;
				   String_Value	 : Not Null Access String;
      End Case;
   end record;

   Procedure Write_Atom( Stream	: Not Null Access Stream_Root'Class;
			 Item	: In Atom
                       );

   For Atom'Write Use Write_Atom;

   Type Atom_Array is Array (Positive Range <>) of Atom;
   Type Elementry_List( Terminal : Boolean:= True ) is record
      Head : Atom:=		( Element => Empty_Type );
      Case Terminal is
	When False => Tail : Not Null Access Elementry_List;
	When True  => Null;
      End Case;
   end record;

   Procedure Append( Head : In Out Elementry_List; Tail : In
Elementry_List );
   Function  Convert( List : Elementry_List ) Return Atom_Array;
   Function  Convert( List : Atom_Array ) Return Elementry_List;

   Procedure Write_EList( Stream	: Not Null Access Stream_Root'Class;
			  Item		: In Elementry_List
                       );
   Procedure Read_EList( Stream	: Not Null Access Stream_Root'Class;
			 Item	: Out Elementry_List
                       );


   For Elementry_List'Read  Use Read_EList;
   For Elementry_List'Write Use Write_EList;

   Type List_Element_Type is ( Atom_Element, EList_Type,
Recursive_List );
   Type List_Element( Element : List_Element_Type:= Atom_Element ) is
record
      Case Element is
	When Atom_Element	=> Atom_Data	: Atom;
	When EList_Type		=> EList_Data	: Elementry_List;
	When Recursive_List	=> RList_Data	: Not Null Access List;
      end case;
   end record;
   Function As_List( Input : in List_Element ) Return List;

   Package Elements is New Ada.Containers.Indefinite_Vectors
	( Index_Type => Positive, Element_Type => List_Element );

   Type List is Tagged record
      Data : Elements.Vector:= Elements.Empty_Vector;
   end record;

   Procedure Write_List( Stream	: Not Null Access Stream_Root'Class;
			  Item	: In List
                       );
   Procedure Read_List( Stream	: Not Null Access Stream_Root'Class;
			 Item	: Out List
                       );

   For List'Read  Use Read_List;
   For List'Write Use Write_List;


End LISP;

---------------
-- LISP.ADB  --
---------------

With
Ada.Strings.Fixed;

Package Body LISP is

   FALSE_Text	: Constant String:= Boolean'Image( False );
   TRUE_Text	: Constant String:= Boolean'Image( True  );
   NULL_Text	: Constant String:= "NULL";

   Function Trim_Image( Input : In Float ) Return String is
      Use Ada.Strings, Ada.Strings.Fixed;
   Begin
      Return Result: String:=
        Trim( Side => Left, Source => Float'Image( Input ) );
   End Trim_Image;


   ------------------
   --  WRITE_ATOM  --
   ------------------
   Procedure Write_Atom(	Stream	: Not Null Access Stream_Root'Class;
				Item	: In Atom ) is
      Text : Access String;
   begin
      Case Item.Element is
	 When Empty_Type	=>
		Text:= New String'( NULL_Text );
         When Boolean_Type	=>
		Text:= New String'( Boolean'Image(Item.Boolean_Value) );
         When Integer_Type	=>
		Text:= New String'( Integer'Image(Item.Integer_Value) );
         When Real_Type		=>
		Text:= New String'( Float'Image( Item.Real_Value ) );
         When String_Type	=>
            If Not Item.Is_Name then
		Text:= New String'( '"' & Item.String_Value.All & '"' );
            else
		Text:= New String'( Item.String_Value.All );
            end if;
      End Case;
      String'Write(	Stream, Text.All	);
   end Write_Atom;


   --------------
   --  Append  --
   --------------
   Procedure Append( Head : In Out Elementry_List; Tail : In
Elementry_List ) is
   begin
      If Head.Terminal then
         Declare
            Result : Elementry_List:= Elementry_List'( Terminal =>
False,
		Head => Head.Head, Tail => New Elementry_List'(Tail) );
            For Result'Address Use Head'Address;
         Begin		-- Here the initialization of Result changes the value
            Null;	-- of Head because they are overlaid; further, we
are
         End;		-- guarenteed that the sizes are both the same because
      else		-- Elementry_List is a simple varient record and cannot
         Declare	-- be extended because it is not a tagged-type.
            This : Access Elementry_List:= Head.Tail;
         Begin
            While Not This.Terminal loop	-- If Head is not terminal
then
               This:= This.Tail;		-- we must traverse the list
            end loop;				-- until the end to append Tail.
            Append( This.All, Tail );
         End;
      end if;
   end Append;

   Function  Convert( List : Elementry_List ) Return Atom_Array is

      Function Get_Element( Item : Elementry_List ) Return Atom_Array
is
      begin
         if Item.Terminal then
            Return Result : Atom_Array:= ( 1 => Item.Head );
         else
            Return Result : Atom_Array:= Atom_Array'( 1 => Item.Head )
		& Get_Element( Item.Tail.All );
         end if;
      end Get_Element;

   begin
      Return Get_Element( List );
   end Convert;

   Function Create( Input : Atom ) Return Elementry_List is
   begin
      Return Result: Elementry_List:= ( Terminal => True, Head =>
Input );
   end;


   Function  Convert( List : Atom_Array ) Return Elementry_List is
   begin
      if List'Length = 0 then
         Raise Program_Error;
      end if;

      Declare
	Working : Elementry_List:= Create( Input => List(List'First) );
      Begin
	For Index in Positive'Succ(List'First)..List'Last loop
            Append( Head => Working, Tail => Create( List(Index) ) );
	end loop;
       Return Working;
      End;
   end Convert;


   ---------------------------------------------------
   --  Elementry_List's  'Read & 'Write Attributes  --
   ---------------------------------------------------

   Procedure Write_EList( Stream	: Not Null Access Stream_Root'Class;
			  Item		: In Elementry_List
                       ) is

   begin
      Character'Write( Stream, '(' );		-- When saving to a Stream
every
      Declare					-- elementry-list begins with an
         This : Elementry_List:= Item;		-- opening parenthisis,
followed
      Begin					-- by list of Atoms (whitespace
         List:					-- separated), terminated by a
         loop					-- closing parenthisis.
            Atom'Write( Stream, This.Head );
            Exit List When This.Terminal;
            This:= This.Tail.All;
            Character'Write( Stream, ',' );
         end loop List;
         Character'Write( Stream, ')' );
      End;
   end Write_EList;

   Procedure Read_EList( Stream	: Not Null Access Stream_Root'Class;
			 Item	: Out Elementry_List
                        ) is
      Function Parse_Atom( S : String ) Return Atom is
         Function Get_Type_Indicator(Input : String) Return
Element_Type is
            SubType Digit is Character Range '0'..'9';
         begin
            Case Input(Input'First) is		-- A floating-point numeric is
               When Digit =>			-- distinguished from an integer
                  For Index in Input'Range loop	-- by the decimal
point or the
                     Case Input(Index) is	-- exponent notation.
                        When 'e' | 'E' | '.' => Return Real_Type;
                        When Others => null;
                     End case;
                  end loop;
                  Return Integer_Type;
               When Others =>
                  if Input = NULL_Text then	-- NULL, TRUE, & FALSE are
texts
                     Return Empty_Type;		-- which are not String_Type.
                  elsif Input = TRUE_Text or Input = FALSE_Text then
                     Return Boolean_Type;
                  else				-- Everything else, however, is
                     Return String_Type;	-- either a String_Type or a
                  end if;			-- name. Strings start w/ '"'.
            end case;
         end Get_Type_Indicator;

       Use Ada.Strings, Ada.Strings.Fixed;			-- Parse_Atom
         Input : String:= Ada.Strings.Fixed.Trim( S, Both );	-- starts
here.
      begin
         Return Result : Atom(Get_Type_Indicator(Input)) do
            Case Result.Element is
            When Empty_Type	=> Null;
            When String_Type	=>
               Result.Is_Name:= Input(Input'First) = '"';
               if Not Result.Is_Name then
               Result.String_Value:= New String'(
		  Input(Positive'Succ(Input'First)..Positive'Pred(Input'Last))
						);
               else
                  Result.String_Value:= New String'(Input);
               end if;
            When Integer_Type	=> Result.Integer_Value:=
Integer'Value(Input);
            When Real_Type	=> Result.Real_Value:= Float'Value(Input);
            When Boolean_Type	=> Result.Boolean_Value:= Input =
TRUE_Text;
            End case;
         End Return;
      end Parse_Atom;

         WhiteSpace : Constant Array(Character) Of Boolean:=
           ( ASCII.VT | ASCII.HT | ASCII.LF | ASCII.CR | ' ' => True,
             Others => False );

	Type Index_Vector is Array (Positive Range <>) of Positive;
	Seperators	: Not Null Access Index_Vector:=
					New Index_Vector'( 2..1 => 1 );
	Working		: Not Null Access String:= New String'( "" );
	C		: Character;
	Result		: Elementry_List;
	In_String	: Boolean:= False;
	Is_Terminated	: Boolean:= False;

   begin
      Loop
	Character'Read( Stream, C );
	Case C is
	 When '"'	=>	In_String:= Not In_String;
				Is_Terminated:= False;
         When ')'	=>	Exit When Not In_String;
         When Others	=>
	    If WhiteSpace(C) then
		if Is_Terminated then
			GoTo Bypass;
		else
			Is_Terminated:= True;
		end if;
	    else
		Is_Terminated:= False;
	    end if;
	End Case;
	Working:= New String'( Working.All & C );	-- We update "working."
	if WhiteSpace(C) then			-- and delimit with whitespace.
	   Seperators:= New Index_Vector'( Seperators.All & Working'Last );
	end if;
	<<Bypass>>
	Null;
      End Loop;

	-- We simulate a terminating space by appending one more
	-- than the last index to Seperators.
	Seperators:= New Index_Vector'(Seperators.All & (Working'Last+1));

      Declare
	-- We use one more than Working'First to ignore the '(' that starts
	-- this list, just like we terminated the string just before
	-- copying the trailing ')' into Working.
	Start : Positive:= Working'First+1;
	Stop  : Positive;
      Begin
	for Index in Seperators'Range loop	-- Here is where we create an
	    Stop:= Seperators( Index )-1;	-- atom from every interval we
	    Append(Result,			-- recorded in "seperators".
		(Terminal => True, Head => Parse_Atom(Working(Start..Stop)))
		  );
	    Start:= Seperators( Index )+1;
	end loop;
      End;
					-- And we return everything we
      Item:= Result.Tail.All;		-- previously appended to result.
   end Read_EList;

   ---------------
   --  As_List  --
   ---------------
   Function As_List( Input : in List_Element ) Return List is
   Begin
      Return Result : List do
         Case Input.Element is
            When Atom_Element	=> Result.Data.Append( New_Item =>
Input );
            When Recursive_List	=> Result:= Input.RList_Data.All;
            When EList_Type	=>
               Declare
		Data : Elementry_List:= Input.EList_Data;
               Begin
		loop
		   Result.Data.Append( New_Item => (Atom_Element, Data.Head) );
		   Exit When Data.Terminal;
		   Data:= Data.Tail.All;
		end loop;
               End;
         End Case;
      End Return;
   End As_List;



   Procedure Write_List( Stream	: Not Null Access Stream_Root'Class;
			  Item	: In List
                       ) is
      SubType ELIST is Elementry_List;
   begin
      Character'Write( Stream, '(' );
      Declare
         Procedure Process_Data( Position : Elements.Cursor ) is
            Item : List_Element Renames Elements.Element( Position );
         begin
            Case Item.Element is
            When Atom_Element	=> Atom'Write( Stream, Item.Atom_Data );
            When EList_Type	=> ELIST'Write(Stream, Item.EList_Data);
            When Recursive_List	=> List'Write( Stream,
Item.RList_Data.All );
            end case;
         end Process_Data;
      Begin
         Item.Data.Iterate( Process_Data'Access );
      End;
      Character'Write( Stream, ')' );
   end Write_List;

   Procedure Read_List( Stream	: Not Null Access Stream_Root'Class;
			 Item	: Out List
                      ) is
   begin
      null;
   end Read_List;


End LISP;