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;
+

lib/h2-pool.adb

@@ -28,30 +28,30 @@ package body H2.Pool is
 		end if;
 	end Allocate;
 
-	function Allocate (Source: in Normal_Type; 
+--	function Allocate (Source: in Normal_Type; 
-	                   Pool:   in Storage_Pool_Pointer := null) return Pointer_Type is
+--	                   Pool:   in Storage_Pool_Pointer := null) return Pointer_Type is
-		P: Storage_Pool_Pointer;
+--		P: Storage_Pool_Pointer;
-	begin
+--	begin
-		if Pool = null then
+--		if Pool = null then
-			P := Storage_Pool;
+--			P := Storage_Pool;
-		else
+--		else
-			P := Pool;
+--			P := Pool;
-		end if;
+--		end if;
-
+--
-		if P = null then
+--		if P = null then
-			return new Normal_Type'(Source);
+--			return new Normal_Type'(Source);
-		else
+--		else
-			declare
+--			declare
-				type Pooled_Pointer is access Normal_Type;
+--				type Pooled_Pointer is access Normal_Type;
-				for Pooled_Pointer'Storage_Pool use P.all;
+--				for Pooled_Pointer'Storage_Pool use P.all;
-				function To_Pointer_Type is new Ada.Unchecked_Conversion (Pooled_Pointer, Pointer_Type);
+--				function To_Pointer_Type is new Ada.Unchecked_Conversion (Pooled_Pointer, Pointer_Type);
-				Tmp: Pooled_Pointer;
+--				Tmp: Pooled_Pointer;
-			begin
+--			begin
-				Tmp := new Normal_Type'(Source);
+--				Tmp := new Normal_Type'(Source);
-				return To_Pointer_Type (Tmp);
+--				return To_Pointer_Type (Tmp);
-			end; 
+--			end; 
-		end if;
+--		end if;
-	end Allocate;
+--	end Allocate;
 
 	procedure Deallocate (Target: in out Pointer_Type;
 	                      Pool:   in Storage_Pool_Pointer := null) is

lib/h2-pool.ads

@@ -7,16 +7,17 @@
 --------------------------------------------------------------------
 
 generic
-	type Normal_Type is private;
+	--type Normal_Type is private;
-	type Pointer_Type is access Normal_Type;
+	type Normal_Type is limited private;
+	type Pointer_Type is access all Normal_Type;
 	Storage_Pool: in Storage_Pool_Pointer := null;
 
 package H2.Pool is
 
 	function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type;
 
-	function Allocate (Source: in Normal_Type; 
+--	function Allocate (Source: in Normal_Type; 
-	                   Pool:   in Storage_Pool_Pointer := null) return Pointer_Type;
+--	                   Pool:   in Storage_Pool_Pointer := null) return Pointer_Type;
 
 	procedure Deallocate (Target: in out Pointer_Type;
 	                      Pool:   in     Storage_Pool_Pointer := null);

lib/h2-scheme.adb

@@ -22,17 +22,21 @@ package body H2.Scheme is
 	type Heap_Element_Pointer is access all Heap_Element;
 	for Heap_Element_Pointer'Size use Object_Pointer_Bits; -- ensure that it can be overlayed by an ObjectPointer
 
