added experimental stream handling code

cmd/scheme.adb

@@ -1,6 +1,9 @@
 with H2.Scheme;
+with H2.Pool;
 with Storage;
+with Stream;
 with Ada.Text_IO;
+with Ada.Unchecked_Deallocation;
 
 procedure scheme is
 	package S renames H2.Scheme;
@@ -10,12 +13,62 @@ procedure scheme is
 
 	I: S.Object_Pointer;
 	O: S.Object_Pointer;
+
+	--String: aliased S.Object_String := "(car '(1 2 3))";
+	String: aliased S.Object_String := "((lambda (x y) (+ x y))  9  7)";
+	String_Stream: Stream.String_Input_Stream_Record (String'Unchecked_Access);
+	--String_Stream: Stream.String_Input_Stream_Record := (Len => String'Length, Str => String, Pos => 0);
+	
+
+	File_Name: aliased S.Object_String := "test.adb";
+	--File_Stream: Stream.File_Stream_Record (File_Name'Unchecked_Access);
+	--File_Stream: Stream.File_Stream_Record := (Name => File_Name'Unchecked_Access);
+	File_Stream: Stream.File_Stream_Record;
+
+	procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
+	                           Name:   access S.Object_String;
+	                           Result: in out S.Stream_Pointer) is
+		subtype FSR is Stream.File_Stream_Record;
+		type FSP is access all FSR;
+		package P is new H2.Pool (FSR, FSP);
+
+		X: FSP;
+		for X'Address use Result'Address;
+		pragma Import (Ada, X);
+	begin
+		X := P.Allocate (S.Get_Storage_Pool(Interp));
+		X.Name := Stream.Object_String_Pointer(Name);
+	end Allocate_Stream;
+
+	procedure Deallocate_Stream (Interp: in out S.Interpreter_Record;
+	                             Source: in out S.Stream_Pointer) is
+		subtype FSR is Stream.File_Stream_Record;
+		type FSP is access all FSR;
+		package P is new H2.Pool (FSR, FSP);
+
+		X: FSP;
+		for X'Address use Source'Address;
+		pragma Import (Ada, X);
+	begin
+		P.Deallocate (X, S.Get_Storage_Pool(Interp));
+	end Deallocate_Stream;
+
+--   --procedure Dealloc_Stream is new Ada.Unchecked_Deallocation (Stream_Record'Class, Stream_Pointer);
+--   --procedure Destroy_Stream (Stream: in out Stream_Pointer) renames Dealloc_Stream;
+
+
 begin
 	Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Pointer_Bytes));
 
 	S.Open (SI, 2_000_000, Pool'Unchecked_Access);
 	--S.Open (SI, null);
+
+File_Stream.Name := File_Name'Unchecked_Access;
+S.Set_Input_Stream (SI, File_Stream); -- specify main input stream
+--S.Set_Output_Stream (SI, Stream); -- specify main output stream.
+S.Read (SI, I);
 S.Make_Test_Object (SI, I);
+
 	S.Evaluate (SI, I, O);
 S.Print (SI, I);
 Ada.Text_IO.Put_Line ("-------------------------------------------");

cmd/scheme.gpr.in

@@ -1,7 +1,7 @@
 
 with "@abs_builddir@/../lib/libh2";
 
-project H2_Scheme is
+project Scheme is
 
 	for Main use ("scheme");
 
@@ -15,13 +15,15 @@ project H2_Scheme is
 	for Source_Files use (
 		"storage.ads",
 		"storage.adb",
+		"stream.ads",
+		"stream.adb",
 		"scheme.adb"
 	);
 	for Object_Dir use "@ADA_OBJDIR@";
 
 	package Compiler is
 		for Default_Switches ("Ada") use (
-			"-gnata", "-gnato", "-gnatN",  "-gnatwl",
+			"-gnata", "-gnato", "-gnatN",  "-gnatwl", "-gnat95"
 			"-I@abs_srcdir@/../lib"
 		);
 	end Compiler;
@@ -30,6 +32,6 @@ project H2_Scheme is
 		for Executable ("scheme.adb") use "h2scm";
 	end Builder;
 
-end H2_Scheme;
+end Scheme;
 
 

cmd/stream.adb

@@ -0,0 +1,87 @@
+
+package body Stream is
+
+	------------------------------------------------------------------
+
+	procedure Open (Stream: in out String_Input_Stream_Record) is
+	begin
+Ada.Text_IO.Put_Line ("OPEN STRING STREAM");
+		Stream.Pos := 0;
+	end Open;
+
+	procedure Close (Stream: in out String_Input_Stream_Record) is
+	begin
+Ada.Text_IO.Put_Line ("CLOSE STRING STREAM");
+		Stream.Pos := Stream.Str'Last;
+	end Close;
+
+	procedure Read (Stream: in out String_Input_Stream_Record;
+	                Data:   out    S.Object_String;
+	                Last:   out    Standard.Natural) is
+		Avail: Standard.Natural;
+	begin
+		Avail := Stream.Str'Last - Stream.Pos;
+		if Avail <= 0 then
+			-- EOF
+			Last := Data'First - 1;
+		else
+			if Avail > Data'Length then
+				Avail := Data'Length;
+			end if;
+
+			Data(Data'First .. Avail) := Stream.Str(Stream.Pos + 1..Stream.Pos + Avail);
+			Stream.Pos := Stream.Pos + Avail;
+			Last := Data'First + Avail - 1;
+		end if;
+	end Read;
+
+	procedure Write (Stream: in out String_Input_Stream_Record;
+	                 Data:   out    S.Object_String;
+	                 Last:   out    Standard.Natural) is
+	begin
+		--raise S.Stream_Error;
+		Last := Data'First - 1;
+	end Write;
+
+	------------------------------------------------------------------
+
+	procedure Open (Stream: in out File_Stream_Record) is
+	begin
+Ada.Text_IO.Put_Line ("OPEN File STREAM");
+		Ada.Text_IO.Open (Stream.Handle, Ada.Text_IO.In_File, Stream.Name.all);
+	end Open;
+
+	procedure Close (Stream: in out File_Stream_Record) is
+	begin
+Ada.Text_IO.Put_Line ("CLOSE File STREAM");
+		Ada.Text_IO.Close (Stream.Handle);
+	end Close;
+
+	procedure Read (Stream: in out File_Stream_Record;
+	                Data:   out    S.Object_String;
+	                Last:   out    Standard.Natural) is
+	begin
+		for I in Data'First .. Data'Last loop
+			begin
+				Ada.Text_IO.Get_Immediate (Stream.Handle, Data(I));
+			exception
+				when Ada.Text_IO.End_Error =>
+					Last := I - 1;
+					return;
+				-- other exceptions must be just raised to indicate errors
+			end;
+		end loop;
+		Last := Data'Last;
+	end Read;
+
+	procedure Write (Stream: in out File_Stream_Record;
+	                 Data:   out    S.Object_String;
+	                 Last:   out    Standard.Natural) is
+	begin
+		--raise S.Stream_Error;
+		Last := Data'First - 1;
+	end Write;
+
+	------------------------------------------------------------------
+
+end Stream;

cmd/stream.ads

@@ -0,0 +1,48 @@
+with H2.Scheme;
+with Ada.Text_IO;
+
+package Stream is
+
+	package S renames H2.Scheme;
+
+	------------------------------------------------------------
+	type Object_String_Pointer is access all S.Object_String;
+	type String_Input_Stream_Record(Str: Object_String_Pointer) is new S.Stream_Record with record
+		Pos: Standard.Natural := 0;	
+	end record;
+
+	--type String_Input_Stream_Record(Len: Standard.Natural) is new S.Stream_Record with record
+	--	Pos: Standard.Natural := 0;	
+	--	Str: S.Object_String (1 .. Len) := (others => ' ');
+	--end record;
+
+	procedure Open (Stream: in out String_Input_Stream_Record);
+	procedure Close (Stream: in out String_Input_Stream_Record);
+	procedure Read (Stream: in out String_Input_Stream_Record;
+	                Data:   out    S.Object_String;
+	                Last:   out    Standard.Natural);
+	procedure Write (Stream: in out String_Input_Stream_Record;
+	                 Data:   out    S.Object_String;
+	                 Last:   out    Standard.Natural);
+
+	------------------------------------------------------------
+	--type File_Stream_Record(Name: Object_String_Pointer) is new S.Stream_Record with record
+	--	Handle: Ada.Text_IO.File_Type;
+	--end record;
+
+	type File_Stream_Record is new S.Stream_Record with record
+		Name:   Object_String_Pointer;
+		Handle: Ada.Text_IO.File_Type;
+	end record;
+
+	procedure Open (Stream: in out File_Stream_Record);
+	procedure Close (Stream: in out File_Stream_Record);
+	procedure Read (Stream: in out File_Stream_Record;
+	                Data:   out    S.Object_String;
+	                Last:   out    Standard.Natural);
+	procedure Write (Stream: in out File_Stream_Record;
+	                 Data:   out    S.Object_String;
+	                 Last:   out    Standard.Natural);
+
+end Stream;
+