added Buffer_Record, Token_Record and related procedures

cmd/scheme.adb

@@ -21,7 +21,7 @@ procedure scheme is
 	
 
 	--File_Name: aliased S.Object_String := "test.adb";
-	File_Name: aliased constant S.Object_String := "test.adb";
+	File_Name: aliased constant S.Object_String := "test.scm";
 	--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;

lib/h2-scheme.adb

@@ -302,10 +302,6 @@ package body H2.Scheme is
 		end;
 	end Character_Array_To_String;
 
-	type Thin_String is new Object_String (Standard.Positive'Range);
-	type Thin_String_Pointer is access all Thin_String;
-	for Thin_String_Pointer'Size use Object_Pointer_Bits;
-
 -- TODO: move away these utilities routines
 	--function To_Thin_String_Pointer (Source: in Object_Pointer) return Thin_String_Pointer is
 	--	type Character_Pointer is access all Object_Character;
@@ -365,6 +361,114 @@ package body H2.Scheme is
 		end if;
 	end Print_Object_Pointer;
 
+	-----------------------------------------------------------------------------
+	-- BUFFER MANAGEMENT
+	-----------------------------------------------------------------------------
+	procedure Clear_Buffer (Buffer: in out Buffer_Record) is
+		pragma Inline (Clear_Buffer);
+	begin
+		Buffer.Last := 0;	
+	end Clear_Buffer;
+
+	procedure Purge_Buffer (Interp: in out Interpreter_Record;
+	                        Buffer: in out Buffer_Record) is
+	begin
+		if Buffer.Len > 0 then
+			declare
+				subtype New_String is Object_String (1 .. Buffer.Len);
+				type New_String_Pointer is access all New_String;
+				for New_String_Pointer'Size use Object_Pointer_Bits;
+
+				package Pool is new H2.Pool (New_String, New_String_Pointer, Interp.Storage_Pool);
+
+				Tmp: New_String_Pointer;
+				for Tmp'Address use Buffer.Ptr'Address;
+				pragma Import (Ada, Tmp);
+			begin
+				Pool.Deallocate (Tmp);
+			end;
+
+			Buffer := (null, 0, 0);
+		end if;
+	end Purge_Buffer;
+
+	procedure Append_Buffer (Interp: in out Interpreter_Record;
+	                         Buffer: in out Buffer_Record; 
+	                         Source: in Object_String) is
+		Incr: Standard.Natural;
+	begin
+		if Buffer.Last >= Buffer.Len then
+			if Buffer.Len <= 0 then
+				Incr := 1; -- TODO: increase to 128
+			else
+				Incr := Buffer.Len;	
+			end if;
+			if Incr < Source'Length then	
+				Incr := Source'Length;
+			end if;
+			
+			declare
+				subtype New_String is Object_String (1 .. Buffer.Len + Incr);
+				type New_String_Pointer is access all New_String;
+				for New_String_Pointer'Size use Object_Pointer_Bits;
+
+				package Pool is new H2.Pool (New_String, New_String_Pointer, Interp.Storage_Pool);
+
+				T1: New_String_Pointer;
+				T2: New_String_Pointer;
+				for T2'Address use Buffer.Ptr'Address;
+				pragma Import (Ada, T2);
+			begin
+				T1 := Pool.Allocate;
+				if Buffer.Last > 0 then
+					T1(1 .. Buffer.Last) := Buffer.Ptr(1 .. Buffer.Last);
+				end if;
+				Pool.Deallocate (T2);
+				T2 := T1;
+			end;
+
+			Buffer.Len := Buffer.Len + Incr;
+		end if;
+
+		Buffer.Ptr(Buffer.Last + 1 .. Buffer.Last + Source'Length) := Source;
+		Buffer.Last := Buffer.Last + Source'Length;
+	end Append_Buffer;
+	
+	procedure Purge_Token (Interp: in out Interpreter_Record) is
+	begin
+		Purge_Buffer (Interp, Interp.Token.Value);
+		Interp.Token := (End_Token, (null, 0, 0));
+	end Purge_Token;
+
+	procedure Set_Token (Interp: in out Interpreter_Record;
+	                     Kind:   in     Token_Kind;
+	                     Value:  in     Object_String) is
+	begin
+		Interp.Token.Kind := Kind;	
+		Clear_Buffer (Interp.Token.Value);
+		if Value'Length > 0 then
+			Append_Buffer (Interp, Interp.Token.Value, Value);
+		end if;
+	end Set_Token;
+
+	procedure Append_Token_String (Interp: in out Interpreter_Record;
+	                               Value:  in     Object_String) is
+		pragma Inline (Append_Token_String);
+	begin
+		if Value'Length > 0 then
+			Append_Buffer (Interp, Interp.Token.Value, Value);	
+		end if;
+	end Append_Token_String;
+
+	procedure Append_Token_Character (Interp: in out Interpreter_Record;
+	                                  Value:  in     Object_Character) is
+		pragma Inline (Append_Token_Character);
+		Tmp: Object_String(1..1) := (1 => Value);
+	begin
+		Append_Buffer (Interp, Interp.Token.Value, Tmp);
+	end Append_Token_Character;
+
+	
 	-----------------------------------------------------------------------------
 	-- MEMORY MANAGEMENT
 	-----------------------------------------------------------------------------
@@ -1467,6 +1571,7 @@ Put_String (To_Thin_String_Pointer (Result));
 
 		Interp.Base_Input.Stream := null;
 		Interp.Input := Interp.Base_Input'Unchecked_Access;
+		Interp.Token := (End_Token, (null, 0, 0));
 
 -- TODO: disallow garbage collecion during initialization.
 Text_IO.Put_Line ("1111111111");
@@ -1498,6 +1603,7 @@ Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Eleme
 		end if;
 
 		Deinitialize_Heap (Interp);
+		Purge_Token (Interp);
 	end Close;
 
 	function Get_Storage_Pool (Interp: in Interpreter_Record) return Storage_Pool_Pointer is
@@ -1594,34 +1700,41 @@ Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Eleme
 			Interp.Input.Iochar := (Normal_Character, Interp.Input.Data(Interp.Input.Pos));
 		end Fetch_Character;
 
+		function Is_White_Space (X: in Object_Character) return Standard.Boolean is
+		begin
+			return X = ' ' or else
+			       X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.HT)) or else
+			       X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.VT)) or else
+			       X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.CR)) or else
+			       X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF)) or else
+			       X = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.FF));
+		end Is_White_Space;
+
 		procedure Skip_Spaces is
 			C: IO_Character_Record renames Interp.Input.Iochar;
 		begin
 			loop
 				exit when C.Kind /= Normal_Character;
 