+
 	type Thin_Heap_Element_Array is array (1 .. Heap_Size'Last) of Heap_Element;
 	type Thin_Heap_Element_Array_Pointer is access all Thin_Heap_Element_Array;
 	for Thin_Heap_Element_Array_Pointer'Size use Object_Pointer_Bits;
 
-	subtype Opcode_Type is Object_Integer range 0 .. 5;
+	subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
+
+	subtype Opcode_Type is Object_Integer range 0 .. 6;
 	Opcode_Exit:               constant Opcode_Type := Opcode_Type'(0);
 	Opcode_Evaluate_Object:    constant Opcode_Type := Opcode_Type'(1);
 	Opcode_Evaluate_Group:     constant Opcode_Type := Opcode_Type'(2);
 	Opcode_Evaluate_Syntax:    constant Opcode_Type := Opcode_Type'(3);
 	Opcode_Evaluate_Procedure: constant Opcode_Type := Opcode_Type'(4);
 	Opcode_Apply:              constant Opcode_Type := Opcode_Type'(5);
+	Opcode_Read_Object:        constant Opcode_Type := Opcode_Type'(6);
 
 	-----------------------------------------------------------------------------
 	-- COMMON OBJECTS
@@ -58,13 +62,10 @@ package body H2.Scheme is
 	Closure_Code_Index: constant Pointer_Object_Size := 1;
 	Closure_Environment_Index: constant Pointer_Object_Size := 2;
 
-	Pair_Object_Size: constant Pointer_Object_Size := 3;
+	procedure Set_New_Location (Object: in Object_Pointer;
-	Pair_Key_Size: constant Pointer_Object_Size := 1;
+	                            Ptr:    in Heap_Element_Pointer);
-	Pair_Value_Size: constant Pointer_Object_Size := 2;
+	procedure Set_New_Location (Object: in Object_Pointer;
-	Pair_Link_Size: constant Pointer_Object_Size := 3;
+	                            Ptr:    in Object_Pointer);
-
-	procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Heap_Element_Pointer);
-	procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Object_Pointer);
 	pragma Inline (Set_New_Location);
 
 	function Get_New_Location (Object: in Object_Pointer) return Object_Pointer;
@@ -117,7 +118,6 @@ package body H2.Scheme is
 		return Get_Pointer_Type(Pointer) = Object_Pointer_Type_Byte;
 	end Is_Byte;
 
-
 	function Integer_To_Pointer (Int: in Object_Integer) return Object_Pointer is
 		Pointer: Object_Pointer;
 		Word: Object_Word;
@@ -389,7 +389,6 @@ package body H2.Scheme is
 	-- object takes up the smallest space that a valid object can take. So
 	-- it is safe to overlay it on any normal objects.
 	procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Heap_Element_Pointer) is
-		subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
 		Moved_Object: Moved_Object_Record;
 		for Moved_Object'Address use Object.all'Address;
 		-- pramga Import must not be specified here as I'm counting
@@ -402,7 +401,6 @@ package body H2.Scheme is
 	end Set_New_Location;
 
 	procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Object_Pointer) is
-		subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
 		Moved_Object: Moved_Object_Record;
 		for Moved_Object'Address use Object.all'Address;
 		--pragma Import (Ada, Moved_Object); -- this must not be used.
@@ -419,14 +417,21 @@ package body H2.Scheme is
 	                                 Heap_Bytes: in     Heap_Size) return Heap_Element_Pointer is
 		Avail: Heap_Size;
 		Result: Heap_Element_Pointer;
+		Real_Bytes: Heap_Size := Heap_Bytes;
 	begin
+		if Real_Bytes < Moved_Object_Record'Max_Size_In_Storage_Elements then
+			-- Guarantee the minimum object size to be greater than or 
+			-- equal to the size of a moved object for GC to work.
+			Real_Bytes := Moved_Object_Record'Max_Size_In_Storage_Elements;	
+		end if;
+
 		Avail := Heap.Size - Heap.Bound;
-		if Heap_Bytes > Avail then
+		if Real_Bytes > Avail then
 			return null;
 		end if;
 		
 		Result := Heap.Space(Heap.Bound + 1)'Unchecked_Access;
-		Heap.Bound := Heap.Bound + Heap_Bytes;
+		Heap.Bound := Heap.Bound + Real_Bytes;
 		return Result;
 	end Allocate_Bytes_In_Heap;
 
