diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index d2732f9..5b45141 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -8,6 +8,7 @@ procedure Apply is Func: aliased Object_Pointer; Args: aliased Object_Pointer; + -- ------------------------------------------------------------- -- List manipulation procedures -- ------------------------------------------------------------- @@ -290,6 +291,9 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); procedure Apply_GE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Or_Equal); procedure Apply_LE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Or_Equal); + -- ------------------------------------------------------------- + -- Closure + -- ------------------------------------------------------------- procedure Apply_Closure is Fbody: aliased Object_Pointer; Formal: aliased Object_Pointer; @@ -362,6 +366,49 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); Pop_Tops (Interp, 4); end Apply_Closure; + -- ------------------------------------------------------------- + -- Continuation + -- ------------------------------------------------------------- + + procedure Apply_Callcc_Procedure is + A: Object_Pointer; + C: Object_Pointer; + X: Object_Pointer; + begin + -- (define f (lambda (return) (return 2) 3)) + -- (f (lambda (x) x)) ; 3 + -- (call-with-current-continuation f) ; 2 + + +-- TODO: gc aware +-- TODO: check others, extra arguments.. etc + A := Get_Car(Args); + if not Is_Closure(A) then + ada.text_io.put_line ("NON CLOSURE XXXXXXX"); + raise Syntax_Error; + end if; + + C := Make_Continuation (Interp.Self, Get_Frame_Parent(Interp.Stack)); + C := Make_Cons (Interp.Self, C, Nil_Pointer); + X := Make_Cons (Interp.Self, A, C); + Set_Frame_Opcode (Interp.Stack, Opcode_Apply); + Set_Frame_Operand (Interp.Stack, X); + end Apply_Callcc_Procedure; + + procedure Apply_Continuation is + A: Object_Pointer; + begin +-- TODO: gc aware +-- more argument check. + A := Get_Car(Args); + +ada.text_io.put_line ("continuation....."); + Set_Frame_Opcode (Interp.Stack, Opcode_Continuation_Finish); + Set_Frame_Operand (Interp.Stack, Func); +print (interp, a); + Push_Frame (Interp, Opcode_Evaluate_Object, A); + end Apply_Continuation; + begin Push_Top (Interp, Operand'Unchecked_Access); Push_Top (Interp, Func'Unchecked_Access); @@ -384,6 +431,8 @@ Print (Interp, Operand); when Procedure_Object => case Get_Procedure_Opcode(Func) is + when Callcc_Procedure => + Apply_Callcc_Procedure; when Car_Procedure => Apply_Car_Procedure; when Cdr_Procedure => @@ -424,7 +473,7 @@ Print (Interp, Operand); Apply_Closure; when Continuation_Object => - null; + Apply_Continuation; when others => Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE"); diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 522f440..e713c66 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -328,6 +328,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); -- y ; 11 -- x ; 10 -- + -- #3. + -- (define x (let ((x x)) x)) + -- if Car /= Nil_Pointer then -- is not empty diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 56c1161..613a1e8 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -178,6 +178,22 @@ procedure Execute (Interp: in out Interpreter_Record) is Pop_Tops (Interp, 2); end Finish_If_Syntax; + -- -------------------------------------------------------------------- + procedure Do_Continuation_Finish is + pragma Inline (Do_Continuation_Finish); + C: Object_Pointer; + R: Object_Pointer; + begin + C := Get_Frame_Operand(Interp.Stack); + pragma Assert (Is_Continuation(C)); + R := Get_Frame_Result(Interp.Stack); + + Interp.Stack := Get_Continuation_Frame(C); + Set_Frame_Result (Interp.Stack, R); +ada.text_io.put_line ("resettting result"); +print (interp, get_Frame_result(interp.stack)); + end Do_Continuation_Finish; + -- -------------------------------------------------------------------- procedure Do_Let_Evaluation is @@ -950,6 +966,9 @@ begin when Opcode_Finish_If_Syntax => Finish_If_Syntax; -- Conditional + when Opcode_Continuation_Finish => + Do_Continuation_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 e903e54..c2720d2 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -43,6 +43,12 @@ package body H2.Scheme is Label_Quote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quote" Label_Set: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Exclamation); -- "set!" + + Label_Callcc: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_L, Ch.LC_L, Ch.Minus_Sign, + Ch.LC_W, Ch.LC_I, Ch.LC_T, Ch.LC_H, Ch.Minus_Sign, + Ch.LC_C, Ch.LC_U, Ch.LC_R, Ch.LC_R, Ch.LC_E, Ch.LC_N, Ch.LC_T, Ch.Minus_Sign, + Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_T, Ch.LC_I, Ch.LC_N, Ch.LC_U, Ch.LC_A, + Ch.LC_T, Ch.LC_I, Ch.LC_O, Ch.LC_N); -- "call-with-current-continuation" Label_Car: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_R); -- "car" Label_Cdr: constant Object_Character_Array := (Ch.LC_C, Ch.LC_D, Ch.LC_R); -- "cdr" Label_Cons: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_S); -- "cons" @@ -87,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 .. 19; + subtype Opcode_Type is Object_Integer range 0 .. 20; 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); @@ -98,18 +104,20 @@ package body H2.Scheme is Opcode_Finish_Or_Syntax: constant Opcode_Type := Opcode_Type'(7); Opcode_Finish_Set_Syntax: 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_Let_Finish: constant Opcode_Type := Opcode_Type'(12); - Opcode_Apply: constant Opcode_Type := Opcode_Type'(13); - Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(14); - Opcode_Read_List: constant Opcode_Type := Opcode_Type'(15); - Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(16); - Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(17); - Opcode_Close_List: constant Opcode_Type := Opcode_Type'(18); - Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(19); + Opcode_Continuation_Finish: constant Opcode_Type := Opcode_Type'(9); + Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(10); + Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(11); + Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(12); + Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(13); + + Opcode_Apply: constant Opcode_Type := Opcode_Type'(14); + Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(15); + Opcode_Read_List: constant Opcode_Type := Opcode_Type'(16); + Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(17); + Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(18); + Opcode_Close_List: constant Opcode_Type := Opcode_Type'(19); + Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(20); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -135,6 +143,9 @@ 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 := 1; + Continuation_Frame_Index: constant Pointer_Object_Size := 1; + procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Heap_Element_Pointer); procedure Set_New_Location (Object: in Object_Pointer; @@ -1523,6 +1534,34 @@ Ada.Text_IO.Put_Line ("Make_String..."); return Closure.Pointer_Slot(Closure_Environment_Index); end Get_Closure_Environment; + ----------------------------------------------------------------------------- + function Make_Continuation (Interp: access Interpreter_Record; + Frame: in Object_Pointer) return Object_Pointer is + Cont: Object_Pointer; + Aliased_Frame: aliased Object_Pointer := Frame; + begin + Push_Top (Interp.all, Aliased_Frame'Unchecked_Access); + Cont := Allocate_Pointer_Object (Interp, Closure_Object_Size, Nil_Pointer); + Cont.Tag := Continuation_Object; + Cont.Pointer_Slot(Continuation_Frame_Index) := Aliased_Frame; + Pop_Tops (Interp.all, 1); + return Cont; + end Make_Continuation; + + function Is_Continuation (Source: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_Continuation); + begin + return Is_Normal_Pointer(Source) and then + Source.Tag = Continuation_Object; + end Is_Continuation; + + function Get_Continuation_Frame (Cont: in Object_Pointer) return Object_Pointer is + pragma Inline (Get_Continuation_Frame); + pragma Assert (Is_Continuation(Cont)); + begin + return Cont.Pointer_Slot(Continuation_Frame_Index); + end Get_Continuation_Frame; + ----------------------------------------------------------------------------- procedure Deinitialize_Heap (Interp: in out Interpreter_Record) is begin @@ -1660,6 +1699,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Dummy: Object_Pointer; begin Dummy := Make_Procedure (Interp.Self, Add_Procedure, Label_Plus); -- "+" + Dummy := Make_Procedure (Interp.Self, Callcc_Procedure, Label_Callcc); -- "call-with-current-continuation" Dummy := Make_Procedure (Interp.Self, Car_Procedure, Label_Car); -- "car" Dummy := Make_Procedure (Interp.Self, Cdr_Procedure, Label_Cdr); -- "cdr" Dummy := Make_Procedure (Interp.Self, Cons_Procedure, Label_Cons); -- "cons" @@ -1898,7 +1938,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Cdr: Object_Pointer; begin - if Is_Cons (Obj) then + if Is_Cons(Obj) then Cons := Obj; Ada.Text_IO.Put ("("); diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index fe8fc01..9a64499 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -183,20 +183,21 @@ package H2.Scheme is subtype Procedure_Code is Object_Integer; Add_Procedure: constant Procedure_Code := Procedure_Code'(0); - Car_Procedure: constant Procedure_Code := Procedure_Code'(1); - Cdr_Procedure: constant Procedure_Code := Procedure_Code'(2); - Cons_Procedure: constant Procedure_Code := Procedure_Code'(3); - EQ_Procedure: constant Procedure_Code := Procedure_Code'(4); - GT_Procedure: constant Procedure_Code := Procedure_Code'(5); - LT_Procedure: constant Procedure_Code := Procedure_Code'(6); - GE_Procedure: constant Procedure_Code := Procedure_Code'(7); - LE_Procedure: constant Procedure_Code := Procedure_Code'(8); - Multiply_Procedure: constant Procedure_Code := Procedure_Code'(9); - Quotient_Procedure: constant Procedure_Code := Procedure_Code'(10); - Remainder_Procedure: constant Procedure_Code := Procedure_Code'(11); - Setcar_Procedure: constant Procedure_Code := Procedure_Code'(12); - Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(13); - Subtract_Procedure: constant Procedure_Code := Procedure_Code'(14); + Callcc_Procedure: constant Procedure_Code := Procedure_Code'(1); + Car_Procedure: constant Procedure_Code := Procedure_Code'(2); + Cdr_Procedure: constant Procedure_Code := Procedure_Code'(3); + Cons_Procedure: constant Procedure_Code := Procedure_Code'(4); + EQ_Procedure: constant Procedure_Code := Procedure_Code'(5); + GT_Procedure: constant Procedure_Code := Procedure_Code'(6); + LT_Procedure: constant Procedure_Code := Procedure_Code'(7); + GE_Procedure: constant Procedure_Code := Procedure_Code'(8); + LE_Procedure: constant Procedure_Code := Procedure_Code'(9); + Multiply_Procedure: constant Procedure_Code := Procedure_Code'(10); + Quotient_Procedure: constant Procedure_Code := Procedure_Code'(11); + Remainder_Procedure: constant Procedure_Code := Procedure_Code'(12); + Setcar_Procedure: constant Procedure_Code := Procedure_Code'(13); + Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(14); + Subtract_Procedure: constant Procedure_Code := Procedure_Code'(15); type Object_Tag is ( Unknown_Object,