fixed a GC bug caused by a temporary object pointer pointing to the symbol table

lib/h2-scheme-execute.adb

@@ -188,13 +188,11 @@ procedure Execute (Interp: in out Interpreter_Record) is
 								end if;
 
 								declare
-									Closure: aliased Object_Pointer;
+									Closure: Object_Pointer;
 								begin
-Push_Top (Interp, Closure'Unchecked_Access); -- not necessary
 									Closure := Make_Closure (Interp.Self, Operand, Interp.Environment);
 									Pop_Frame (Interp);  -- Done
 									Chain_Frame_Result (Interp, Interp.Stack, Closure);
-Pop_Tops (Interp, 1); -- not necessary 
 								end;
 							end if;
 
@@ -389,7 +387,6 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
 
 			-- Push a new environmen for the closure
 			Interp.Environment := Make_Environment (Interp.Self, Get_Closure_Environment(Func));
--- TODO: GC. Func may be invalid if GC has been invoked.
 
 			Fbody := Get_Closure_Code(Func);
 			pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this.
@@ -430,7 +427,6 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
 				raise Syntax_Error;
 			end if;
 				
--- TODO: GC. the environment construction can cause GC. so Fbody here may be invalid.
 -- TODO: is it correct to keep the environement in the frame?
 			Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
 			Set_Frame_Operand (Interp.Stack, Fbody);
@@ -456,10 +452,6 @@ Print (Interp, Operand);
 
 		Args := Get_Cdr(Operand);
 
-		-- No GC must be performed here.
-		-- Otherwise, Operand, Func, Args get invalidated
-		-- since GC doesn't update local variables.
-
 		case Func.Tag is
 			when Procedure_Object => 
 				case Get_Procedure_Opcode(Func) is
@@ -700,7 +692,7 @@ Print (Interp, Operand);
 	end Fetch_Token;
 
 	procedure Read_List is
-		--pragma Inline (Read_List);
+		pragma Inline (Read_List);
 		V: aliased Object_Pointer;
 	begin
 		-- This procedure reads each token in a list.
@@ -710,7 +702,7 @@ Print (Interp, Operand);
 		
 		Fetch_Token;
 	
-		Push_Top (Interp, V'Unchecked_Access);
+		--Push_Top (Interp, V'Unchecked_Access);
 
 		case Interp.Token.Kind is
 			when End_Token =>
@@ -751,18 +743,15 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
 				Chain_Frame_Result (Interp, Interp.Stack, V);
 
 			when Identifier_Token =>	
-Print_Object_Pointer ("000 Identifier => Stack => ", Interp.Stack);
 				V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-Print_Object_Pointer ("111 Identifier => Stack => ", Interp.Stack);
 				Chain_Frame_Result (Interp, Interp.Stack, V);
-Print_Object_Pointer ("222 Identifier => Stack => ", Interp.Stack);
 
 			when others =>
 				-- TODO: set various error info
 				raise Syntax_Error;
 		end case;
 
-		Pop_Tops (Interp, 1);
+		--Pop_Tops (Interp, 1);
 	end Read_List;
 
 	procedure Read_List_Cdr is
@@ -776,7 +765,7 @@ Print_Object_Pointer ("222 Identifier => Stack => ", Interp.Stack);
 		-- to handle the head item specially.
 		Fetch_Token;
 	
-		Push_Top (Interp, V'Unchecked_Access);
+		--Push_Top (Interp, V'Unchecked_Access);
 
 		case Interp.Token.Kind is
 			when End_Token =>
@@ -801,13 +790,11 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
 		
 			when String_Token =>
 				V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-				-- TODO: make V gc-aware
 				Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
 				Chain_Frame_Result (Interp, Interp.Stack, V);
 
 			when Identifier_Token =>	
 				V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-				-- TODO: make V gc-aware
 				Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
 				Chain_Frame_Result (Interp, Interp.Stack, V);
 
@@ -816,7 +803,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
 				raise Syntax_Error;
 		end case;
 
-		Pop_Tops (Interp, 1);
+		--Pop_Tops (Interp, 1);
 	end Read_List_Cdr;
 
 	procedure Read_List_End is
@@ -825,42 +812,42 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
 	begin
 		Fetch_Token;
 
-		Push_Top (Interp, V'Unchecked_Access);
+		--Push_Top (Interp, V'Unchecked_Access);
 
 		case Interp.Token.Kind is
 			when Right_Parenthesis_Token =>
 				V := Get_Frame_Result(Interp.Stack);
 				pragma Assert (V /= Nil_Pointer);
 				-- The first item in the chain is actually Cdr of the last cell.
-				V := Reverse_Cons(Get_Cdr(V), Get_Car(V)); -- TODO: GC
+				V := Reverse_Cons(Get_Cdr(V), Get_Car(V)); 
 				Pop_Frame (Interp); 
 				Chain_Frame_Result (Interp, Interp.Stack, V);
 			when others =>
 				raise Syntax_Error;
 		end case;
 
-		Pop_Tops (Interp, 1);
+		--Pop_Tops (Interp, 1);
 	end Read_List_End;
 
 	procedure Close_List is
 		pragma Inline (Close_List);
 		V: aliased Object_Pointer;
 	begin
-		Push_Top (Interp, V'Unchecked_Access);
+		--Push_Top (Interp, V'Unchecked_Access);
 
 		V := Get_Frame_Result(Interp.Stack);
 		pragma Assert (Get_Cdr(V) = Nil_Pointer);
 		Pop_Frame (Interp); -- Done with the current frame
 		Chain_Frame_Result (Interp, Interp.Stack, Get_Car(V));
 
-		Pop_Tops (Interp, 1);
+		--Pop_Tops (Interp, 1);
 	end Close_List;
 
 	procedure Close_Quote is
 		pragma Inline (Close_Quote);
 		V: aliased Object_Pointer;
 	begin
-		Push_Top (Interp, V'Unchecked_Access);
+		--Push_Top (Interp, V'Unchecked_Access);
 
 -- TODO: use Interp.Quote_Syntax instead of Make_Symbol("quote")
 		Chain_Frame_Result (Interp, Interp.Stack, Make_Symbol(Interp.Self, Label_Quote));
@@ -868,7 +855,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
 		Pop_Frame (Interp); -- Done with the current frame
 		Chain_Frame_Result (Interp, Interp.Stack, V);
 
-		Pop_Tops (Interp, 1);
+		--Pop_Tops (Interp, 1);
 	end Close_Quote;
 
 	procedure Read_Object is
@@ -877,7 +864,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
 	begin
 		Fetch_Token;
 
-		Push_Top (Interp, V'Unchecked_Access);
+		--Push_Top (Interp, V'Unchecked_Access);
 
 		case Interp.Token.Kind is
 			when End_Token =>
@@ -900,13 +887,11 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
 
 			when String_Token =>
 				V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-				-- TODO: make V gc-aware
 				Pop_Frame (Interp); -- Done with the current frame
 				Chain_Frame_Result (Interp, Interp.Stack, V);
 
 			when Identifier_Token =>	
 				V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-				-- TODO: make V gc-aware
 				Pop_Frame (Interp); -- Done with the current frame
 				Chain_Frame_Result (Interp, Interp.Stack, V);
 
@@ -915,7 +900,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
 				raise Syntax_Error;
 		end case;
 
-		Pop_Tops (Interp, 1);
+		--Pop_Tops (Interp, 1);
 	end Read_Object;
 
 begin
@@ -986,27 +971,6 @@ begin
 	pragma Assert (Interp.Top.Last < Interp.Top.Data'First);
 
 	loop
-
---if Is_Normal_Pointer(Interp.Stack) then
---declare
---     X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
---	type XX is access all object_pointer;
---	t: xx := Interp.Stack'Unchecked_access;
---	w: object_word;
---	for w'address use t'address;
---
---	ww: object_word;
---	for ww'address use interp.stack'address;
---
---	www: object_word;
---	for www'address use interp.stack'address;
---begin
---    Ada.Text_IO.Put_Line ("$$$$$ [XXXXX] Stack in HEAP: " & Heap_Number'Image(X) & " FROM: " &object_word'image(w) & " VALUE: " & object_word'image(ww) & " VALUE2: " & object_word'image(www));
---	Print_Object_Pointer ("   ====> t", t.all);
---end;
---Print_Object_Pointer ("   ====> Stack", Interp.Stack);
---end if;
-
 		case Get_Frame_Opcode(Interp.Stack) is
 			when Opcode_Exit =>
 				exit;
@@ -1047,9 +1011,6 @@ begin
 		end case;
 	end loop;
 
-	-- the stack must be empty when the loop is terminated
-	--pragma Assert (Interp.Stack = Nil_Pointer);
-
 exception
 	when Stream_End_Error =>
 		raise;

lib/h2-scheme.adb

@@ -325,7 +325,10 @@ package body H2.Scheme is
 				Output_Character_Array (Source.Character_Slot);
 			end if;
 		else
-			Ada.Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W) & " kind: " & Object_Kind'Image(Source.Kind) & " size: " & Object_Size'Image(Source.Size));
+			Ada.Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W) & 
+			                            " kind: " & Object_Kind'Image(Source.Kind) &
+			                            " size: " & Object_Size'Image(Source.Size) &
+			                            " tag: " & Object_Tag'Image(Source.Tag));
 		end if;
 	end Print_Object_Pointer;
 
@@ -422,6 +425,17 @@ package body H2.Scheme is
 		return Object.New_Pointer;
 	end Get_New_Location;
 
+	function Verify_Pointer (Source: in Object_Pointer) return Object_Pointer is
+		pragma Inline (Verify_Pointer);
+	begin
+		if not Is_Normal_Pointer(Source) or else
+		   Source.Kind /= Moved_Object then
+			return Source;
+		else
+			return Get_New_Location(Source);
+		end if;
+	end Verify_Pointer;
+
 	function Allocate_Bytes_In_Heap (Heap:       access Heap_Record; 
 	                                 Heap_Bytes: in     Heap_Size) return Heap_Element_Pointer is
 		Avail: Heap_Size;
@@ -436,7 +450,6 @@ package body H2.Scheme is
 
 		Avail := Heap.Size - Heap.Bound;
 		if Real_Bytes > Avail then
-Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap_Size'Image(Real_Bytes));
 			return null;
 		end if;
 		
@@ -467,6 +480,11 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap
 			return 1;	
 		end if;
 
+		if Source = Nil_Pointer then
+ada.text_io.put_line ("HEAP SOURCE IS NIL");
+			return 0;
+		end if;
+
 		raise Internal_Error;
 	end Get_Heap_Number;
 
@@ -514,6 +532,7 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap
 
 		Last_Pos: Heap_Size;
 		New_Heap: Heap_Number;
+		Original_Symbol_Table: Object_Pointer;
 
 		--function To_Object_Pointer is new Ada.Unchecked_Conversion (Heap_Element_Pointer, Object_Pointer);
 
@@ -627,6 +646,8 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap
 		procedure Compact_Symbol_Table is
 			Pred: Object_Pointer;
 			Cons: Object_Pointer;
+			Car: Object_Pointer;
+			Cdr: Object_Pointer;
 		begin
 -- TODO: Change code here if the symbol table structure is changed to a hash table.
 
@@ -635,78 +656,66 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap
 			while Cons /= Nil_Pointer loop
 				pragma Assert (Cons.Tag = Cons_Object);	
 
-				declare
+				Car := Cons.Pointer_Slot(Cons_Car_Index);
-					Car: Object_Pointer renames Cons.Pointer_Slot(Cons_Car_Index);
+				Cdr := Cons.Pointer_Slot(Cons_Cdr_Index);
-					Cdr: Object_Pointer renames Cons.Pointer_Slot(Cons_Cdr_Index);
-				begin
 				pragma Assert (Car.Kind = Moved_Object or else Car.Tag = Symbol_Object);
 
 				if Car.Kind /= Moved_Object and then
 				   (Car.Flags and Syntax_Object) = 0 then
 					-- A non-syntax symbol has not been moved. 
 					-- Unlink the cons cell from the symbol table.
-
---Text_IO.Put_Line ("COMPACT_SYMBOL_TABLE Unlinking " & Character_Array_To_String (Car.Character_Slot));
 					if Pred = Nil_Pointer then
 						Interp.Symbol_Table := Cdr;
 					else
 						Pred.Pointer_Slot(Cons_Cdr_Index) := Cdr;
 					end if;
+				else
+					Pred := Cons;
 				end if;
 				
 				Cons := Cdr;	
-				end;
 			end loop;
 		end Compact_Symbol_Table;
 
 	begin
 
-declare
+--declare
-Avail: Heap_Size;
+--Avail: Heap_Size;
-begin
+--begin
-Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound;
+--Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound;
-Ada.Text_IO.Put_Line (">>> [GC BEGIN] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail));
+--Ada.Text_IO.Put_Line (">>> [GC BEGIN] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail));
-end;
+--end;
 
 		-- As the Heap_Number type is a modular type that can 
 		-- represent 0 and 1, incrementing it gives the next value.
 		New_Heap := Interp.Current_Heap + 1;
 
 		-- Migrate some root objects
-Print_Object_Pointer (">>> [GC] ROOT OBJECTS ...", Interp.Mark);
+--Print_Object_Pointer (">>> [GC] ROOT OBJECTS ...", Interp.Mark);
-Print_Object_Pointer (">>> [GC] Stack BEFORE ...", Interp.Stack);
+--Print_Object_Pointer (">>> [GC] Stack BEFORE ...", Interp.Stack);
 		if Is_Normal_Pointer(Interp.Stack) then
 			Interp.Stack := Move_One_Object(Interp.Stack);
-
-		Interp.Stack_XXX := Interp.Stack;
-declare
-	X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
-
-     type XX is access all object_pointer;
-     t: xx := Interp.Stack'Unchecked_access;
-     w: object_word;
-     for w'address use t'address;
-
-begin
-	Ada.Text_IO.Put_Line (">>> [GC MOVE] Stack in HEAP: " & Heap_Number'Image(X) & " FROM: " & Object_word'Image(w));
-end;
 		end if;
-Print_Object_Pointer (">>> [GC] Stack AFTER ...", Interp.Stack);
+
 		Interp.Root_Environment := Move_One_Object(Interp.Root_Environment);
 		Interp.Environment := Move_One_Object(Interp.Environment);
 		Interp.Mark := Move_One_Object(Interp.Mark);
 
 		-- Migrate temporary object pointers
-ADa.TEXT_IO.PUT_LINE (">>> [GC] TOP BEGIN: " & Interp.Top.Data'First'Img & ":" & Interp.Top.Last'Img);
 		for I in Interp.Top.Data'First .. Interp.Top.Last loop
-			if Interp.Top.Data(I).all /= null and then
+			if Interp.Top.Data(I).all = Interp.Symbol_Table then 
+				-- The symbol table must stay before compaction.
+				-- Skip migrating a temporary object pointer if it 
+				-- is pointing to the symbol table. Remember that
+				-- such skipping has happened.
+				Original_Symbol_Table := Interp.Symbol_Table;	
+			elsif Interp.Top.Data(I).all /= null and then
 			      Is_Normal_Pointer(Interp.Top.Data(I).all) then
 				Interp.Top.Data(I).all := Move_One_Object(Interp.Top.Data(I).all);
 			end if;
 		end loop;
-ADa.TEXT_IO.PUT_LINE (">>> [GC] TOP END");
 
-Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
+--Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
 		-- Scan the heap
 		Last_Pos := Scan_New_Heap(Interp.Heap(New_Heap).Space'First);
 
@@ -714,14 +723,24 @@ Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
 		-- If the symbol has not moved to the new heap, the symbol
 		-- is not referenced by any other objects than the symbol 
 		-- table itself 
-Ada.Text_IO.Put_Line (">>> [GC COMPACTING SYMBOL TABLE]");
+--Ada.Text_IO.Put_Line (">>> [GC COMPACTING SYMBOL TABLE]");
 		Compact_Symbol_Table;
 
-Print_Object_Pointer (">>> [GC MOVING SYMBOL TABLE]", Interp.Symbol_Table);
+--Print_Object_Pointer (">>> [GC MOVING SYMBOL TABLE]", Interp.Symbol_Table);
 		-- Migrate the symbol table itself
 		Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table);
 
-Ada.Text_IO.Put_Line (">>> [GC SCANNING HEAP AGAIN AFTER SYMBOL TABLE MIGRATION]");
+		-- Update temporary object pointers that were pointing to the symbol table
+		if Original_Symbol_Table /= null then
+			for I in Interp.Top.Data'First .. Interp.Top.Last loop
+				if Interp.Top.Data(I).all = Original_Symbol_Table then 
+					-- update to the new symbol table
+					Interp.Top.Data(I).all := Interp.Symbol_Table; 
+				end if;
+			end loop;
+		end if;
+
+--Ada.Text_IO.Put_Line (">>> [GC SCANNING HEAP AGAIN AFTER SYMBOL TABLE MIGRATION]");
 		-- Scan the new heap again from the end position of
 		-- the previous scan to move referenced objects by 
 		-- the symbol table. 
@@ -730,25 +749,14 @@ Ada.Text_IO.Put_Line (">>> [GC SCANNING HEAP AGAIN AFTER SYMBOL TABLE MIGRATION]
 		-- Swap the current heap and the new heap
 		Interp.Heap(Interp.Current_Heap).Bound := 0;
 		Interp.Current_Heap := New_Heap;
-declare
+--declare
-Avail: Heap_Size;
+--Avail: Heap_Size;
-begin
+--begin
-Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound;
+--Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound;
-Print_Object_Pointer (">>> [GC DONE] Stack ...", Interp.Stack);
+--Print_Object_Pointer (">>> [GC DONE] Stack ...", Interp.Stack);
-if Is_Normal_Pointer(Interp.Stack) then
+--Ada.Text_IO.Put_Line (">>> [GC DONE] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail));
-declare
+--Ada.Text_IO.Put_Line (">>> [GC DONE] ----------------------------------------------------------");
-	X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
+--end;
-     type XX is access all object_pointer;
-     t: xx := Interp.Stack'Unchecked_access;
-     w: object_word;
-     for w'address use t'address;
-begin
-	Ada.Text_IO.Put_Line (">>> [GC DONE] Stack in HEAP: " & Heap_Number'Image(X) & " FROM: " & Object_word'Image(w));
-end;
-end if;
-Ada.Text_IO.Put_Line (">>> [GC DONE] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail));
-Ada.Text_IO.Put_Line (">>> [GC DONE] ----------------------------------------------------------");
-end;
 	end Collect_Garbage;
 
 	function Allocate_Bytes (Interp: access Interpreter_Record;
@@ -881,28 +889,12 @@ end if;
 		return Result;
 	end Allocate_Byte_Object;
 
-	function Verify_Pointer (Source: in Object_Pointer) return Object_Pointer is
-		pragma Inline (Verify_Pointer);
-	begin
-		if not Is_Normal_Pointer(Source) or else
-		   Source.Kind /= Moved_Object then
-			return Source;
-		else
-			return Get_New_Location(Source);
-		end if;
-	end Verify_Pointer;
 	-----------------------------------------------------------------------------
 
 	procedure Push_Top (Interp: in out Interpreter_Record;
 	                    Source: access Object_Pointer) is
 		Top: Top_Record renames Interp.Top;
 	begin
---declare
---	W: Object_WOrd;
---	for W'address use Source'address;
---begin
---Ada.Text_IO.Put_Line ("Push_Top -  " & Object_WOrd'Image(W));
---end;
 		if Top.Last >= Top.Data'Last then
 			-- Something is wrong. Too many temporary object pointers
 			raise Internal_Error; -- TODO: change the exception to something else.
@@ -916,7 +908,6 @@ end if;
 	                    Count:  in     Object_Size) is
 		Top: Top_Record renames Interp.Top;
 	begin
---Ada.Text_IO.Put_Line ("Pop_Top");
 		if Top.Last < Count then
 			-- Something is wrong. Too few temporary object pointers
 			raise Internal_Error; -- TODO: change the exception to something else.
@@ -944,8 +935,8 @@ end if;
 		Push_Top (Interp.all, Aliased_Cdr'Unchecked_Access);
 
 		Cons := Allocate_Pointer_Object (Interp, Cons_Object_Size, Nil_Pointer);
-		Cons.Pointer_Slot(Cons_Car_Index) := Aliased_Car; -- TODO: is this really a good idea? resise this...
+		Cons.Pointer_Slot(Cons_Car_Index) := Aliased_Car;
-		Cons.Pointer_Slot(Cons_Cdr_Index) := Aliased_Cdr; --       If so, use Verify_pointer after Allocate_XXX
+		Cons.Pointer_Slot(Cons_Cdr_Index) := Aliased_Cdr;
 		Cons.Tag := Cons_Object;
 
 		Pop_Tops (Interp.all, 2);
@@ -989,7 +980,6 @@ end if;
 		Source.Pointer_Slot(Cons_Cdr_Index) := Value;
 	end Set_Cdr;
 
-
 	function Reverse_Cons (Source:   in Object_Pointer; 
 	                       Last_Cdr: in Object_Pointer := Nil_Pointer) return Object_Pointer is
 		pragma Assert (Is_Cons(Source));
@@ -1000,20 +990,15 @@ end if;
 		Next: Object_Pointer;
 		Prev: Object_Pointer;
 	begin
-		--Prev := Nil_Pointer;
 		Prev := Last_Cdr;
 		Ptr := Source;
 		loop
 			Next := Get_Cdr(Ptr);
 			Set_Cdr (Ptr, Prev);
 			Prev := Ptr;
-			if Is_Cons(Next) then
+			exit when not Is_Cons(Next);
 			Ptr := Next;
-			else
-				exit;
-			end if;
 		end loop;
-
 		return Ptr;
 	end Reverse_Cons;
 	-----------------------------------------------------------------------------
@@ -1052,25 +1037,22 @@ Ada.Text_IO.Put_Line ("Make_String...");
 				Car: Object_Pointer renames Ptr.Pointer_Slot(Cons_Car_Index);
 				Cdr: Object_Pointer renames Ptr.Pointer_Slot(Cons_Cdr_Index);
 			begin
---Text_IO.Put_Line (Car.Kind'Img & Car.Tag'Img & Object_Word'Image(Pointer_To_Word(Car)));
 				pragma Assert (Car.Tag = Symbol_Object);
 
-	 			--if Match_Character_Object(Car, Source) then
 				if Car.Character_Slot = Source then
+					-- the character string contents are the same.
 					return Car;
---Print_Object_Pointer ("Make_Symbol Result (Existing) - " & Source, Car);
 				end if;
 
 				Ptr := Cdr;	
 			end;
 		end loop;
 
---Text_IO.Put_Line ("Creating a symbol .. " & Source);
 		-- Create a symbol object
 		Ptr := Allocate_Character_Object(Interp, Source);
 		Ptr.Tag := Symbol_Object;
 
-		-- Make it safe from GC
+		-- Make Ptr safe from GC
 		Push_Top (Interp.all, Ptr'Unchecked_Access);
 
 		-- Link the symbol to the symbol table. 
@@ -1351,6 +1333,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
 	                              Value:  in     Object_Pointer) is
 		pragma Inline (Chain_Frame_Result);
 		pragma Assert (Is_Frame(Frame));
+		V: Object_Pointer;
 	begin
 		-- Add a new cons cell to the front
 
@@ -1359,8 +1342,13 @@ Ada.Text_IO.Put_Line ("Make_String...");
 		--	Make_Cons(Interp.Self, Value, Frame.Pointer_Slot(Frame_Result_Index));
 		--Pop_Tops (Interp, 1);
 
-		Interp.Stack.Pointer_Slot(Frame_Result_Index) :=  
+		-- This seems to cause a problem if Interp.Stack changes in Make_Cons().
-			Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index));
+		--Interp.Stack.Pointer_Slot(Frame_Result_Index) :=  
+		--	Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index));
+
+		-- So, let's separate the evaluation and the assignment.
+		V := Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index));
+		Interp.Stack.Pointer_Slot(Frame_Result_Index) := V;
 	end Chain_Frame_Result;
 
 	procedure Clear_Frame_Result (Frame: in Object_Pointer) is
@@ -1858,8 +1846,6 @@ Ada.Text_IO.Put_Line ("Make_String...");
 if DEBUG_GC then
 ADA.TEXT_IO.PUT_LINE ("XXXXXXXXXXXXXXXXXXXXXXXXX NO PROINTING XXXXXXXXXXXXXXXXXXXXXXXxxx");
 return;
-else
-ADA.TEXT_IO.PUT_LINE ("XXXXXXXXXXXXXXXXXXXXXXXXX TTTTTTTTTTTTTTTTTTTT XXXXXXXXXXXXXXXXXXXXXXXxxx");
 end if;
 		-- TODO: Let Make_Frame use a dedicated stack space that's apart from the heap.
 		--       This way, the stack frame doesn't have to be managed by GC.
@@ -1941,25 +1927,9 @@ end if;
 	procedure Push_Frame (Interp:  in out Interpreter_Record;
 	                      Opcode:  in     Opcode_Type; 
 	                      Operand: in     Object_Pointer) is
-		--pragma Inline (Push_Frame);
+		pragma Inline (Push_Frame);
 	begin
-if IS_NORMAL_POINTER(Interp.Stack) then
-declare
-	X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
-begin
-	Ada.Text_IO.Put_Line ("$$$$ [PUSH FRAME BEFORE] Stack in HEAP: " & Heap_Number'Image(X));
-	Print_Object_Pointer ("$$$$ -> Stack ", Interp.Stack);
-end;
-else
-	Ada.Text_IO.Put_Line ("$$$$ [PUSH FRAME BEFORE] Stack NULL");
-end if;
 		Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Operand, Interp.Environment);
-declare
-	X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
-begin
-	Ada.Text_IO.Put_Line ("$$$$ [PUSH FRAME AFTER] Stack in HEAP: " & Heap_Number'Image(X));
-	Print_Object_Pointer ("$$$$ -> Stack ", Interp.Stack);
-end;
 	end Push_Frame;
 
 	--procedure Pop_Frame (Interp.Stack: out Object_Pointer;
@@ -1974,16 +1944,11 @@ end;
 	--end Pop_Frame;
 
 	procedure Pop_Frame (Interp: in out Interpreter_Record) is
-		--pragma Inline (Pop_Frame);
+		pragma Inline (Pop_Frame);
 	begin
 		pragma Assert (Interp.Stack /= Nil_Pointer);
 		Interp.Environment := Interp.Stack.Pointer_Slot(Frame_Environment_Index); -- restore environment
 		Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop 
-declare
-	X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
-begin
-	Ada.Text_IO.Put_Line ("$$$$ [POP FRAME] Stack in HEAP: " & Heap_Number'Image(X));
-end;
 	end Pop_Frame;
 
 	procedure Execute (Interp: in out Interpreter_Record) is separate;
@@ -2026,14 +1991,13 @@ Print_Object_Pointer ("STACK IN EVALUTE => ", Interp.Stack);
 	begin
 		pragma Assert (Interp.Base_Input.Stream /= null);
 
-DEBUG_GC := Standard.True;
+--DEBUG_GC := Standard.True;
 		Clear_Tops (Interp);
 		Result := Nil_Pointer;
 
 		loop
 			pragma Assert (Interp.Stack = Nil_Pointer);
 			Interp.Stack := Nil_Pointer;
-Print_Object_Pointer ("STACK IN Run_Loop => ", Interp.Stack);
 
 			Push_Frame (Interp, Opcode_Exit, Nil_Pointer);
 			--Push_Frame (Interp, Opcode_Print_Result, Nil_Pointer);

lib/h2-scheme.ads

@@ -490,8 +490,6 @@ private
 
 		Token: Token_Record;
 		LC_Unfetched: Standard.Boolean := Standard.False;
-
-		STACK_XXX: aliased Object_Pointer := Nil_Pointer;
 	end record;
 
 	package Token is