@@ -446,7 +451,7 @@ package body H2.Scheme is
 		-- Target_Object_Record'Max_Size_In_Stroage_Elements were not
 		-- always correct. For example, for a character object containing
 		-- the string "lambda", Target_Object.all'Size returned 72 while
-		-- it's supposed to be 96. 
+		-- it's supposed to be 96. Use Copy_Object_With_Size() below instead.
 		Target_Object.all := Source.all;
 		pragma Assert (Source.all'Size = Target_Object.all'Size);
 	end Copy_Object;
@@ -1313,6 +1318,7 @@ Put_String (To_Thin_String_Pointer (Result));
 					Heap := Pool.Allocate;
 				end;
 			end loop;
+
 		exception
 			when others =>
 				Deinitialize_Heap (Interp);
@@ -1376,33 +1382,60 @@ Put_String (To_Thin_String_Pointer (Result));
 		Interp.Root_Table := Nil_Pointer;
 		Interp.Symbol_Table := Nil_Pointer;
 
-		Interp.Line_Pos := Interp.Line'First - 1;
+		Interp.Input.Stream := null;
-		Interp.Line_Last := Interp.Line'First - 1;
+		Interp.IO := Interp.Input'Unchecked_Access;
 
 -- TODO: disallow garbage collecion during initialization.
+Text_IO.Put_Line ("1111111111");
 		Initialize_Heap (Initial_Heap_Size);
 		Interp.Mark := Make_Mark (Interp.Self, 0); -- to indicate the end of cons evluation
 		Interp.Root_Environment := Make_Environment (Interp.Self, Nil_Pointer);
 		Interp.Environment := Interp.Root_Environment;
 		Make_Syntax_Objects;
 		Make_Procedure_Objects;
+Text_IO.Put_Line ("99999");
 
 	exception
 		when others =>
 			Deinitialize_Heap (Interp);
 	end Open;
 
+	procedure Close_Stream (Stream: in out Stream_Pointer) is
+	begin
+		Close (Stream.all);
+		Stream := null;
+	exception
+		when others =>
+			Stream := null; -- ignore exception
+	end Close_Stream;
+
+	procedure Close_All_Streams (Interp: in out Interpreter_Record) is
+	begin
+		-- TODO: close all cascaded streams if any.
+		if Interp.Input.Stream /= null then
+			Close_Stream (Interp.Input.Stream);
+		end if;
+	end Close_All_Streams;
+
 	procedure Close (Interp: in out Interpreter_Record) is
 	begin
+		Close_All_Streams (Interp);
 		Deinitialize_Heap (Interp);
 	end Close;
 
+	function Get_Storage_Pool (Interp: in Interpreter_Record) return Storage_Pool_Pointer is
+	begin
+		return Interp.Storage_Pool;	
+	end Get_Storage_Pool;
+
 	procedure Set_Option (Interp: in out Interpreter_Record;
 	                      Option: in     Option_Record) is
 	begin
 		case Option.Kind  is
-		when Trait_Option =>
+			when Trait_Option =>
 				Interp.Trait := Option;
+			when Stream_Option =>
+				Interp.Stream := Option;
 		end case;
 	end Set_Option;
 
@@ -1410,36 +1443,123 @@ Put_String (To_Thin_String_Pointer (Result));
 	                      Option: in out Option_Record) is
 	begin
 		case Option.Kind  is
-		when Trait_Option =>
+			when Trait_Option =>
 				Option := Interp.Trait;
+			when Stream_Option =>
+				Option := Interp.Stream;
 		end case;
 	end Get_Option;
 