-				-- normal character
+				-- Normal character
-				case C.Value is
+				if Is_White_Space(C.Value) then
-					when ' ' | 
+					Fetch_Character;
-					     Object_Character'Val(Standard.Character'Pos(Standard.ASCII.HT))  |
+				elsif C.Value = ';' then
-					     Object_Character'Val(Standard.Character'Pos(Standard.ASCII.VT))  |
+					-- Comment.
-					     Object_Character'Val(Standard.Character'Pos(Standard.ASCII.CR))  |
+					loop
-					     Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF))  |
-					     Object_Character'Val(Standard.Character'Pos(Standard.ASCII.FF))  =>
-						-- white space
 						Fetch_Character;
 
-					when ';' =>
+						exit when C.Kind = End_Character; -- EOF before LF
-						-- comment. consume until EOL
-						loop
-							Fetch_Character;
-					     	exit when C.Kind = Normal_Character and then 
-							          C.Value = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF));
-						end loop;
 
-					when others =>
+						if C.Kind = Normal_Character and then 
-						exit;
+						   C.Value = Object_Character'Val(Standard.Character'Pos(Standard.ASCII.LF)) then
-				end case;
+							Fetch_Character; -- Consume LF
+							exit;
+						end if;
+					end loop;
+				else
+					exit;
+				end if;
 			end loop;
 		end Skip_Spaces;
 
@@ -1630,24 +1743,48 @@ Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Eleme
 		begin
 			Skip_Spaces;
 			if C.Kind /= Normal_Character then
-				Interp.Token.Kind := End_Token;
+				Set_Token (Interp, End_Token, "");
 				return;
 			end if;
 
 			case C.Value is
 				when '(' =>
-					Interp.Token := (Left_Parenthesis_Token, "(");
+					Set_Token (Interp, Left_Parenthesis_Token, "(");
+					Fetch_Character;
 
 				when ')' =>
