diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index 4a54c69..d85abb1 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -406,28 +406,22 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); Push_Top (Interp, C'Unchecked_Access); C := Get_Frame_Parent(Interp.Stack); - if Get_Frame_Parent(C) = Nil_Pointer then - C := Make_Continuation (Interp.Self, C, Nil_Pointer, Nil_Pointer); - else - declare w: object_word; for w'address use c'address; + f: object_word; for f'address use interp.stack'address; r: object_pointer := get_frame_result(c); -rw: object_word; -for rw'address use r'address; begin ada.text_io.put_line ("Frame" & object_word'image(f) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); ada.text_io.put (" CURRENT RESULT "); print (interp, r); +ada.text_io.put_line (" PARENT FRAME " & object_word'image(w)); end; - --C := Make_Continuation (Interp.Self, C, Get_Frame_Result(Get_Frame_Parent(C)), Get_Frame_Operand(Get_Frame_Parent(C))); - C := Make_Continuation (Interp.Self, C, Get_Frame_Result(Get_Frame_Parent(C)), Get_Frame_Result(C)); - end if; + C := Make_Continuation (Interp.Self, C); C := Make_Cons (Interp.Self, C, Nil_Pointer); C := Make_Cons (Interp.Self, Get_Car(Args), C); declare @@ -444,6 +438,7 @@ end; Set_Frame_Opcode (Interp.Stack, Opcode_Apply); Set_Frame_Operand (Interp.Stack, C); Clear_Frame_Result (Interp.Stack); + ada.text_io.put_line (" CLEARED RESULT BEFORE APPLYING"); Pop_Tops (Interp, 1); @@ -489,16 +484,6 @@ ada.text_io.put_line (" CURRENT OPCODE " & opcode_type'imag end; -declare -k: object_pointer := get_continuation_save2(func); -w: object_word; -for w'address use k'address; -begin -ada.text_io.put (" RESTORE FREME RESULT TO " & object_word'image(w) & " --> "); -print (interp, k); -end; - --Set_Frame_Result (Interp.Stack, Get_Continuation_Save2(Func)); - ada.text_io.put (" CHAIN NEW RESULT, TAKING THE FIRST ONLY FROM "); print (interp, args); Put_Frame_Result (Interp, Interp.Stack, Get_Car(Args)); diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 4749511..d6d4b46 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -1036,6 +1036,7 @@ begin Do_Grouped_Call; when Opcode_Grouped_Call_Finish => Do_Grouped_Call_Finish; + when Opcode_Let_Binding => Do_Let_Binding; when Opcode_Letast_Binding => diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 7550b23..da56dd2 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -147,10 +147,8 @@ package body H2.Scheme is Closure_Code_Index: constant Pointer_Object_Size := 1; Closure_Environment_Index: constant Pointer_Object_Size := 2; - Continuation_Object_Size: constant Pointer_Object_Size := 3; + Continuation_Object_Size: constant Pointer_Object_Size := 1; Continuation_Frame_Index: constant Pointer_Object_Size := 1; - Continuation_Save_Index: constant Pointer_Object_Size := 2; - Continuation_Save2_Index: constant Pointer_Object_Size := 3; procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Heap_Element_Pointer); @@ -1572,20 +1570,14 @@ Ada.Text_IO.Put_Line ("Make_String..."); ----------------------------------------------------------------------------- function Make_Continuation (Interp: access Interpreter_Record; - Frame: in Object_Pointer; - Save: in Object_Pointer; - Save2: in Object_Pointer) return Object_Pointer is + Frame: in Object_Pointer) return Object_Pointer is Cont: Object_Pointer; Aliased_Frame: aliased Object_Pointer := Frame; - Aliased_Save: aliased Object_Pointer := Save; - Aliased_Save2: aliased Object_Pointer := Save2; begin Push_Top (Interp.all, Aliased_Frame'Unchecked_Access); Cont := Allocate_Pointer_Object (Interp, Continuation_Object_Size, Nil_Pointer); Cont.Tag := Continuation_Object; Cont.Pointer_Slot(Continuation_Frame_Index) := Aliased_Frame; - Cont.Pointer_Slot(Continuation_Save_Index) := Aliased_Save; - Cont.Pointer_Slot(Continuation_Save2_Index) := Aliased_Save2; Pop_Tops (Interp.all, 1); return Cont; end Make_Continuation; @@ -1604,20 +1596,6 @@ Ada.Text_IO.Put_Line ("Make_String..."); return Cont.Pointer_Slot(Continuation_Frame_Index); end Get_Continuation_Frame; - function Get_Continuation_Save (Cont: in Object_Pointer) return Object_Pointer is - pragma Inline (Get_Continuation_Save); - pragma Assert (Is_Continuation(Cont)); - begin - return Cont.Pointer_Slot(Continuation_Save_Index); - end Get_Continuation_Save; - - function Get_Continuation_Save2 (Cont: in Object_Pointer) return Object_Pointer is - pragma Inline (Get_Continuation_Save2); - pragma Assert (Is_Continuation(Cont)); - begin - return Cont.Pointer_Slot(Continuation_Save2_Index); - end Get_Continuation_Save2; - ----------------------------------------------------------------------------- procedure Deinitialize_Heap (Interp: in out Interpreter_Record) is begin