+	procedure Set_Input_Stream  (Interp: in out Interpreter_Record;
+	                             Stream: in out Stream_Record'Class) is
+	begin
+		--Open (Stream, Interp);		
+		Open (Stream);
+
+		-- if Open raised an exception, it wouldn't reach here.
+		-- so the existing stream still remains intact.
+		if Interp.Input.Stream /= null then
+			Close_Stream (Interp.Input.Stream);
+		end if;
+
+		--Interp.Input := IO_Record'(
+		--	Stream => Stream'Unchecked_Access,
+		--	Data => (others => ' '),
+		--	Pos => Interp.Input.Data'First - 1,
+		--	Last => Interp.Input.Data'First - 1, 
+		--	Flags => 0
+		--);
+		Interp.Input.Stream := Stream'Unchecked_Access;
+		Interp.Input.Pos := Interp.Input.Data'First - 1; 
+		Interp.Input.Last := Interp.Input.Data'First - 1; 
+		Interp.Input.Flags := 0;
+	end Set_Input_Stream;
+
+	--procedure Set_Output_Stream (Interp: in out Interpreter_Record;
+	--                             Stream: in out Stream_Record'Class) is
+	--begin
+	--	
+	--end Set_Output_Stream;
+
+	procedure Start_Input_Stream (Interp: in out Interpreter_Record;
+	                        Name:   access Object_String) is
+		package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool);
+		IO: IO_Pointer;
+	begin
+		IO := IO_Pool.Allocate;
+		begin
+			Interp.Stream.Allocate (Interp, Name, IO.Stream);
+		exception
+			when others =>	
+				IO_Pool.Deallocate (IO);
+				raise;
+		end;
+
+		begin
+			Open (IO.Stream.all);
+		exception
+			when others =>
+				Interp.Stream.Deallocate (Interp, IO.Stream);
+				IO_Pool.Deallocate (IO);
+			raise;
+		end;
+		IO.Pos := IO.Data'First - 1;
+		IO.Last := IO.Data'First - 1;
+		IO.Flags := 0;
+
+		IO.Next := Interp.IO;
+		Interp.IO := IO;
+	end Start_Input_Stream;
+
+	procedure Stop_Input_Stream (Interp: in out Interpreter_Record) is
+		package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool);
+		IO: IO_Pointer;
+	begin
+		pragma Assert (Interp.IO /= Interp.Input'Unchecked_Access);
+		IO := Interp.IO;
+		Interp.IO := IO.Next;
+
+		Interp.Stream.Deallocate (Interp, IO.Stream);
+		IO_Pool.Deallocate (IO);
+	end Stop_Input_Stream;
+
 	procedure Read (Interp: in out Interpreter_Record;
 	                Result: out    Object_Pointer) is
 
-		EOF_Error: exception;
+		End_Error: exception;
 
 		function Get_Character return Object_Character is
 		begin
-			if Interp.Line_Pos >= Interp.Line_Last then
+		-- TODO: calculate Interp.Input.Row, Interp.Input.Column
-				if Text_IO.End_Of_File then
+			if Interp.Input.Pos >= Interp.Input.Last then
-					raise EOF_Error;
+				if Interp.Input.Flags /= 0 then
+					-- an error has occurred previously.
+					raise End_Error;
 				end if;
-				Text_IO.Get_Line (Interp.Line, Interp.Line_Last);
-				Interp.Line_Pos := Interp.Line'First - 1;
-			end if;
 
-			Interp.Line_Pos := Interp.Line_Pos + 1;
+				Interp.Input.Pos := Interp.Input.Data'First - 1;
-			return Interp.Line(Interp.Line_Pos);
+				begin
+					Read (Interp.Input.Stream.all, Interp.Input.Data, Interp.Input.Last);
+				exception
+					when others =>
+						Interp.Input.Flags := Interp.Input.Flags and IO_Error_Occurred;
+						raise End_Error; -- TODO: change the exception name
+				end;
+				if Interp.Input.Last < Interp.Input.Data'First then	
+					Interp.Input.Flags := Interp.Input.Flags and IO_End_Reached;
+					raise End_Error;
+				end if;
+			end if;
+			Interp.Input.Pos := Interp.Input.Pos + 1;
+			return Interp.Input.Data(Interp.Input.Pos);
 		end Get_Character;
 
 		procedure Skip_Space is
 		begin
 			null;
 		end Skip_Space;
-		
+
-		--function Get_Token is
+		--function Get_Token return Token_Type is
 		--begin
 		--	null;	
 		--end Get_Token;
@@ -1452,13 +1572,23 @@ Put_String (To_Thin_String_Pointer (Result));
 		Stack: Object_Pointer;
 		Opcode: Object_Integer;
 		Operand: Object_Pointer;
+
+		C: Object_Character;
 	begin
 		--Opcode := 1;
 		--loop
 		--	case Opcode is
 		--		when 1 =>
 		--end loop;
-		null;
+		loop
+			C := Get_Character;
+			Text_IO.Put (C);
+		end loop;
+
+	exception
+		when End_Error =>
+			TEXT_IO.New_Line;
+			Text_IO.Put_Line ("END OF INPUT...");
 	end Read;
 	          
 	procedure Print (Interp: in out Interpreter_Record; 
@@ -1694,7 +1824,7 @@ Interp.Root_Table := Make_Symbol (Interp.Self, "lambda");
 
 		--X := Make_Cons (Interp.Self, Nil_Pointer, Make_Cons (Interp.Self, Nil_Pointer, Integer_To_Pointer(TEN)));
 		--X := Make_Cons (Interp.Self, Nil_Pointer, Nil_Pointer);
-		Read (Interp, X);
+		--Read (Interp, X);
 		Print (Interp, X);
 
 	end Evaluatex;
@@ -2301,6 +2431,62 @@ Print (Interp, Operand);
 			end case;
 		end Apply;
 
+		procedure Read_Object is
+
+--			function Get_Character return Object_Character is
+--			begin
+--				if Interp.Line_Pos >= Interp.Line_Last then
+--					if Text_IO.End_Of_File then
+--						raise EOF_Error;
+--					end if;
+--					Text_IO.Get_Line (Interp.Line, Interp.Line_Last);
+--					Interp.Line_Pos := Interp.Line'First - 1;
+--				end if;
+--	
+--				Interp.Line_Pos := Interp.Line_Pos + 1;
+--				return Interp.Line(Interp.Line_Pos);
+--			end Get_Character;
+
+--			type Input_Object_Record is
+--			end record;
+--			Read (Input_Object_Record);
+--			Write (Input_Object_Record);
+--			Close (Input_Object_Record);
+--
+--			type Input_Object_Class_Pointer is access all Input_Object_Record'Class;
+--
+--			type Input_Record is record
+--				Pos: Standard.Natural;
+--				Last: Standard.Natural;
+--				Buffer: Object_String (1 .. 1024);
+--				Handle: Input_Object_Class_Pointer;
+--			end record;
+--			function Get_Character return Object_Character is
+--			begin
+--				if Interp.Input.Pos >= Interp.Input.Last then
+--					Read (Interp.Input.Handle, Interp.Input.Buffer, Interp.Input.Last);
+--					Interp.Input.Pos := Interp.Input.Buffer'First - 1;
+--				end if;
+--
+--				Interp.Input.Pos := Interp.Input.Pos + 1;
+--				return Interp.Input.Buffer(Interp.Input.Pos);
+--			end Get_Character;
+
+		begin
+			null;
+
+			--if Interp.Input.Handle = null then
+			--	Interp.Input.Handle := Interp.Tio ("");
+			--	Interp.Input.Pos := 0;
+			--	Interp.Input.Last := 0;
+			--end if;
+
+			-- In Interp.Close()
+			-- if Interp.Input.Handle /= null then
+			-- 	Close (Interp.Input.Handle);
+			--end if;
+		end Read_Object;
+
 	begin
 		
 		-- Stack frames looks like this upon initialization
@@ -2373,6 +2559,11 @@ Print (Interp, Operand);
 
 		loop
 			case Get_Frame_Opcode(Interp.Stack) is
+				when Opcode_Exit =>
+					Result := Get_Frame_Return (Interp.Stack);
+					Pop_Frame;
+					exit;
+
 				when Opcode_Evaluate_Object =>
 					Evaluate_Object;
 
@@ -2388,10 +2579,8 @@ Print (Interp, Operand);
 				when Opcode_Apply =>
 					Apply;
 
-				when Opcode_Exit =>
+				when Opcode_Read_Object =>
-					Result := Get_Frame_Return (Interp.Stack);
+					Read_Object;
-					Pop_Frame;
-					exit;
 			end case;
 		end loop;
 
@@ -2405,6 +2594,13 @@ Print (Interp, Operand);
 			-- TODO: restore envirronemtn frame???
 	end Evaluate;
 
+	procedure Run_Loop (Interp: in out Interpreter_Record;
+	                Result: out    Object_Pointer) is
+		-- standard read-eval-print loop
+	begin
+		null;
+	end Run_Loop;
+	
 	-----------------------------------------------------------------------------
 
 	function h2scm_open return Interpreter_Pointer;

lib/h2-scheme.ads

@@ -6,23 +6,62 @@
 --       # #      #    # #      #    # #            #     # #       
 -- #     # #    # #    # #      #    # #            #     # #       
 --  #####   ####  #    # ###### #    # ######       #     # ####### 
+--
+-- Literal
+--  Number: 1, 10
+--  String: "hello"
+--
+-- Environment
+--  The environment holds the key/value pairs.
+--
+-- Procedure
+--  Some builtin-procedure objects are registered to the top-level environment
+--  upon start-up. You can break the mapping between a name and a procedure
+--  as it's in the normal environment.
+--
+-- Syntax Object
+--  Some syntax objects are registered upon start-up. They are handled 
+--  very specially when the list containing one of them as the first argument
+--  is evaluated.
+--
+-- Evaluation Rule
+--   A literal object evaluates to itself. A Symbol object evaluates to 
+--   a value found in the environment. List evaluation is slightly more 
+--   complex. Each element of a list is evluated using the standard evaluation
+--   rule. The first argument acts as a function and the rest of the arguments
+--   are applied to the function. An element must evaluate to a closure to be
+--   a function. The syntax object bypasses the normal evaluation rule and is
+--   evaluated according to the object-specific rule.
+--
 ---------------------------------------------------------------------
 
 with System;
 with System.Storage_Pools;
 
-
 with Ada.Unchecked_Conversion;
 -- TODO: delete these after debugging
 with ada.text_io;
 with ada.wide_text_io;
 with ada.integer_text_io;
 with ada.long_integer_text_io;
---with system.address_image;
 -- TODO: delete above after debugging
 
 package H2.Scheme is
 
+	type Interpreter_Record is limited private;
+	type Interpreter_Pointer is access all Interpreter_Record;
+
+	-- -----------------------------------------------------------------------------
+	-- While I could define Heap_Element and Heap_Size to be
+	-- the subtype of Object_Byte and Object_Size each, they are not
+	-- logically the same thing.
+	-- subtype Storage_Element is Object_Byte;
+	-- subtype Storage_Count is Object_Size;
+	type Heap_Element is mod 2 ** System.Storage_Unit;
+	type Heap_Size is range 0 .. (2 ** (System.Word_Size - 1)) - 1;
+
+	-- -----------------------------------------------------------------------
+
 	-- An object pointer takes up as many bytes as a system word.
 	Object_Pointer_Bits: constant := System.Word_Size;
 	Object_Pointer_Bytes: constant := Object_Pointer_Bits / System.Storage_Unit;
@@ -173,8 +212,8 @@ package H2.Scheme is
 		-- Object payload:
 		--  I assume that the smallest payload is able to hold an 
 		--  object pointer by specifying the alignement attribute 
-		--  to Object_Pointer_Bytes. this implementation will break
+		--  to Object_Pointer_Bytes and checking the minimum allocation
-		--  severely if this assumption is not correct.
+		--  size in Allocate_Bytes_In_Heap().
 		case Kind is
 			when Moved_Object =>
 				New_Pointer: Object_Pointer := null;
@@ -248,26 +287,72 @@ package H2.Scheme is
 	pragma Inline (Pointer_To_Byte);
 
 	-- -----------------------------------------------------------------------------
-	-- While I could define Heap_Element and Heap_Size to be
+
-	-- the subtype of Object_Byte and Object_Size each, they are not
+
-	-- logically the same thing.
+	type Stream_Record is abstract tagged limited null record;
-	-- subtype Storage_Element is Object_Byte;
+
-	-- subtype Storage_Count is Object_Size;
+	procedure Open (Stream: in out Stream_Record) is abstract;
-	type Heap_Element is mod 2 ** System.Storage_Unit;
+
-	type Heap_Size is range 0 .. (2 ** (System.Word_Size - 1)) - 1;
+	procedure Close (Stream: in out Stream_Record) is abstract;
+
+	procedure Read (Stream: in out Stream_Record;
+	                Data:   out    Object_String;
+	                Last:   out    Standard.Natural) is abstract;
+
+	procedure Write (Stream: in out Stream_Record;
+	                 Data:   out    Object_String;
+	                 Last:   out    Standard.Natural) is abstract;
+
+	type Stream_Pointer is access all Stream_Record'Class;
+
+	type Stream_Allocator is access 
+		procedure (Interp: in out Interpreter_Record; 
+		           Name:   access Object_String;
+		           Result: out Stream_Pointer);
+
+	type Stream_Deallocator is access 
+		procedure (Interp: in out Interpreter_Record; 
+		           Source: in out Stream_Pointer);
+
+
+	type IO_Flags is mod 2 ** 4;
+	IO_End_Reached: constant IO_Flags := IO_Flags'(2#0001#); 
+	IO_Error_Occurred: constant IO_Flags := IO_Flags'(2#0001#); 
+
+	type IO_Record;
+	type IO_Pointer is access all IO_Record;
+
+	type IO_Record is record
+	--type IO_Record is limited record
+		Stream: Stream_Pointer := null;
+		--Data: Object_String(1..2048) := (others => ' ');
+		Data: Object_String(1..5) := (others => ' ');
+		Last: Standard.Natural := 0;
+		Pos: Standard.Natural := 0;
+		Flags: IO_Flags := 0; -- EOF, ERROR
+		Next: IO_Pointer;
+	end record;
+
+
+	-- -----------------------------------------------------------------------------
 
 	type Trait_Mask is mod 2 ** System.Word_Size;
 	No_Garbage_Collection: constant Trait_Mask := 2#0000_0000_0000_0001#;
 	No_Optimization:       constant Trait_Mask := 2#0000_0000_0000_0010#;
 
-	type Option_Kind is (Trait_Option);
+	type Option_Kind is (Trait_Option, Stream_Option);
 	type Option_Record (Kind: Option_Kind) is record
 		case Kind is
 			when Trait_Option =>
 				Trait_Bits: Trait_Mask := 0;
+
+			when Stream_Option =>
+				Allocate: Stream_Allocator := null;
+				Deallocate: Stream_Deallocator := null;
 		end case;
 	end record;  
 
+
 	-- -----------------------------------------------------------------------------
 
 	-- The nil/true/false object are represented by special pointer values.
@@ -297,26 +382,6 @@ package H2.Scheme is
 
 	-- -----------------------------------------------------------------------------
 
-	type Interpreter_Record is limited private;
-
-	type Interpreter_Text_IO_Record is abstract tagged null record;
-
-	procedure Open (IO:   in out Interpreter_Text_IO_Record;
-	                Name: in     Object_String) is abstract;
-
-	procedure Close (IO: in out Interpreter_Text_IO_Record) is abstract;
-
-	procedure Read (IO:   in out Interpreter_Text_IO_Record;
-	                Data: in     Object_String;
-	                Last: in     Standard.Natural) is abstract;
-
-	procedure Write (IO:   in out Interpreter_Text_IO_Record;
-	                 Data: out    Object_String;
-	                 Last: out    Standard.Natural) is abstract;
-		
-	
-	-- -----------------------------------------------------------------------------
-
 procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Object_Pointer);
 
 	procedure Open (Interp:           in out Interpreter_Record;
@@ -325,6 +390,21 @@ procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Objec
 
 	procedure Close (Interp: in out Interpreter_Record);
 
+	function Get_Storage_Pool (Interp: in Interpreter_Record) return Storage_Pool_Pointer;
+
+	procedure Set_Option (Interp: in out Interpreter_Record;
+	                      Option: in     Option_Record);
+
+	procedure Get_Option (Interp: in out Interpreter_Record;
+	                      Option: in out Option_Record);
+	
+	procedure Set_Input_Stream  (Interp: in out Interpreter_Record;
+	                             Stream: in out Stream_Record'Class);
+
+	-- Source must be open for Read() to work.
+	procedure Read (Interp: in out Interpreter_Record;
+	                Result: out    Object_Pointer);
+
 	procedure Evaluate (Interp: in out Interpreter_Record;
 	                    Source: in     Object_Pointer;
 	                    Result: out    Object_Pointer);
@@ -332,12 +412,8 @@ procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Objec
 	procedure Print (Interp: in out Interpreter_Record;
 	                 Source: in     Object_Pointer);
 
-	procedure Set_Option (Interp: in out Interpreter_Record;
+	procedure Run_Loop (Interp: in out Interpreter_Record;
-	                      Option: in     Option_Record);
+	                    Result: out    Object_Pointer);
-
-	procedure Get_Option (Interp: in out Interpreter_Record;
-	                      Option: in out Option_Record);
-
 
 	-- -----------------------------------------------------------------------------
 
@@ -361,12 +437,13 @@ private
 		Next:  Object_Pointer := Nil_Pointer;
 	end record;
 
-	type Interpreter_Pointer is access all Interpreter_Record;
 	--type Interpreter_Record is tagged limited record
 	type Interpreter_Record is limited record
-		Self: Interpreter_Pointer := null;
+		--Self: Interpreter_Pointer := null;
+		Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer
 		Storage_Pool: Storage_Pool_Pointer := null;
 		Trait: Option_Record(Trait_Option);
+		Stream: Option_Record(Stream_Option);
 
 		Heap: Heap_Pointer_Array := (others => null);
 		Current_Heap: Heap_Number := Heap_Number'First;
@@ -380,9 +457,9 @@ private
 
 		R: Register_Record;
 
-		Line: Object_String(1..1024);
+		-- TODO: Buffer_Record needs to be stacked to handle "load".
-		Line_Last: Standard.Natural;
+		Input: aliased IO_Record;
-		Line_Pos: Standard.Natural;
+		IO: IO_Pointer := null;
 	end record;
 
 end H2.Scheme;

lib/h2.ads

@@ -2,7 +2,7 @@ with System.Storage_Pools;
 
 package H2 is
 
-	subtype Character is Standard.Wide_Character;
+	--subtype Character is Standard.Wide_Character;
 
 	type Storage_Pool_Pointer is 
 		access all System.Storage_Pools.Root_Storage_Pool'Class;

lib/lib.gpr.in

@@ -22,7 +22,7 @@ project Lib is
 
 	package Compiler is
 		for Default_Switches ("Ada") use (
-			"-gnata", "-gnato", "-gnatN",  "-gnatwl"
+			"-gnata", "-gnato", "-gnatN",  "-gnatwl", "-gnat95"
 		);
 	end Compiler;