-					Interp.Token := (Left_Parenthesis_Token, ")");
+					Set_Token (Interp, Right_Parenthesis_Token, ")");
+					Fetch_Character;
 
 				when ''' =>
-					Interp.Token := (Single_Quote_Token, ")");
+					Set_Token (Interp, Single_Quote_Token, "'");
+					Fetch_Character;
+
+				when '"' =>
+					Set_Token (Interp, String_Token, "'");
+					Fetch_Character;
+					-- TODO:
+
+				when '#' =>
+					Fetch_Character;
+					-- TODO: t, false, etc
 
 				when others =>	
-					null;	
+					Set_Token (Interp, Identifier_Token, "");
+					loop
+						Append_Token_Character (Interp, C.Value);
+						Fetch_Character;
+						--exit when not Is_Ident_Char(C.Value);
+						if C.Value = '(' or else C.Value = ')' or else
+						   C.Value = ''' or else C.Value = '"' or else
+						   C.Value = '#' or else C.Value = ';' or else
+						   Is_White_Space(C.Value) then
+							exit;
+						end if;
+					end loop;
 			end case;
 			
+Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>> Token: " & Interp.Token.Value.Ptr(1..Interp.Token.Value.Last));
 		end Fetch_Token;
 
 		procedure Read_Atom (Atom: out Object_Pointer) is
@@ -1659,38 +1796,16 @@ Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Eleme
 		Opcode: Object_Integer;
 		Operand: Object_Pointer;
 
-		C: IO_Character_Record renames Interp.Input.Iochar;
 	begin
-		--Opcode := 1;
+		Fetch_Character;
-		--loop
-		--	case Opcode is
-		--		when 1 =>
-		--end loop;
 		loop
-			begin
+			Fetch_Token;
-				Fetch_Character;
+			exit when Interp.Token.Kind = End_Token;
-			exception
-				when others =>
-					TEXT_IO.New_Line;
-					Text_IO.Put_Line ("INPUT ERROR...");
-					exit;
-			end;
-
-			case C.Kind is
-				when Normal_Character =>
-					Text_IO.Put (C.Value);
-
-				when End_Character =>
-					TEXT_IO.New_Line;
-					Text_IO.Put_Line ("END OF INPUT...");
-					exit;
-
-				when Error_Character =>
-					TEXT_IO.New_Line;
-					Text_IO.Put_Line ("INPUT ERROR...");
-					exit;
-			end case;
 		end loop;
+
+	exception
+		when IO_Error =>
+			Text_IO.Put_Line ("****************************** INPUT ERROR...");
 	end Read;
 	          
 	procedure Print (Interp: in out Interpreter_Record; 

lib/h2-scheme.ads

@@ -430,23 +430,27 @@ private
 	type Heap_Number is mod 2 ** 1;
 	type Heap_Pointer_Array is Array (Heap_Number'First .. Heap_Number'Last) of Heap_Pointer;
 
-	type Register_Record is limited record
+	subtype Thin_String is Object_String (Standard.Positive'Range);
-		Code:  Object_Pointer := Nil_Pointer;
+	type Thin_String_Pointer is access all Thin_String;
-		Envir: Object_Pointer := Nil_Pointer;
+	for Thin_String_Pointer'Size use Object_Pointer_Bits;
-		Args:  Object_Pointer := Nil_Pointer;
+
-		Next:  Object_Pointer := Nil_Pointer;
+	type Buffer_Record is record
+		Ptr: Thin_String_Pointer := null;
+		Len: Standard.Natural := 0;
+		Last: Standard.Natural := 0;
 	end record;
 
 	type Token_Kind is (End_Token,
 	                    Identifier_Token,
 	                    Left_Parenthesis_Token,
 	                    Right_Parenthesis_Token,
-	                    Single_Quote_Token
+	                    Single_Quote_Token,
+	                    String_Token
 	);
 
 	type Token_Record is record
 		Kind: Token_Kind;
-		Value: Object_String;
+		Value: Buffer_Record;
 	end record;
 
 	--type Interpreter_Record is tagged limited record
@@ -467,8 +471,6 @@ private
 		Stack: Object_Pointer := Nil_Pointer;
 		Mark: Object_Pointer := Nil_Pointer;
 
-		R: Register_Record;
-
 		Base_Input: aliased IO_Record;
 		Input: IO_Pointer := null;