added more code for evaluation

lib/h2-scheme.adb

@@ -8,6 +8,7 @@ package body H2.Scheme is
 	----------------------------------------------------------------------------------
 	Allocation_Error: exception;
 	Size_Error: exception;
+	Evaluation_Error: exception;
 	Internal_Error: exception;
 
 	----------------------------------------------------------------------------------
@@ -20,13 +21,12 @@ package body H2.Scheme is
 	type Thin_Memory_Element_Array_Pointer is access all Thin_Memory_Element_Array;
 	for Thin_Memory_Element_Array_Pointer'Size use Object_Pointer_Bits;
 
-	subtype Opcode_Type is Object_Integer range 0 .. 5;
+	subtype Opcode_Type is Object_Integer range 0 .. 4;
 	Opcode_Exit:               constant Opcode_Type := Opcode_Type'(0);
 	Opcode_Evaluate_Object:    constant Opcode_Type := Opcode_Type'(1);
-	Opcode_Evaluate_Argument:  constant Opcode_Type := Opcode_Type'(2);
+	Opcode_Evaluate_Syntax:    constant Opcode_Type := Opcode_Type'(2);
-	Opcode_Evaluate_Syntax:    constant Opcode_Type := Opcode_Type'(3);
+	Opcode_Evaluate_Procedure: constant Opcode_Type := Opcode_Type'(3);
-	Opcode_Evaluate_Procedure: constant Opcode_Type := Opcode_Type'(4);
+	Opcode_Apply:              constant Opcode_Type := Opcode_Type'(4);
-	Opcode_Apply:              constant Opcode_Type := Opcode_Type'(5);
 
 	----------------------------------------------------------------------------------
 	-- COMMON OBJECTS
@@ -42,6 +42,9 @@ package body H2.Scheme is
 	Frame_Environment_Index: constant Pointer_Object_Size := 4;
 	Frame_Return_Index: constant Pointer_Object_Size := 5;
 
+	Mark_Object_Size: constant Pointer_Object_Size := 1;
+	Mark_Context_Index: constant Pointer_Object_Size := 1;
+
 	Procedure_Object_Size: constant Pointer_Object_Size := 1;
 	Procedure_Opcode_Index: constant Pointer_Object_Size := 1;
 
@@ -616,6 +619,7 @@ Text_IO.Put_Line ("COMPACT_SYMBOL_TABLE Unlinking " & To_String (Car.Character_S
 		-- Migrate objects in the root table
 Print_Object_Pointer ("Root_Table ...", Interp.Root_Table);
 		Interp.Root_Table := Move_One_Object (Interp.Root_Table);
+		Interp.Mark := Move_One_Object (Interp.Mark);
 
 		-- Scane the heap
 		Last_Pos := Scan_New_Heap (Interp.Heap(New_Heap).Space'First);
@@ -765,47 +769,6 @@ Text_IO.Put_Line (">>> [GC DONE]");
 
 	----------------------------------------------------------------------------------
 
-	function Is_Cons (Source: in Object_Pointer) return Standard.Boolean is
-		pragma Inline (Is_Cons);
-	begin
-		return Is_Normal_Pointer (Source) and then 
-		       Source.Tag = Cons_Object;
-	end Is_Cons;
-
-	function Get_Car (Source: in Object_Pointer) return Object_Pointer is
-		pragma Inline (Get_Car);
-	begin
-		pragma Assert (Is_Cons (Source));
-		pragma Assert (Source.Size = Cons_Object_Size);
-		return Source.Pointer_Slot(Cons_Car_Index);
-	end Get_Car;
-
-	procedure Set_Car (Source: in out Object_Pointer;
-	                   Value:  in     Object_Pointer) is
-		pragma Inline (Set_Car);
-	begin
-		pragma Assert (Is_Cons (Source));
-		pragma Assert (Source.Size = Cons_Object_Size);
-		Source.Pointer_Slot(Cons_Car_Index) := Value;
-	end Set_Car;
-
-	function Get_Cdr (Source: in Object_Pointer) return Object_Pointer is
-		pragma Inline (Get_Cdr);
-	begin
-		pragma Assert (Is_Cons (Source));
-		pragma Assert (Source.Size = Cons_Object_Size);
-		return Source.Pointer_Slot(Cons_Cdr_Index);
-	end Get_Cdr;
-
-	procedure Set_Cdr (Source: in out Object_Pointer;
-	                   Value:  in     Object_Pointer) is
-		pragma Inline (Set_Cdr);
-	begin
-		pragma Assert (Is_Cons (Source));
-		pragma Assert (Source.Size = Cons_Object_Size);
-		Source.Pointer_Slot(Cons_Cdr_Index) := Value;
-	end Set_Cdr;
-
 	procedure Make_Cons (Interp: in out Interpreter_Record;
 	                     Car:    in     Object_Pointer;
 	                     Cdr:    in     Object_Pointer;
@@ -815,7 +778,7 @@ Text_IO.Put_Line (">>> [GC DONE]");
 		Result.Pointer_Slot(Cons_Car_Index) := Car;
 		Result.Pointer_Slot(Cons_Cdr_Index) := Cdr;
 		Result.Tag := Cons_Object;
-Print_Object_Pointer ("Make_Cons Result - ", Result);
+--Print_Object_Pointer ("Make_Cons Result - ", Result);
 	end Make_Cons;
 
 	function Make_Cons (Interp: access Interpreter_Record;
@@ -827,6 +790,73 @@ Print_Object_Pointer ("Make_Cons Result - ", Result);
 		return Result;
 	end Make_Cons;
 
+	function Is_Cons (Source: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Cons);
+	begin
+		return Is_Normal_Pointer(Source) and then 
+		       Source.Tag = Cons_Object;
+	end Is_Cons;
+
+	function Get_Car (Source: in Object_Pointer) return Object_Pointer is
+		pragma Inline (Get_Car);
+		pragma Assert (Is_Cons(Source));
+		pragma Assert (Source.Size = Cons_Object_Size);
+	begin
+		return Source.Pointer_Slot(Cons_Car_Index);
+	end Get_Car;
+
+	procedure Set_Car (Source: in out Object_Pointer;
+	                   Value:  in     Object_Pointer) is
+		pragma Inline (Set_Car);
+		pragma Assert (Is_Cons(Source));
+		pragma Assert (Source.Size = Cons_Object_Size);
+	begin
+		Source.Pointer_Slot(Cons_Car_Index) := Value;
+	end Set_Car;
+
+	function Get_Cdr (Source: in Object_Pointer) return Object_Pointer is
+		pragma Inline (Get_Cdr);
+		pragma Assert (Is_Cons(Source));
+		pragma Assert (Source.Size = Cons_Object_Size);
+	begin
+		return Source.Pointer_Slot(Cons_Cdr_Index);
+	end Get_Cdr;
+
+	procedure Set_Cdr (Source: in out Object_Pointer;
+	                   Value:  in     Object_Pointer) is
+		pragma Inline (Set_Cdr);
+		pragma Assert (Is_Cons(Source));
+		pragma Assert (Source.Size = Cons_Object_Size);
+	begin
+		Source.Pointer_Slot(Cons_Cdr_Index) := Value;
+	end Set_Cdr;
+
+
+	function Reverse_Cons (Source: in Object_Pointer) return Object_Pointer is
+		pragma Assert (Is_Cons(Source));
+		pragma Assert (Source.Size = Cons_Object_Size);
+
+		-- Note: The non-nil cdr in the last cons cell gets lost.
+		--       e.g.) Reversing (1 2 3 . 4) results in (3 2 1)
+		Ptr: Object_Pointer;
+		Next: Object_Pointer;
+		Prev: Object_Pointer;
+	begin
+		Prev := Nil_Pointer;
+		Ptr := Source;
+		loop
+			Next := Get_Cdr(Ptr);
+			Set_Cdr (Ptr, Prev);
+			Prev := Ptr;
+			if Is_Cons(Next) then
+				Ptr := Next;
+			else
+				exit;
+			end if;
+		end loop;
+
+		return Ptr;
+	end Reverse_Cons;
 	----------------------------------------------------------------------------------
 
 	procedure Make_String (Interp: in out Interpreter_Record;
@@ -965,10 +995,6 @@ Print_Object_Pointer ("Get_Environment Key => ", Key);
 
 	----------------------------------------------------------------------------------
 
-	function Is_Syntax (Source: in Object_Pointer) return Standard.Boolean is
-	begin
-		return Is_Symbol(Source) and then (Source.Flags and Syntax_Object) /= 0;
-	end Is_Syntax;
 
 	procedure Make_Syntax (Interp: in out Interpreter_Record;
 	                       Opcode: in     Syntax_Code;
@@ -982,6 +1008,12 @@ Text_IO.Put ("Creating Syntax Symbol ");
 Put_String (To_Thin_String_Pointer (Result));
 	end Make_Syntax;
 
+	function Is_Syntax (Source: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Syntax);
+	begin
+		return Is_Symbol(Source) and then (Source.Flags and Syntax_Object) /= 0;
+	end Is_Syntax;
+
 	procedure Make_Procedure (Interp: in out Interpreter_Record;
 	                          Opcode: in     Procedure_Code;
 	                          Name:   in     Object_String;
@@ -1007,15 +1039,23 @@ Put_String (To_Thin_String_Pointer (Result));
 		Result := Proc;
 	end Make_Procedure;
 
+	function Is_Procedure (Source: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Procedure);
+	begin
+		return Is_Normal_Pointer(Source) and then 
+		       Source.Tag = Procedure_Object;
+	end Is_Procedure;
+
+	function Get_Procedure_Opcode (Proc: in Object_Pointer) return Procedure_Code is
+		pragma Inline (Get_Procedure_Opcode);
+		pragma Assert (Is_Procedure(Proc));
+		pragma Assert (Proc.Size = Procedure_Object_Size);
+	begin
+		return Pointer_To_Integer(Proc.Pointer_Slot(Procedure_Opcode_Index));
+	end Get_Procedure_Opcode;
 	
 	----------------------------------------------------------------------------------
 
-	function Is_Frame (Source: in Object_Pointer) return Standard.Boolean is
-		pragma Inline (Is_Frame);
-	begin
-		return Is_Normal_Pointer (Source) and then 
-		       Source.Tag = Frame_Object;
-	end Is_Frame;
 
 	procedure Make_Frame (Interp:  in out Interpreter_Record;
 	                      Stack:   in     Object_Pointer; -- current stack pointer
@@ -1024,6 +1064,8 @@ Put_String (To_Thin_String_Pointer (Result));
 	                      Envir:   in     Object_Pointer;
 	                      Result:  out    Object_Pointer) is
 	begin
+-- TODO: create a Frame in a special memory rather than in Heap Memory.
+--       Since it's used for stack, it can be made special.
 		Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer, Result);
 		Result.Tag := Frame_Object;
 		Result.Pointer_Slot(Frame_Stack_Index) := Stack;
@@ -1044,60 +1086,105 @@ Put_String (To_Thin_String_Pointer (Result));
 		return Frame;
 	end Make_Frame;
 
+	function Is_Frame (Source: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Frame);
+	begin
+		return Is_Normal_Pointer(Source) and then 
+		       Source.Tag = Frame_Object;
+	end Is_Frame;
+
 	function Get_Frame_Return (Frame: in Object_Pointer) return Object_Pointer is
 		pragma Inline (Get_Frame_Return);
-	begin
 		pragma Assert (Is_Frame(Frame));
+	begin
 		return Frame.Pointer_Slot(Frame_Return_Index);
 	end Get_Frame_Return;
 
 	procedure Set_Frame_Return (Frame: in out Object_Pointer;
 	                            Value: in     Object_Pointer) is
 		pragma Inline (Set_Frame_Return);
-	begin
 		pragma Assert (Is_Frame(Frame));
+	begin
 		Frame.Pointer_Slot(Frame_Return_Index) := Value;
 	end Set_Frame_Return;
 
+	procedure Chain_Frame_Return (Interp: in out Interpreter_Record;
+	                              Frame:  in out Object_Pointer;
+	                              Value:  in     Object_Pointer) is
+		pragma Inline (Chain_Frame_Return);
+		pragma Assert (Is_Frame(Frame));
+
+		Cons: Object_Pointer renames Frame.Pointer_Slot(Frame_Return_Index);
+	begin
+-- TODO: make it GC-aware
+
+		-- Add a new cons cell to the front
+		Cons :=  Make_Cons (Interp.Self, Value, Cons);
+	end Chain_Frame_Return;
+
+	procedure Clear_Frame_Return (Frame: in out Object_Pointer) is
+	begin
+		Frame.Pointer_Slot(Frame_Return_Index) := Nil_Pointer;
+	end Clear_Frame_Return;
+
 	function Get_Frame_Environment (Frame: in Object_Pointer) return Object_Pointer is
 		pragma Inline (Get_Frame_Environment);
-	begin
 		pragma Assert (Is_Frame(Frame));
+	begin
 		return Frame.Pointer_Slot(Frame_Environment_Index);
 	end Get_Frame_Environment;
 
 	function Get_Frame_Opcode (Frame: in Object_Pointer) return Opcode_Type is
 		pragma Inline (Get_Frame_Opcode);
-	begin
 		pragma Assert (Is_Frame(Frame));
+	begin
 		return Pointer_To_Integer(Frame.Pointer_Slot(Frame_Opcode_Index));
 	end Get_Frame_Opcode;
 
 	procedure Set_Frame_Opcode (Frame:  in Object_Pointer; 
 	                            OpcodE: in Opcode_Type) is
 		pragma Inline (Set_Frame_Opcode);
-	begin
 		pragma Assert (Is_Frame(Frame));
+	begin
 		Frame.Pointer_Slot(Frame_Opcode_Index) := Integer_To_Pointer(Opcode);
 	end Set_Frame_Opcode;
 
 	function Get_Frame_Operand (Frame: in Object_Pointer) return Object_Pointer is
 		pragma Inline (Get_Frame_Operand);
-	begin
 		pragma Assert (Is_Frame(Frame));
+	begin
 		return Frame.Pointer_Slot(Frame_Operand_Index);
 	end Get_Frame_Operand;
 
 	procedure Set_Frame_Operand (Frame: in out Object_Pointer;
-	                            Value: in     Object_Pointer) is
+	                             Value: in     Object_Pointer) is
 		pragma Inline (Set_Frame_Operand);
-	begin
 		pragma Assert (Is_Frame(Frame));
+	begin
 		Frame.Pointer_Slot(Frame_Operand_Index) := Value;
 	end Set_Frame_Operand;
 
 	----------------------------------------------------------------------------------
 
+	procedure Make_Mark (Interp:  in out Interpreter_Record;
+	                     Context: in     Object_Integer;
+	                     Result:  out    Object_Pointer) is
+	begin
+		Allocate_Pointer_Object (Interp, Mark_Object_Size, Nil_Pointer, Result);
+		Result.Pointer_Slot(Mark_Context_Index) := Integer_To_Pointer(Context);
+		Result.Tag := Mark_Object;
+	end Make_Mark;
+
+	function Make_Mark (Interp:  access Interpreter_Record;
+	                    Context: in     Object_Integer) return Object_Pointer is
+		Mark: Object_Pointer;
+	begin
+		Make_Mark (Interp.all, Context, Mark);
+		return Mark;
+	end Make_Mark;
+
+	----------------------------------------------------------------------------------
+
 	procedure Make_Closure (Interp:  in out Interpreter_Record;
 	                        Code:    in     Object_Pointer;
 	                        Envir:   in     Object_Pointer;
@@ -1118,6 +1205,27 @@ Put_String (To_Thin_String_Pointer (Result));
 		return Closure;
 	end Make_Closure;
 	
+	function Is_Closure (Source: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Closure);
+	begin
+		return Is_Normal_Pointer(Source) and then 
+		       Source.Tag = Closure_Object;
+	end Is_Closure;
+
+	function Get_Closure_Code (Closure: in Object_Pointer) return Object_Pointer is
+		pragma Inline (Get_Closure_Code);
+		pragma Assert (Is_Closure(Closure));
+	begin
+		return Closure.Pointer_Slot(Closure_Code_Index);
+	end Get_Closure_Code;
+
+	function Get_Closure_Environment (Closure: in Object_Pointer) return Object_Pointer is
+		pragma Inline (Get_Closure_Environment);
+		pragma Assert (Is_Closure(Closure));
+	begin
+		return Closure.Pointer_Slot(Closure_Environment_Index);
+	end Get_Closure_Environment;
+
 	----------------------------------------------------------------------------------
 	procedure Deinitialize_Heap (Interp: in out Interpreter_Record) is
 	begin
@@ -1230,8 +1338,11 @@ Put_String (To_Thin_String_Pointer (Result));
 
 -- TODO: disallow garbage collecion during initialization.
 		Initialize_Heap (Initial_Heap_Size);
+		Interp.Mark := Make_Mark (Interp.Self, 0); -- to indicate the end of cons evluation
 		Make_Syntax_Objects;
 		Make_Procedure_Objects;
+
+
 	exception
 		when others =>
 			Deinitialize_Heap (Interp);
@@ -1537,6 +1648,8 @@ Make_Symbol (Interp, "lambda", Interp.Root_Table);
 	end Evaluatex;
 
 procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Object_Pointer) is
+	Y: Object_Pointer;
+	Z: Object_Pointer;
 begin
 		--(define x 10)
 		--Result := Make_Cons (
@@ -1554,17 +1667,47 @@ begin
 		--	)
 		--);
 
-		-- (+ 1 2 . 2)
+		Z := Make_Cons (
+			Interp.Self,
+			Make_Symbol (Interp.Self, "+"),
+			Make_Cons (
+				Interp.Self,
+				Integer_To_Pointer (3),
+				Make_Cons (
+					Interp.Self,
+					Integer_To_Pointer (9),
+					Nil_Pointer
+				)
+			)
+		);
+		Y := Make_Cons (
+			Interp.Self,
+			Make_Symbol (Interp.Self, "+"),
+			Make_Cons (
+				Interp.Self,
+				Integer_To_Pointer (100),
+				Make_Cons (
+					Interp.Self,
+					Z,
+					Nil_Pointer
+				)
+			)
+		);
 		Result := Make_Cons (
 			Interp.Self,
 			Make_Symbol (Interp.Self, "+"),
 			Make_Cons (
 				Interp.Self,
-				Integer_To_Pointer (10),
+				--Integer_To_Pointer (10),
+				Y,
 				Make_Cons (
 					Interp.Self,
-					Integer_To_Pointer (20),
+					Integer_To_Pointer (-5),
-					Integer_To_Pointer (2)
+					Make_Cons (
+						Interp.Self,
+						Y,
+						Integer_To_Pointer (20)
+					)
 				)
 			)
 		);
@@ -1607,7 +1750,7 @@ end Make_Test_Object;
 		--	Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop 
 		--end Pop_Frame;
 
-		procedure Pop_Frame (Stack:   out Object_Pointer) is
+		procedure Pop_Frame (Stack: out Object_Pointer) is
 			pragma Inline (Pop_Frame);
 		begin
 			pragma Assert (Stack /= Nil_Pointer);
@@ -1623,24 +1766,19 @@ end Make_Test_Object;
 
 			Tmp: Object_Pointer;
 		begin
-Text_IO.Put_Line ("Evaluate_Object...");
+		<<Start_Over>>
 			Operand := Get_Frame_Operand (Stack);
 
 			if Get_Pointer_Type(Operand) /= Object_Pointer_Type_Pointer then
-Text_IO.Put_Line ("NON_POINTER...");
 				goto Literal;
 			end if;
 
-Print_Object_Pointer ("Operand => ", Operand);
 			case Operand_Word is
 				when Nil_Word | True_Word | False_Word =>
 					-- special literal object
-Text_IO.Put_Line ("SPECIAL POINTER...");
 					goto Literal;
 
 				when others =>
-Text_IO.Put_Line ("OTHER BDONE.." & Object_Tag'Image(Operand.Tag));
-
 					case Operand.Tag is
 						when Symbol_Object => -- Is_Symbol(Operand)
 							Tmp := Get_Environment (Interp.Self, Get_Frame_Environment(Stack), Operand); -- TODO: use current environent
@@ -1649,7 +1787,6 @@ Text_IO.Put_Line ("OTHER BDONE.." & Object_Tag'Image(Operand.Tag));
 								Text_IO.Put_Line ("Unbound symbol....");
 							else
 								-- symbol found in the environment
-Text_IO.Put_Line ("SUMBOL BDONE..");
 								Operand := Tmp; 
 								goto Literal;  -- In fact, this is not a literal, but can be handled in the same way
 							end if;
@@ -1657,32 +1794,56 @@ Text_IO.Put_Line ("SUMBOL BDONE..");
 						when Cons_Object => -- Is_Cons(Operand)
 							Tmp := Get_Car(Operand);
 							if Is_Syntax(Tmp) then
-Text_IO.Put_Line ("SYNTAX ..");
 								-- special syntax symbol. normal evaluate rule doesn't 
 								-- apply for special syntax objects.
 								--Opcode := Syntax_To_Opcode(Operand);
 								Set_Frame_Opcode (Stack, Opcode_Evaluate_Syntax);  -- switch to syntax evaluation
 							else
-Text_IO.Put_Line ("NON_SYNTAX ..");
 								declare
 									Cdr: Object_Pointer := Get_Cdr(Operand);
 								begin
 									if Is_Cons(Cdr) then
-										Set_Frame_Operand (Stack, Cdr); -- change the operand for the next call
+										-- Not the last cons cell yet
-										Push_Frame (Stack, Opcode_Evaluate_Object, Tmp, Get_Frame_Environment(Stack)); 
+										Set_Frame_Operand (Stack, Cdr); -- change the operand for the next call 
 									else
+										-- Reached the last cons cell
 										if Cdr /= Nil_Pointer then
-											Text_IO.Put_Line ("..................FUCKING CDR.....................");
+											-- The last CDR is not NIL.
+											Text_IO.Put_Line ("$$$$..................FUCKING CDR.....................$$$$");
 										end if;
-										Operand := Get_Frame_Return(Stack);
+
-										Set_Frame_Opcode (Stack, Opcode_Apply); 
+										-- Change the operand to a mark object so that the call to this 
+										-- procedure after the evaluation of the last car goes to the 
+										-- Mark_Object case.
+										Set_Frame_Operand (Stack, Interp.Mark); 
 									end if;
+
+									-- Arrange to evaluate the car object
+									Push_Frame (Stack, Opcode_Evaluate_Object, Tmp, Get_Frame_Environment(Stack));  
+									goto Start_Over; -- for optimization only. not really needed.
 								end;
 							end if;
 
+						when Mark_Object =>
+							-- TODO: you can use the mark context to differentiate context
+
+							-- Get the evaluation result stored in the current stack frame by
+							-- various sub-Opcode_Evaluate_Object frames. the return value 
+							-- chain must be reversed Chain_Frame_Return reverse-chains values.
+							Operand := Reverse_Cons(Get_Frame_Return(Stack));
+
+							-- Refresh the current stack frame to Opcode_Apply.
+							-- This should be faster than Popping the current frame and pushing
+							-- a new frame.
+							--   Envir := Get_Frame_Environment(Stack);
+							--   Pop_Frame (Stack); -- done
+							--   Push_Frame (Stack, Opcode_Apply, Operand, Envir); 
+							Clear_Frame_Return (Stack);
+							Set_Frame_Opcode (Stack, Opcode_Apply); 
+							Set_Frame_Operand (Stack, Operand);
+
 						when others =>
 							-- normal literal object
-Text_IO.Put_Line ("nORMAL LITERAL POINTER...");
 							goto Literal;
 					end case;
 			end case;
@@ -1691,15 +1852,11 @@ Text_IO.Put_Line ("nORMAL LITERAL POINTER...");
 
 		<<Literal>>
 			Pop_Frame (Stack); -- done
-Print_Object_Pointer ("Return => ", Operand);
+Text_IO.Put ("Return => ");
-			Set_Frame_Return (Stack, Operand);
+Print (Interp, Operand);
+			Chain_Frame_Return (Interp, Stack, Operand);
 		end Evaluate_Object;
 
-		procedure Evaluate_Argument (Stack: in out Object_Pointer) is
-		begin
-			null;
-		end Evaluate_Argument;
-
 		procedure Evaluate_Syntax (Stack: in out Object_Pointer) is
 			Scode: Syntax_Code;
 		begin
@@ -1718,10 +1875,140 @@ Print_Object_Pointer ("Return => ", Operand);
 		end Evaluate_Procedure;
 
 		procedure Apply (Stack: in out Object_Pointer) is
+			Operand: Object_Pointer;
+			Func: Object_Pointer;
+			Args: Object_Pointer;
+
+			procedure Apply_Car_Procedure is
+			begin
+				Pop_Frame (Stack); -- Done with the current frame
+				Chain_Frame_Return (Interp, Stack, Get_Car(Args));
+			end Apply_Car_Procedure;
+
+			procedure Apply_Cdr_Procedure is
+			begin
+				Pop_Frame (Stack); -- Done with the current frame
+				Chain_Frame_Return (Interp, Stack, Get_Cdr(Args));
+			end Apply_Cdr_Procedure;
+
+			procedure Apply_Add_Procedure is
+				Ptr: Object_Pointer := Args;
+				Num: Object_Integer := 0; -- TODO: support BIGNUM
+				Car: Object_Pointer;
+			begin
+				while Ptr /= Nil_Pointer loop
+					-- TODO: check if car is an integer or bignum or something else.
+					--       if something else, error
+					Car := Get_Car(Ptr);
+					if not Is_Integer(Car) then
+						raise Evaluation_Error;
+					end if;
+					Num := Num + Pointer_To_Integer(Car);
+					Ptr := Get_Cdr(Ptr);
+				end loop;
+
+				Pop_Frame (Stack); -- Done with the current frame
+				Chain_Frame_Return (Interp, Stack, Integer_To_Pointer(Num));
+			end Apply_Add_Procedure;
+
+			procedure Apply_Subtract_Procedure is
+				Ptr: Object_Pointer := Args;
+				Num: Object_Integer := 0; -- TODO: support BIGNUM
+				Car: Object_Pointer;
+			begin
+				if Ptr /= Nil_Pointer then
+					Car := Get_Car(Ptr);
+					if not Is_Integer(Car) then
+						raise Evaluation_Error;
+					end if;
+					Num := Pointer_To_Integer(Car);
+
+					while Ptr /= Nil_Pointer loop
+						-- TODO: check if car is an integer or bignum or something else.
+						--       if something else, error
+						Car := Get_Car(Ptr);
+						if not Is_Integer(Car) then
+							raise Evaluation_Error;
+						end if;
+						Num := Num - Pointer_To_Integer(Car);
+						Ptr := Get_Cdr(Ptr);
+					end loop;
+				end if;
+
+				Pop_Frame (Stack); --  Done with the current frame
+				Chain_Frame_Return (Interp, Stack, Integer_To_Pointer(Num));
+			end Apply_Subtract_Procedure;
+
+			procedure Apply_Closure is
+				Envir: Object_Pointer;
+				Param: Object_Pointer;
+				Arg: Object_Pointer;
+			begin
+				-- For a closure created of "(lambda (x y) (+ x y) (* x y))"
+				-- Get_Closure_Code(Func) returns "((x y) (+ x y) (* x y))"
+				Envir := Make_Cons (Interp.Self, Nil_Pointer, Get_Closure_Environment(Func));
+				Param := Get_Car(Get_Closure_Code(Func)); -- parameter list
+				Arg := Get_Car(Args);
+				while Is_Cons(Param) loop
+
+					-- Insert the parameter name/value pair into the environment
+					--Set_Car (Envir, Make_Cons (Interp.Self, 
+
+					Param := Get_Cdr(Param);
+					Arg := Get_Cdr(Arg);
+				end loop;
+					
+				--Push_Frame (....);
+			end Apply_Closure;
+
 		begin
-			null;
+			Operand := Get_Frame_Operand(Stack);
+			pragma Assert (Is_Cons(Operand));
+
+Print (Interp, Operand);
+			Func := Get_Car(Operand);
+			if not Is_Normal_Pointer(Func) then
+				Text_IO.Put_Line ("INVALID FUNCTION TYPE");
+				raise Evaluation_Error;
+			end if;
+	
+			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
+						when Car_Procedure =>
+							Apply_Car_Procedure;
+						when Cdr_Procedure =>
+							Apply_Cdr_Procedure;
+
+						when Add_Procedure =>
+							Apply_Add_Procedure;
+						when Subtract_Procedure =>
+							Apply_Subtract_Procedure;
+
+						when others =>
+							raise Internal_Error;
+					end case;	
+
+				when Closure_Object =>
+					Apply_Closure;
+
+				when Continuation_Object =>
+					null;
+
+				when others =>
+					Text_IO.Put_Line ("INVALID FUNCTION TYPE");
+					raise Internal_Error;
+
+			end case;
 		end Apply;
 
+
 		Stack: Object_Pointer; -- TODO: make it into the interpreter_Record so that GC can workd
 
 	begin
@@ -1738,9 +2025,6 @@ Print_Object_Pointer ("Return => ", Operand);
 				when Opcode_Evaluate_Object =>
 					Evaluate_Object (Stack);
 					
-				when Opcode_Evaluate_Argument =>
-					Evaluate_Argument (Stack);
-	
 				when Opcode_Evaluate_Syntax =>
 					Evaluate_Syntax (Stack);
 
@@ -1759,14 +2043,9 @@ Print_Object_Pointer ("Return => ", Operand);
 
 		-- the stack must be empty when the loop is terminated
 		pragma Assert (Stack = Nil_Pointer);
-
 	end Evaluate;
 
 end H2.Scheme;
 
 
 
---(+ (+ 1 2) (+ 1 2))
---push | eval | expr | result |
-
-

lib/h2-scheme.ads

@@ -161,7 +161,8 @@ package H2.Scheme is
 		Procedure_Object,
 		Closure_Object,
 		Continuation_Object,
-		Frame_Object
+		Frame_Object,
+		Mark_Object
 	);
 
 	type Object_Record (Kind: Object_Kind; Size: Object_Size) is record
@@ -374,6 +375,7 @@ private
 		Root_Environment: Object_Pointer := Nil_Pointer;
 		Environment: Object_Pointer := Nil_Pointer;
 		Stack: Object_Pointer := Nil_Pointer;
+		Mark: Object_Pointer := Nil_Pointer;
 
 		R: Register_Record;