repaired broken let, letast, letrec handling

lib/h2-scheme-execute-evaluate.adb

@@ -341,13 +341,17 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
 			Push_Top (Interp, Envir'Unchecked_Access);
 			Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));
 
+			-- Create an array to hold the binding list and the evaluation result
+			Cdr := Make_Array (Interp.Self, 3);
+			Cdr.Pointer_Slot(1) := Car;
+
 			-- The actual binding after evaluation must be performed in the 
 			-- new environment.
-			Push_Frame (Interp, Opcode_Let_Binding, Car);
+			Push_Frame (Interp, Opcode_Let_Binding, Cdr);
 
 			-- But evaluation must be done in the current environment which is 
 			-- the environment before the environment update above.
-			Push_Frame_With_Environment (Interp, Opcode_Let_Evaluation, Car, Envir); 
+			Push_Frame_With_Environment (Interp, Opcode_Let_Evaluation, Cdr, Envir); 
 			Pop_Tops (Interp, 1);
 		end if;
 	end Evaluate_Let_Syntax;
@@ -393,8 +397,11 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
 			-- <bindings> is not empty
 			-- Arrange to perform evaluataion and binding in the
 			-- new environment created.
-			Push_Frame (Interp, Opcode_Let_Binding, Car);
+			Cdr := Make_Array (Interp.Self, 3);
-			Push_Frame (Interp, Opcode_Let_Evaluation, Car); 
+			Cdr.Pointer_Slot(1) := Car;
+
+			Push_Frame (Interp, Opcode_Let_Binding, Cdr);
+			Push_Frame (Interp, Opcode_Let_Evaluation, Cdr); 
 		end if;
 	end Evaluate_Letrec_Syntax;
 

lib/h2-scheme-execute.adb

@@ -145,15 +145,15 @@ procedure Execute (Interp: in out Interpreter_Record) is
 		R := Make_Cons(Interp.Self, Get_Car(Get_Frame_Result(Interp.Stack)), R); 
 
 		Clear_Frame_Result (Interp.Stack);
-		if not Is_Cons(S) then
+		if Is_Cons(S) then
+			Set_Cdr (X, R); -- chain the result
+			Set_Car (X, Get_Cdr(S)); -- remember the next <operator> to evaluate
+			Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(S));
+		else
 			-- no more argument to evaluate. 
 			-- apply the evaluated arguments to the evaluated operator.
 			Set_Frame_Opcode (Interp.Stack, Opcode_Apply); 
 			Set_Frame_Operand (Interp.Stack, Reverse_Cons(R));
-		else
-			Set_Cdr (X, R);
-			Set_Car (X, Get_Cdr(S)); 
-			Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(S));
 		end if;
 
 		Pop_Tops (Interp, 3);
@@ -216,56 +216,108 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
 
 	procedure Do_Let_Evaluation is
 		pragma Inline (Do_Let_Evaluation);
-		X: Object_Pointer;
+		X: aliased Object_Pointer;
-		Y: Object_Pointer;
+		S: aliased Object_Pointer;
+		R: aliased Object_Pointer;
 	begin	
