From 04aa5de83cbe9ecac678ede2e5adf707abb7f251 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Tue, 28 Jan 2014 15:42:28 +0000 Subject: [PATCH] changed implementation of procedure call and grouped call. still struggling with call-with-current-continuation --- cmd/scheme.adb | 2 + lib/h2-scheme-execute-apply.adb | 193 +++++++++++++++++++++------ lib/h2-scheme-execute-evaluate.adb | 167 ++++++++++------------- lib/h2-scheme-execute.adb | 206 ++++++++++++++++------------- lib/h2-scheme.adb | 95 +++++++++---- 5 files changed, 411 insertions(+), 252 deletions(-) diff --git a/cmd/scheme.adb b/cmd/scheme.adb index fe5efc1..ffaf818 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -41,6 +41,8 @@ begin Stream.Deallocate_Stream'Access) ); +S.Set_Option (SI, (S.Trait_Option, S.No_Optimization)); + File_Stream.Name := File_Name'Unchecked_Access; begin S.Set_Input_Stream (SI, File_Stream); -- specify main input stream diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index 5b45141..acc1208 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -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"); diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index e713c66..7a6b2bc 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -25,7 +25,7 @@ procedure Evaluate is if Operand = Nil_Pointer then -- (and) Pop_Frame (Interp); - Chain_Frame_Result (Interp, Interp.Stack, V); + Put_Frame_Result (Interp, Interp.Stack, V); elsif not Is_Cons(Operand) or else Get_Last_Cdr(Operand) /= Nil_Pointer then -- (and . 10) -- (and 1 2 . 10) @@ -33,11 +33,11 @@ procedure Evaluate is raise Syntax_Error; else Set_Frame_Opcode (Interp.Stack, Opcode); - Set_Frame_Operand (Interp.Stack, Get_Cdr(Operand)); -- onwards - Clear_Frame_Result (Interp.Stack); + Set_Frame_Operand (Interp.Stack, Get_Cdr(Operand)); -- onwards + Clear_Frame_Result (Interp.Stack); -- arrange to evaluate - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand)); + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand)); end if; end Generic_And_Or_Syntax; @@ -77,6 +77,7 @@ procedure Evaluate is -- Arrange to finish defining after value evaluation. Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Define_Symbol); Set_Frame_Operand (Interp.Stack, Car); + Clear_Frame_Result (Interp.Stack); -- Arrange to evalaute the value part Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); @@ -131,6 +132,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); -- Switch the current frame to execute action after evaluation. Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If_Syntax); Set_Frame_Operand (Interp.Stack, Operand); + Clear_Frame_Result (Interp.Stack); -- Arrange to evalaute the conditional Push_Frame (Interp, Opcode_Evaluate_Object, Car); @@ -216,7 +218,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); begin Closure := Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack)); Pop_Frame (Interp); -- Done - Chain_Frame_Result (Interp, Interp.Stack, Closure); + Put_Frame_Result (Interp, Interp.Stack, Closure); end; end Evaluate_Lambda_Syntax; @@ -242,9 +244,10 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); end if; Letbody := Get_Cdr(Operand); -- Cons cell to - if not Is_Cons(Letbody) then + if not Is_Cons(Letbody) or else Get_Last_Cdr(Letbody) /= Nil_Pointer then -- (let ((x 2)) ) -- (let ((x 2)) . 99) + -- (let ((x 2)) (+ x 2) . 99) Ada.Text_IO.Put_Line ("INVALID BODY FOR LET"); raise Syntax_Error; end if; @@ -308,6 +311,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Operand (Interp.Stack, Cdr); + Clear_Frame_Result (Interp.Stack); -- Push a new environment onto the current frame. -- It's pushed even if is empty because @@ -357,6 +361,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Operand (Interp.Stack, Cdr); + Clear_Frame_Result (Interp.Stack); if Car /= Nil_Pointer then -- is not empty @@ -378,6 +383,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Operand (Interp.Stack, Cdr); + Clear_Frame_Result (Interp.Stack); -- Push a new environment. Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); @@ -406,7 +412,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); raise Syntax_Error; end if; Pop_Frame (Interp); -- Done - Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand)); + Put_Frame_Result (Interp, Interp.Stack, Get_Car(Operand)); end Evaluate_Quote_Syntax; procedure Evaluate_Set_Syntax is @@ -421,7 +427,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); -- e.g) (set!) -- (set . 10) -- (set x . 10) - Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR SET"); + Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR SET!"); raise Syntax_Error; end if; @@ -429,14 +435,15 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Cdr := Get_Cdr(Operand); -- cons cell to if Is_Symbol(Car) then if Get_Cdr(Cdr) /= Nil_Pointer then - Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR set!"); + Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR SET!"); raise Syntax_Error; end if; Cdr := Get_Car(Cdr); -- -- Arrange to finish setting a variable after evaluation. - Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Set_Syntax); + Set_Frame_Opcode (Interp.Stack, Opcode_Set_Finish); Set_Frame_Operand (Interp.Stack, Car); + Clear_Frame_Result (Interp.Stack); -- Arrange to evalaute the value part Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); @@ -454,6 +461,18 @@ begin <> Operand := Get_Frame_Operand(Interp.Stack); +declare +f: object_word; +for f'address use interp.stack'address; +o: object_word; +for o'address use operand'address; +begin +ada.text_io.put ("Frame" & object_word'image(f) & " EVALUATE OPERAND" & object_word'image(o) & " "); +print (interp, operand); +ada.text_io.put (" CURRENT RESULT "); +print (interp, get_Frame_result(interp.stack)); +end; + if not Is_Normal_Pointer(Operand) then -- integer, character, specal pointers -- TODO: some normal pointers may point to literal objects. e.g.) bignum @@ -487,29 +506,33 @@ begin Evaluate_And_Syntax; when Begin_Syntax => - Operand := Cdr; -- Skip "begin" - if not Is_Cons(Operand) then - -- e.g) (begin) - -- (begin . 10) - Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN"); - raise Syntax_Error; - + if Operand = Nil_Pointer then + -- (begin) + Pop_Frame (Interp); + -- Return nil to the upper frame for (begin). + Put_Frame_Result (Interp, Interp.Stack, Nil_Pointer); else - Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); - Set_Frame_Operand (Interp.Stack, Operand); - - if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then - -- I call Evaluate_Group for optimization here. - Evaluate_Group; -- for optimization only. not really needed. - -- I can jump to Start_Over because Evaluate_Group called - -- above pushes an Opcode_Evaluate_Object frame. - pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Evaluate_Object); - goto Start_Over; -- for optimization only. not really needed. + if Get_Last_Cdr(Operand) /= Nil_Pointer then + Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN"); + raise Syntax_Error; end if; + + Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call); + Set_Frame_Operand (Interp.Stack, Operand); + Clear_Frame_Result (Interp.Stack); end if; + --if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then + -- -- I call Evaluate_Group for optimization here. + -- Evaluate_Group; -- for optimization only. not really needed. + -- -- I can jump to Start_Over because Evaluate_Group called + -- -- above pushes an Opcode_Evaluate_Object frame. + -- pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Evaluate_Object); + -- goto Start_Over; -- for optimization only. not really needed. + --end if; + when Define_Syntax => Evaluate_Define_Syntax; @@ -543,79 +566,26 @@ begin raise Internal_Error; end case; else - if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then - while not Is_Normal_Pointer(Car) loop - -- This while block is for optimization only. It's not really needed. - -- If I know that the next object to evaluate is a literal object, - -- I can simply reverse-chain it to the return field of the current - -- frame without pushing another frame dedicated for it. - - -- TODO: some normal pointers may point to a literal object. e.g.) bignum - -- then it can goto <>. - Chain_Frame_Result (Interp, Interp.Stack, Car); - if Is_Cons(Cdr) then - Operand := Cdr; - Car := Get_Car(Operand); - Cdr := Get_Cdr(Operand); - else - -- last cons - if Cdr /= Nil_Pointer then - -- The last CDR is not Nil. - Ada.Text_IO.Put_Line ("WARNING: $$$$$$$$$$$$$$$$$$$$$..FUCKING CDR.....................OPTIMIZATIN $$$$"); - raise Syntax_Error; - end if; - - Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack)); - Clear_Frame_Result (Interp.Stack); - Set_Frame_Opcode (Interp.Stack, Opcode_Apply); - Set_Frame_Operand (Interp.Stack, Operand); - goto Done; - end if; - end loop; + -- procedure call + -- ( ...) + if Get_Last_Cdr(Operand) /= Nil_Pointer then + Ada.Text_IO.Put_Line ("ERROR: FUCKING CDR FOR PROCEDURE CALL.$$$$"); + raise Syntax_Error; end if; - if Is_Cons(Cdr) then - -- Not the last cons cell yet - Set_Frame_Operand (Interp.Stack, Cdr); -- change the operand for the next call - else - -- Reached the last cons cell - if Cdr /= Nil_Pointer then - -- The last CDR is not Nil. - Ada.Text_IO.Put_Line ("WARNING: $$$$$$$$$$$$$$$$$$$$$..FUCKING CDR.....................$$$$"); - raise Syntax_Error; - end if; + -- Create a cons cell whose 'car' holds arguments and + -- 'cdr' holds evaluation results before applying them. + Cdr := Make_Cons (Interp.Self, Cdr, Nil_Pointer); - -- Change the operand to a mark object so that the call to this - -- procedure after the evaluation of the last car goes to the - -- Mark_Object case. - Set_Frame_Operand (Interp.Stack, Interp.Mark); - end if; + -- Set it as a frame operand + Set_Frame_Opcode (Interp.Stack, Opcode_Procedure_Call); + Set_Frame_Operand (Interp.Stack, Cdr); + Clear_Frame_Result (Interp.Stack); - -- Arrange to evaluate the car object - if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then - Push_Frame (Interp, Opcode_Evaluate_Object, Car); - goto Start_Over; -- for optimization only. not really needed. - end if; + -- Arrange to evaluate first. + Push_Frame (Interp, Opcode_Evaluate_Object, Car); end if; - when Mark_Object => - -- TODO: you can use the mark context to differentiate context - - -- Get the evaluation result stored in the current stack frame by - -- various sub-Opcode_Evaluate_Object frames. the return value - -- chain must be reversed Chain_Frame_Result reverse-chains values. - Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack)); - - -- Refresh the current stack frame to Opcode_Apply. - -- This should be faster than Popping the current frame and pushing - -- a new frame. - -- Envir := Get_Frame_Environment(Interp.Stack); - -- Pop_Frame (Interp); -- done - -- Push_Frame (Interp, Opcode_Apply, Operand, Envir); - Clear_Frame_Result (Interp.Stack); - Set_Frame_Opcode (Interp.Stack, Opcode_Apply); - Set_Frame_Operand (Interp.Stack, Operand); - when others => -- normal literal object goto Literal; @@ -624,9 +594,14 @@ begin <> Pop_Frame (Interp); -- done -Ada.Text_IO.Put ("Return => "); +declare +w: object_word; +for w'address use operand'address; +begin +Ada.Text_IO.Put ("Return => (" & object_word'image(w) & ") =>" ); Print (Interp, Operand); - Chain_Frame_Result (Interp, Interp.Stack, Operand); +end; + Put_Frame_Result (Interp, Interp.Stack, Operand); goto Done; <> diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 613a1e8..f2c127c 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -19,64 +19,6 @@ procedure Execute (Interp: in out Interpreter_Record) is Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object); end Evaluate_Result; - procedure Evaluate_Group is - pragma Inline (Evaluate_Group); - - Operand: aliased Object_Pointer; - Car: aliased Object_Pointer; - Cdr: aliased Object_Pointer; - begin - Push_Top (Interp, Operand'Unchecked_Access); - Push_Top (Interp, Car'Unchecked_Access); - Push_Top (Interp, Cdr'Unchecked_Access); - - Operand := Get_Frame_Operand(Interp.Stack); - pragma Assert (Is_Normal_Pointer(Operand)); - - case Operand.Tag is - when Cons_Object => - Car := Get_Car(Operand); - Cdr := Get_Cdr(Operand); - - if Is_Cons(Cdr) then - -- Let the current frame remember the next expression list - Set_Frame_Operand (Interp.Stack, Cdr); - else - if Cdr /= Nil_Pointer then - -- The last CDR is not Nil. - Ada.Text_IO.Put_Line ("$$$$..................FUCKING CDR. FOR GROUP....................$$$$"); - raise Syntax_Error; - end if; - - -- Change the operand to a mark object so that the call to this - -- procedure after the evaluation of the last car goes to the - -- Mark_Object case. - Set_Frame_Operand (Interp.Stack, Interp.Mark); - end if; - - -- Clear the return value from the previous expression. - Clear_Frame_Result (Interp.Stack); - - -- Arrange to evaluate the current expression - Push_Frame (Interp, Opcode_Evaluate_Object, Car); - - when Mark_Object => - Operand := Get_Frame_Result(Interp.Stack); - Pop_Frame (Interp); -- Done - - -- There must be only 1 return value chained in the Group frame. - pragma Assert (Get_Cdr(Operand) = Nil_Pointer); - - -- Transfer the only return value to the upper chain - Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand)); - - when others => - raise Internal_Error; - end case; - - Pop_Tops (Interp, 3); - end Evaluate_Group; - -- ---------------------------------------------------------------- generic V: Object_Pointer; @@ -89,7 +31,7 @@ procedure Execute (Interp: in out Interpreter_Record) is X := Get_Frame_Operand(Interp.Stack); Y := Get_Frame_Result(Interp.Stack); - -- Evaluate_And_Syntax/Evaluate-Or_Syntax has arranged to + -- Evaluate_And_Syntax/Evaluate_Or_Syntax has arranged to -- evaluate . Y must not be Nil_Pointer even at the -- first time this procedure is called, pragma Assert (Is_Cons(Y)); @@ -105,7 +47,7 @@ procedure Execute (Interp: in out Interpreter_Record) is else -- Return the result of the last expression evaluated. Pop_Frame (Interp); - Chain_Frame_Result (Interp, Interp.Stack, Y); + Put_Frame_Result (Interp, Interp.Stack, Y); end if; end Evaluate_Up_To; @@ -131,7 +73,7 @@ procedure Execute (Interp: in out Interpreter_Record) is Put_Environment (Interp, X, Y); Pop_Frame (Interp); -- Done - Chain_Frame_Result (Interp, Interp.Stack, Y); + Put_Frame_Result (Interp, Interp.Stack, Y); Pop_Tops (Interp, 2); end Finish_Define_Symbol; @@ -164,7 +106,7 @@ procedure Execute (Interp: in out Interpreter_Record) is else Pop_Frame (Interp); -- Return nil if no is specified - Chain_Frame_Result (Interp, Interp.Stack, Nil_Pointer); + Put_Frame_Result (Interp, Interp.Stack, Nil_Pointer); end if; else -- All values except #f are true values. evaluate @@ -178,23 +120,99 @@ 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_Procedure_Call is + pragma Inline (Do_Procedure_Call); + X: aliased Object_Pointer; + S: aliased Object_Pointer; + R: aliased Object_Pointer; + begin + Push_Top (Interp, X'Unchecked_Access); + Push_Top (Interp, S'Unchecked_Access); + Push_Top (Interp, R'Unchecked_Access); - -- -------------------------------------------------------------------- + X := Get_Frame_Operand(Interp.Stack); + pragma Assert (Is_Cons(X)); + + -- When this procedure is called for the first time, + -- the first argument must be at the head of the list that + -- 'S' points to. it's because evaluation frame + -- is pushed by Evaluate(). + S := Get_Car(X); + R := Get_Cdr(X); + -- Threfore, the frame result is for for the first call. + R := Make_Cons(Interp.Self, Get_Car(Get_Frame_Result(Interp.Stack)), R); + + Clear_Frame_Result (Interp.Stack); + if not Is_Cons(S) then + -- 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); + end Do_Procedure_Call; + + -- ---------------------------------------------------------------- + + procedure Do_Grouped_Call is + X: Object_Pointer; + begin + X := Get_Frame_Operand(Interp.Stack); + + pragma Assert (Is_Cons(X)); -- The caller must ensure this. + --if Is_Cons(X) then + Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call_Finish); + Set_Frame_Operand (Interp.Stack, Get_Cdr(X)); + Clear_Frame_Result (Interp.Stack); + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); + --else + -- -- Nothing to evaluate. + -- Pop_Frame (Interp); + -- Put_Frame_Result (Interp, Interp.Stack, Nil_Pointer); + --end if; + end Do_Grouped_Call; + + procedure Do_Grouped_Call_Finish is + X: Object_Pointer; + R: Object_Pointer; + begin + X := Get_Frame_Operand(Interp.Stack); + + if Is_Cons(X) then + Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call_Finish); + Set_Frame_Operand (Interp.Stack, Get_Cdr(X)); + Clear_Frame_Result (Interp.Stack); + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); + else + -- Nothing more to evaluate. + R := Get_Frame_Result(Interp.Stack); + +declare +w: object_word; +for w'address use interp.stack'address; +begin +ada.text_io.put ("Frame " & object_word'image(w) & " EVAL-GROUP RESULT "); +print (Interp, R); +end; + +-- There must be only 1 return value chained in the Group frame. +pragma Assert (Get_Cdr(R) = Nil_Pointer); + + Pop_Frame (Interp); + + -- Return the last result to the upper frame + Put_Frame_Result (Interp, Interp.Stack, Get_Car(R)); + end if; + end Do_Grouped_Call_Finish; + + -- ---------------------------------------------------------------- procedure Do_Let_Evaluation is pragma Inline (Do_Let_Evaluation); @@ -218,6 +236,7 @@ print (interp, get_Frame_result(interp.stack)); end if; end Do_Let_Evaluation; + procedure Do_Let_Binding is pragma Inline (Do_Let_Binding); X: aliased Object_Pointer; @@ -299,13 +318,14 @@ print (interp, get_Frame_result(interp.stack)); pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer); -- Evaluate_Let_Syntax has places in the operand of this frame. -- can be evaluated as if it's in 'begin'. - Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); + --Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); + Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call); end Do_Let_Finish; -- -------------------------------------------------------------------- - procedure Finish_Set_Syntax is - pragma Inline (Finish_Set_Syntax); + procedure Do_Set_Finish is + pragma Inline (Do_Set_Finish); X: aliased Object_Pointer; Y: aliased Object_Pointer; begin @@ -314,6 +334,8 @@ print (interp, get_Frame_result(interp.stack)); X := Get_Frame_Operand(Interp.Stack); -- symbol Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- value +ada.text_io.put ("%%%%% FINISH SET SYNTAX => "); +print (interp, Get_Frame_Result(Interp.Stack)); pragma Assert (Is_Symbol(X)); pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer); @@ -323,10 +345,10 @@ print (interp, get_Frame_result(interp.stack)); end if; Pop_Frame (Interp); -- Done - Chain_Frame_Result (Interp, Interp.Stack, Y); + Put_Frame_Result (Interp, Interp.Stack, Y); Pop_Tops (Interp, 2); - end Finish_Set_Syntax; + end Do_Set_Finish; procedure Evaluate is separate; procedure Apply is separate; @@ -867,6 +889,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN "); when others => -- TODO: set various error info +Ada.Text_IO.Put_Line ("INFO: UNKNOWN TOKEN " & Token_Kind'Image(Interp.Token.Kind)); raise Syntax_Error; end case; @@ -951,9 +974,6 @@ begin when Opcode_Evaluate_Object => Evaluate; - when Opcode_Evaluate_Group => - Evaluate_Group; - when Opcode_Finish_And_Syntax => Finish_And_Syntax; -- Conditional @@ -966,9 +986,10 @@ begin when Opcode_Finish_If_Syntax => Finish_If_Syntax; -- Conditional - when Opcode_Continuation_Finish => - Do_Continuation_Finish; - + when Opcode_Grouped_Call => + Do_Grouped_Call; + when Opcode_Grouped_Call_Finish => + Do_Grouped_Call_Finish; when Opcode_Let_Binding => Do_Let_Binding; when Opcode_Letast_Binding => @@ -978,12 +999,15 @@ begin when Opcode_Let_Finish => Do_Let_Finish; + when Opcode_Procedure_Call => + Do_Procedure_Call; + + when Opcode_Set_Finish => + Do_Set_Finish; -- Assignment + when Opcode_Finish_Or_Syntax => Finish_Or_Syntax; -- Conditional - when Opcode_Finish_Set_Syntax => - Finish_Set_Syntax; -- Assignment - when Opcode_Apply => Apply; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index c2720d2..6f5c3e3 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -93,31 +93,31 @@ package body H2.Scheme is subtype Moved_Object_Record is Object_Record (Moved_Object, 0); - subtype Opcode_Type is Object_Integer range 0 .. 20; + subtype Opcode_Type is Object_Integer range 0 .. 21; 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); - Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply - Opcode_Finish_And_Syntax: constant Opcode_Type := Opcode_Type'(4); - Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(5); - Opcode_Finish_If_Syntax: constant Opcode_Type := Opcode_Type'(6); - Opcode_Finish_Or_Syntax: constant Opcode_Type := Opcode_Type'(7); - Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(8); + Opcode_Finish_And_Syntax: constant Opcode_Type := Opcode_Type'(3); + Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4); + Opcode_Finish_If_Syntax: constant Opcode_Type := Opcode_Type'(5); + Opcode_Finish_Or_Syntax: constant Opcode_Type := Opcode_Type'(6); + Opcode_Grouped_Call: constant Opcode_Type := Opcode_Type'(7); -- (begin ...), closure apply, let body + 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_Let_Finish: constant Opcode_Type := Opcode_Type'(12); + Opcode_Procedure_Call: constant Opcode_Type := Opcode_Type'(13); + Opcode_Set_Finish: constant Opcode_Type := Opcode_Type'(14); - 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); + Opcode_Apply: constant Opcode_Type := Opcode_Type'(15); + Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(16); + Opcode_Read_List: constant Opcode_Type := Opcode_Type'(17); + Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(18); + Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(19); + Opcode_Close_List: constant Opcode_Type := Opcode_Type'(20); + Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(21); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -143,8 +143,10 @@ 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_Object_Size: constant Pointer_Object_Size := 3; 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); @@ -1170,8 +1172,8 @@ Ada.Text_IO.Put_Line ("Make_String..."); return Frame.Pointer_Slot(Frame_Result_Index); end Get_Frame_Result; - procedure Set_Frame_Result (Frame: in out Object_Pointer; - Value: in Object_Pointer) is + procedure Set_Frame_Result (Frame: in Object_Pointer; + Value: in Object_Pointer) is pragma Inline (Set_Frame_Result); pragma Assert (Is_Frame(Frame)); @@ -1179,11 +1181,22 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- but to set the result chain. so it can be useful -- if you want to migrate a result chain from one frame -- to another. It's what this assertion is for. - pragma Assert (Is_Cons(Value)); + pragma Assert (Value = Nil_Pointer or else Is_Cons(Value)); begin Frame.Pointer_Slot(Frame_Result_Index) := Value; end Set_Frame_Result; + procedure Put_Frame_Result (Interp: in out Interpreter_Record; + Frame: in Object_Pointer; -- TODO: remove this parameter + Value: in Object_Pointer) is + pragma Inline (Put_Frame_Result); + pragma Assert (Is_Frame(Frame)); + V: Object_Pointer; + begin + V := Make_Cons(Interp.Self, Value, Nil_Pointer); + Interp.Stack.Pointer_Slot(Frame_Result_Index) := V; + end Put_Frame_Result; + procedure Chain_Frame_Result (Interp: in out Interpreter_Record; Frame: in Object_Pointer; -- TODO: remove this parameter Value: in Object_Pointer) is @@ -1207,6 +1220,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Interp.Stack.Pointer_Slot(Frame_Result_Index) := V; end Chain_Frame_Result; + procedure Clear_Frame_Result (Frame: in Object_Pointer) is begin Frame.Pointer_Slot(Frame_Result_Index) := Nil_Pointer; @@ -1536,14 +1550,20 @@ Ada.Text_IO.Put_Line ("Make_String..."); ----------------------------------------------------------------------------- function Make_Continuation (Interp: access Interpreter_Record; - Frame: in Object_Pointer) return Object_Pointer is + Frame: in Object_Pointer; + Save: in Object_Pointer; + Save2: 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, Closure_Object_Size, Nil_Pointer); + 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; @@ -1562,6 +1582,20 @@ 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 @@ -1877,7 +1911,12 @@ Ada.Text_IO.Put_Line ("Make_String..."); Ada.Text_IO.Put ("#Closure"); when Continuation_Object => - Ada.Text_IO.Put ("#Continuation"); + declare + w: object_word; + for w'address use Atom'address; + begin + Ada.Text_IO.Put ("#Continuation[" & object_word'image(w) & "]"); + end; when Procedure_Object => Ada.Text_IO.Put ("#Procedure"); @@ -1891,7 +1930,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); elsif Atom.Tag = Mark_Object then Ada.Text_IO.Put ("#INTERNAL MARK#"); else - Ada.Text_IO.Put ("#NOIMPL#"); + Ada.Text_IO.Put ("#NOIMPL# => " & Object_Tag'Image(Atom.Tag)); end if; end case; end case;