hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

started implementing call-with-current-continuation

Browse Source
This commit is contained in:
hyung-hwan 2014-01-26 16:15:28 +00:00
parent 4208d8f2df
commit 11143203af
5 changed files with 140 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
lib/h2-scheme-execute-apply.adb
View File

@ -8,6 +8,7 @@ procedure Apply is
Func: aliased Object_Pointer; Func: aliased Object_Pointer;
Args: aliased Object_Pointer; Args: aliased Object_Pointer;
-- ------------------------------------------------------------- -- -------------------------------------------------------------
-- List manipulation procedures -- 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_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); procedure Apply_LE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Or_Equal);
-- -------------------------------------------------------------
-- Closure
-- -------------------------------------------------------------
procedure Apply_Closure is procedure Apply_Closure is
Fbody: aliased Object_Pointer; Fbody: aliased Object_Pointer;
Formal: 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); Pop_Tops (Interp, 4);
end Apply_Closure; 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 begin
Push_Top (Interp, Operand'Unchecked_Access); Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Func'Unchecked_Access); Push_Top (Interp, Func'Unchecked_Access);
@ -384,6 +431,8 @@ Print (Interp, Operand);
when Procedure_Object => when Procedure_Object =>
case Get_Procedure_Opcode(Func) is case Get_Procedure_Opcode(Func) is
when Callcc_Procedure =>
Apply_Callcc_Procedure;
when Car_Procedure => when Car_Procedure =>
Apply_Car_Procedure; Apply_Car_Procedure;
when Cdr_Procedure => when Cdr_Procedure =>
@ -424,7 +473,7 @@ Print (Interp, Operand);
Apply_Closure; Apply_Closure;
when Continuation_Object => when Continuation_Object =>
null; Apply_Continuation;
when others => when others =>
Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE"); Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE");

3
lib/h2-scheme-execute-evaluate.adb
View File

@ -328,6 +328,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
-- y ; 11 -- y ; 11
-- x ; 10 -- x ; 10
-- --
-- #3.
-- (define x (let ((x x)) x))
--
if Car /= Nil_Pointer then if Car /= Nil_Pointer then
-- <bindings> is not empty -- <bindings> is not empty

19
lib/h2-scheme-execute.adb
View File

@ -178,6 +178,22 @@ procedure Execute (Interp: in out Interpreter_Record) is
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Finish_If_Syntax; 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 procedure Do_Let_Evaluation is
@ -950,6 +966,9 @@ begin
when Opcode_Finish_If_Syntax => when Opcode_Finish_If_Syntax =>
Finish_If_Syntax; -- Conditional Finish_If_Syntax; -- Conditional
when Opcode_Continuation_Finish =>
Do_Continuation_Finish;
when Opcode_Let_Binding => when Opcode_Let_Binding =>
Do_Let_Binding; Do_Let_Binding;
when Opcode_Letast_Binding => when Opcode_Letast_Binding =>

66
lib/h2-scheme.adb
View File

@ -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_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_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_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_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" 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 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_Exit: constant Opcode_Type := Opcode_Type'(0);
Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1); Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1);
Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2); 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_Or_Syntax: constant Opcode_Type := Opcode_Type'(7);
Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(8); 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_Continuation_Finish: constant Opcode_Type := Opcode_Type'(9);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(14); Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(10);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(15); Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(11);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(16); Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(12);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(17); Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(13);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(18);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(19); 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 -- COMMON OBJECTS
@ -135,6 +143,9 @@ package body H2.Scheme is
Closure_Code_Index: constant Pointer_Object_Size := 1; Closure_Code_Index: constant Pointer_Object_Size := 1;
Closure_Environment_Index: constant Pointer_Object_Size := 2; 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; procedure Set_New_Location (Object: in Object_Pointer;
Ptr: in Heap_Element_Pointer); Ptr: in Heap_Element_Pointer);
procedure Set_New_Location (Object: in Object_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); return Closure.Pointer_Slot(Closure_Environment_Index);
end Get_Closure_Environment; 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 procedure Deinitialize_Heap (Interp: in out Interpreter_Record) is
begin begin
@ -1660,6 +1699,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Dummy: Object_Pointer; Dummy: Object_Pointer;
begin begin
Dummy := Make_Procedure (Interp.Self, Add_Procedure, Label_Plus); -- "+" 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, Car_Procedure, Label_Car); -- "car"
Dummy := Make_Procedure (Interp.Self, Cdr_Procedure, Label_Cdr); -- "cdr" Dummy := Make_Procedure (Interp.Self, Cdr_Procedure, Label_Cdr); -- "cdr"
Dummy := Make_Procedure (Interp.Self, Cons_Procedure, Label_Cons); -- "cons" Dummy := Make_Procedure (Interp.Self, Cons_Procedure, Label_Cons); -- "cons"
@ -1898,7 +1938,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Cdr: Object_Pointer; Cdr: Object_Pointer;
begin begin
if Is_Cons (Obj) then if Is_Cons(Obj) then
Cons := Obj; Cons := Obj;
Ada.Text_IO.Put ("("); Ada.Text_IO.Put ("(");

29
lib/h2-scheme.ads
View File

@ -183,20 +183,21 @@ package H2.Scheme is
subtype Procedure_Code is Object_Integer; subtype Procedure_Code is Object_Integer;
Add_Procedure: constant Procedure_Code := Procedure_Code'(0); Add_Procedure: constant Procedure_Code := Procedure_Code'(0);
Car_Procedure: constant Procedure_Code := Procedure_Code'(1); Callcc_Procedure: constant Procedure_Code := Procedure_Code'(1);
Cdr_Procedure: constant Procedure_Code := Procedure_Code'(2); Car_Procedure: constant Procedure_Code := Procedure_Code'(2);
Cons_Procedure: constant Procedure_Code := Procedure_Code'(3); Cdr_Procedure: constant Procedure_Code := Procedure_Code'(3);
EQ_Procedure: constant Procedure_Code := Procedure_Code'(4); Cons_Procedure: constant Procedure_Code := Procedure_Code'(4);
GT_Procedure: constant Procedure_Code := Procedure_Code'(5); EQ_Procedure: constant Procedure_Code := Procedure_Code'(5);
LT_Procedure: constant Procedure_Code := Procedure_Code'(6); GT_Procedure: constant Procedure_Code := Procedure_Code'(6);
GE_Procedure: constant Procedure_Code := Procedure_Code'(7); LT_Procedure: constant Procedure_Code := Procedure_Code'(7);
LE_Procedure: constant Procedure_Code := Procedure_Code'(8); GE_Procedure: constant Procedure_Code := Procedure_Code'(8);
Multiply_Procedure: constant Procedure_Code := Procedure_Code'(9); LE_Procedure: constant Procedure_Code := Procedure_Code'(9);
Quotient_Procedure: constant Procedure_Code := Procedure_Code'(10); Multiply_Procedure: constant Procedure_Code := Procedure_Code'(10);
Remainder_Procedure: constant Procedure_Code := Procedure_Code'(11); Quotient_Procedure: constant Procedure_Code := Procedure_Code'(11);
Setcar_Procedure: constant Procedure_Code := Procedure_Code'(12); Remainder_Procedure: constant Procedure_Code := Procedure_Code'(12);
Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(13); Setcar_Procedure: constant Procedure_Code := Procedure_Code'(13);
Subtract_Procedure: constant Procedure_Code := Procedure_Code'(14); Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(14);
Subtract_Procedure: constant Procedure_Code := Procedure_Code'(15);
type Object_Tag is ( type Object_Tag is (
Unknown_Object, Unknown_Object,