-		X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
+		Push_Top (Interp, X'Unchecked_Access);
+		Push_Top (Interp, S'Unchecked_Access);
+		Push_Top (Interp, R'Unchecked_Access);
 
-		if Is_Cons(X) then
+		X := Get_Frame_Operand(Interp.Stack); 
-			Set_Frame_Operand (Interp.Stack, Get_Cdr(X));
+		pragma Assert (Is_Array(X));
-			-- Say, <bindings> is ((x 2) (y 2)).
+
-			-- for the first call, Get_Car(X) is (x 2).
+		R := X.Pointer_Slot(3);
-			-- To get x, Get_Car(Get_Car(X))
+		if R = Nil_Pointer then
-			-- To get 2, Get_Car(Get_Cdr(Get_Car(X)))
+			-- First call;
-			Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
+			X.Pointer_Slot(2) := X.Pointer_Slot(1);
 		else
-			-- Pass the result to the Perform_Let_Binding frame.
+			-- Subsequent calls. Store the result in the room created 
-			Y := Get_Frame_Result(Interp.Stack);
+			-- in the previous call.
-			Pop_Frame (Interp);
+			pragma Assert (Is_Cons(R));
-			Set_Frame_Result (Interp.Stack, Y);
+			Set_Car (R, Get_Car(Get_Frame_Result(Interp.Stack)));
 		end if;
-	end Do_Let_Evaluation;
+		S := X.Pointer_Slot(2);
 
+		if Is_Cons(S) then
+			-- Handle each binding.
+
+			-- Make an empty room to hold the result on the next call
+			R := Make_Cons (Interp.Self, Nil_Pointer, R);
+			X.Pointer_Slot(3) := R;
+
+			-- Remember the next <operator> to evaluate
+			X.Pointer_Slot(2) := Get_Cdr(S);
+
+			-- Say, <bindings> is ((x 2) (y 2)).
+			-- for the first call, Get_Car(S) is (x 2).
+			-- To get x, Get_Car(Get_Car(S))
+			-- To get 2, Get_Car(Get_Cdr(Get_Car(S)))
+			Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(S))));
+
+		else
+			-- No more binding to handle.
+			Pop_Frame (Interp);
+
+			-- The operands at the Let_Evaluation and the Let_Binding frame
+			-- must be the identical objects. this way, i don't need to carry
+			-- over the binding result to the Let_Binding frame.
+			pragma Assert (X = Get_Frame_Operand(Interp.Stack));
+			pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Binding);
+			--X := Get_Frame_Operand(Interp.Stack);
+			--pragma Assert (Is_Array(X));
+			--pragma Assert (X.Pointer_Slot(3) = Nil_Pointer);
+			--X.Pointer_Slot(3) := R;
+		end if;
+
+		Pop_Tops (Interp, 3);
+	end Do_Let_Evaluation;
 
 	procedure Do_Let_Binding is
 		pragma Inline (Do_Let_Binding);
 		X: aliased Object_Pointer;
-		Y: aliased Object_Pointer;
+		S: aliased Object_Pointer;
+		R: aliased Object_Pointer;
 	begin
 		Push_Top (Interp, X'Unchecked_Access);
-		Push_Top (Interp, Y'Unchecked_Access);
+		Push_Top (Interp, S'Unchecked_Access);
+		Push_Top (Interp, R'Unchecked_Access);
 
-		-- Evaluation of <bindings> is completed.
-		-- Update the environments.
 		X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
-		Y := Reverse_Cons(Get_Frame_Result(Interp.Stack));
+		pragma Assert (Is_Array(X));
 
-		while Is_Cons(X) loop
+		S := X.Pointer_Slot(1);
-			pragma Assert (Is_Cons(Y));
+		R := X.Pointer_Slot(3);
-			Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y));
+		R := Reverse_Cons(R);
 
-			X := Get_Cdr(X);
+		while Is_Cons(S) loop
-			Y := Get_Cdr(Y);
+			pragma Assert (Is_Cons(R));
+			Put_Environment (Interp, Get_Car(Get_Car(S)), Get_Car(R));
+			S := Get_Cdr(S);
+			R := Get_Cdr(R);
 		end loop;
 
 		Pop_Frame (Interp); -- done. 
 		pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish);
 
-		Pop_Tops (Interp, 2);
+		Pop_Tops (Interp, 3);
 	end Do_Let_Binding;
 
 	procedure Do_Letast_Binding is
 		pragma Inline (Do_Letast_Binding);
+		X: Object_Pointer;
+	begin
+		X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
+
+		-- Don't call this procedure if <bindings> is empty. The caller must ensure this
+		pragma Assert (Is_Cons(X)); 
+
+		Set_Frame_Opcode (Interp.Stack, Opcode_Letast_Binding_Finish);
+		Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
+	end Do_Letast_Binding;
+
+	procedure Do_Letast_Binding_Finish is
+		pragma Inline (Do_Letast_Binding_Finish);
 		X: aliased Object_Pointer;
 		Y: aliased Object_Pointer;
 		Envir: aliased Object_Pointer;
@@ -277,13 +329,7 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
 		X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
 		Y := Get_Frame_Result(Interp.Stack);
 
-		if Y = Nil_Pointer then
+		-- Update the environment while evaluating <bindings>
-			-- First call
-			pragma Assert (Is_Cons(X)); -- Don't provoke this procedure if <bindings> is empty.
-			Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));	
-			Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
-		else
-			-- Subsequence calls. Update the environment while evaluating <bindings>
 
 		-- Push a new environment for each binding.
 		Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
@@ -307,10 +353,9 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
 			pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish);
 			Set_Frame_Environment (Interp.Stack, Envir);
 		end if;
-		end if;
 
 		Pop_Tops (Interp, 3);
-	end Do_Letast_Binding;
+	end Do_Letast_Binding_Finish;
 
 	procedure Do_Let_Finish is
 		pragma Inline (Do_Let_Finish);
@@ -994,6 +1039,8 @@ begin
 				Do_Let_Binding; 
 			when Opcode_Letast_Binding =>
 				Do_Letast_Binding; 
+			when Opcode_Letast_Binding_Finish =>
+				Do_Letast_Binding_Finish; 
 			when Opcode_Let_Evaluation =>
 				Do_Let_Evaluation;
 			when Opcode_Let_Finish =>

lib/h2-scheme.adb

@@ -93,7 +93,7 @@ package body H2.Scheme is
 
 	subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
 
-	subtype Opcode_Type is Object_Integer range 0 .. 21;
+	subtype Opcode_Type is Object_Integer range 0 .. 22;
 	Opcode_Exit:                 constant Opcode_Type := Opcode_Type'(0);
 	Opcode_Evaluate_Result:      constant Opcode_Type := Opcode_Type'(1);
 	Opcode_Evaluate_Object:      constant Opcode_Type := Opcode_Type'(2);
@@ -106,18 +106,19 @@ package body H2.Scheme is
 	Opcode_Grouped_Call_Finish:  constant Opcode_Type := Opcode_Type'(8);
 	Opcode_Let_Binding:          constant Opcode_Type := Opcode_Type'(9);
 	Opcode_Letast_Binding:       constant Opcode_Type := Opcode_Type'(10);
-	Opcode_Let_Evaluation:       constant Opcode_Type := Opcode_Type'(11);
+	Opcode_Letast_Binding_Finish:constant Opcode_Type := Opcode_Type'(11);
-	Opcode_Let_Finish:           constant Opcode_Type := Opcode_Type'(12);
+	Opcode_Let_Evaluation:       constant Opcode_Type := Opcode_Type'(12);
-	Opcode_Procedure_Call:       constant Opcode_Type := Opcode_Type'(13); 
+	Opcode_Let_Finish:           constant Opcode_Type := Opcode_Type'(13);
-	Opcode_Set_Finish:           constant Opcode_Type := Opcode_Type'(14); 
+	Opcode_Procedure_Call:       constant Opcode_Type := Opcode_Type'(14); 
+	Opcode_Set_Finish:           constant Opcode_Type := Opcode_Type'(15); 
 
-	Opcode_Apply:                constant Opcode_Type := Opcode_Type'(15);
+	Opcode_Apply:                constant Opcode_Type := Opcode_Type'(16);
-	Opcode_Read_Object:          constant Opcode_Type := Opcode_Type'(16);
+	Opcode_Read_Object:          constant Opcode_Type := Opcode_Type'(17);
-	Opcode_Read_List:            constant Opcode_Type := Opcode_Type'(17);
+	Opcode_Read_List:            constant Opcode_Type := Opcode_Type'(18);
-	Opcode_Read_List_Cdr:        constant Opcode_Type := Opcode_Type'(18);
+	Opcode_Read_List_Cdr:        constant Opcode_Type := Opcode_Type'(19);
-	Opcode_Read_List_End:        constant Opcode_Type := Opcode_Type'(19);
+	Opcode_Read_List_End:        constant Opcode_Type := Opcode_Type'(20);
-	Opcode_Close_List:           constant Opcode_Type := Opcode_Type'(20);
+	Opcode_Close_List:           constant Opcode_Type := Opcode_Type'(21);
-	Opcode_Close_Quote:          constant Opcode_Type := Opcode_Type'(21);
+	Opcode_Close_Quote:          constant Opcode_Type := Opcode_Type'(22);
 
 	-----------------------------------------------------------------------------
 	-- COMMON OBJECTS