changed implementation of procedure call and grouped call.

still struggling with call-with-current-continuation
This commit is contained in:
2014-01-28 15:42:28 +00:00
parent 11143203af
commit 04aa5de83c
5 changed files with 411 additions and 252 deletions

View File

@ -28,7 +28,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CAR");
end if;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Get_Car(A));
Put_Frame_Result (Interp, Interp.Stack, Get_Car(A));
end Apply_Car_Procedure;
procedure Apply_Cdr_Procedure is
@ -47,7 +47,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CDR");
end if;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Get_Cdr(A));
Put_Frame_Result (Interp, Interp.Stack, Get_Cdr(A));
end Apply_Cdr_Procedure;
procedure Apply_Cons_Procedure is
@ -65,7 +65,7 @@ Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CONS");
Ptr := Make_Cons (Interp.Self, A, B); -- change car
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Ptr);
Put_Frame_Result (Interp, Interp.Stack, Ptr);
end Apply_Cons_Procedure;
procedure Apply_Setcar_Procedure is
@ -87,7 +87,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcar");
Set_Car (A, B); -- change car
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, A);
Put_Frame_Result (Interp, Interp.Stack, A);
end Apply_Setcar_Procedure;
procedure Apply_Setcdr_Procedure is
@ -109,7 +109,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcdr");
Set_Cdr (A, B); -- change cdr
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, A);
Put_Frame_Result (Interp, Interp.Stack, A);
end Apply_Setcdr_Procedure;
-- -------------------------------------------------------------
@ -133,7 +133,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
end loop;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
Put_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Add_Procedure;
procedure Apply_Subtract_Procedure is
@ -162,7 +162,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
end if;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
Put_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Subtract_Procedure;
procedure Apply_Multiply_Procedure is
@ -183,7 +183,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
end loop;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
Put_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Multiply_Procedure;
procedure Apply_Quotient_Procedure is
@ -204,7 +204,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
end loop;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
Put_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Quotient_Procedure;
generic
@ -242,7 +242,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
end loop;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Bool);
Put_Frame_Result (Interp, Interp.Stack, Bool);
else
Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
raise Syntax_Error;
@ -359,7 +359,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
end if;
end if;
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call);
Set_Frame_Operand (Interp.Stack, Fbody);
Clear_Frame_Result (Interp.Stack);
@ -370,43 +370,155 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
-- Continuation
-- -------------------------------------------------------------
procedure Apply_Callcc_Procedure is
A: Object_Pointer;
C: Object_Pointer;
X: Object_Pointer;
function Is_Callcc_Friendly (A: Object_Pointer) return Standard.Boolean is
pragma Inline (Is_Callcc_Friendly);
begin
-- (define f (lambda (return) (return 2) 3))
-- (f (lambda (x) x)) ; 3
-- (call-with-current-continuation f) ; 2
return Is_Closure(A) or else Is_Procedure(A) or else Is_Continuation(A);
end Is_Callcc_Friendly;
procedure Apply_Callcc_Procedure is
C: aliased Object_Pointer;
begin
-- (call-with-current-continuation proc)
-- where proc is a procedure accepting one argument.
--
-- (define f (lambda (return) (return 2) 3))
-- (f (lambda (x) x)) ; 3
-- (call-with-current-continuation f) ; 2
--
-- (call-with-current-continuation (lambda (return) (return 2) 3))
--
-- (define c (call-with-current-continuation call-with-current-continuation))
-- c ; continuation
-- (c (+ 1 2 3)) ; 6 becomes the result of the frame that continuation remembers.
-- ; subsequently, its parent frames are executed.
-- c ; 6
-- 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");
if not Is_Cons(Args) or else Get_Cdr(Args) /= Nil_Pointer then
Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CALL/CC");
raise Syntax_Error;
end if;
if not Is_Callcc_Friendly(Get_Car(Args)) then
ada.text_io.put_line ("NON CLOSURE/PROCEDURE/CONTINUATION FOR CALL/CC");
raise Syntax_Error;
end if;
C := Make_Continuation (Interp.Self, Get_Frame_Parent(Interp.Stack));
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 ("Frame" & object_word'image(f) & " PUSH CONTINUATION CURRENT RESULT" & object_word'image(rw) & " ----> ");
print (interp, r);
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_Cons (Interp.Self, C, Nil_Pointer);
X := Make_Cons (Interp.Self, A, C);
C := Make_Cons (Interp.Self, Get_Car(Args), C);
declare
w: object_word;
for w'address use c'address;
f: object_word;
for f'address use interp.stack'address;
begin
ada.text_io.put (" PUSH CONTINUATION");
ada.text_io.put (object_word'image(w) & " ");
print (interp, c);
end;
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, X);
Set_Frame_Operand (Interp.Stack, C);
Clear_Frame_Result (Interp.Stack);
ada.text_io.put_line (" CLEARED RESULT BEFORE APPLYING");
Pop_Tops (Interp, 1);
end Apply_Callcc_Procedure;
procedure Apply_Continuation is
A: Object_Pointer;
R: Object_Pointer;
begin
-- TODO: gc aware
-- more argument check.
A := Get_Car(Args);
declare
w: object_word;
for w'address use func'address;
f: object_word;
for f'address use interp.stack'address;
begin
ada.text_io.put ("Frame" & object_word'image(f) & " POPING APPLY CONTINUATION -----> ");
ada.text_io.put (object_word'image(w) & " ");
end;
Print (Interp, Args);
ada.text_io.put (" CURRENT FREME RESULT " );
Print (Interp, get_Frame_result(interp.stack));
if not Is_Cons(Args) or else Get_Cdr(Args) /= Nil_Pointer then
Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CONTINUATION");
raise Syntax_Error;
end if;
-- Get the result of the continuation frame
-- R := Get_Frame_Result(Interp.Stack);
-- Restore the frame to the remembered one
Interp.Stack := Get_Continuation_Frame(Func);
declare
f: object_word;
for f'address use interp.stack'address;
begin
ada.text_io.put_line (" SWITCHED STACK TO FREME " & object_word'image(f) );
ada.text_io.put (" CURRENT RESULT " );
print (interp, get_Frame_result(interp.stack));
ada.text_io.put (" CURRENT OPERAND " );
print (interp, get_Frame_operand(interp.stack));
ada.text_io.put_line (" CURRENT OPCODE" & opcode_type'image(get_Frame_opcode(interp.stack)));
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));
-- if R /= Nil_Pointer then
--ada.text_io.put (" CARRY OVER RESULT ");
--print (interp, get_car(r));
-- Chain_Frame_Result (Interp, Interp.Stack, Get_Car(R));
-- end if;
--Set_Frame_Result (Interp.Stack, R);
--Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Args));
ada.text_io.put (" FINAL RESULT ");
print (interp, get_Frame_result(interp.stack));
-- if Get_Frame_Parent(Interp.Stack) /= Nil_Pointer then
-- Set_Frame_Result (Get_Frame_Parent(Interp.Stack), Get_Continuation_Save(Func));
-- --Set_Frame_Operand (Get_Frame_Parent(Interp.Stack), Get_Continuation_Save2(Func));
-- end if;
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
@ -417,8 +529,15 @@ begin
Operand := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Cons(Operand));
ada.text_io.put ("OPERAND TO APPLY => ");
Print (Interp, Operand);
declare
w: object_word;
for w'address use interp.stack'address;
begin
ada.text_io.put ("Frame" & object_word'image(w) & " OPERAND TO APPLY => ");
print (Interp, Operand);
ada.text_io.put (" CURRENT RESULT => ");
print (Interp, get_frame_result(interp.stack));
end;
Func := Get_Car(Operand);
if not Is_Normal_Pointer(Func) then
Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE");