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

changed implementation of procedure call and grouped call.

Browse Source 
still struggling with call-with-current-continuation
This commit is contained in:
hyung-hwan 2014-01-28 15:42:28 +00:00
parent 11143203af
commit 04aa5de83c
5 changed files with 411 additions and 252 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cmd/scheme.adb
View File

@ -41,6 +41,8 @@ begin
Stream.Deallocate_Stream'Access) Stream.Deallocate_Stream'Access)
); );
S.Set_Option (SI, (S.Trait_Option, S.No_Optimization));
File_Stream.Name := File_Name'Unchecked_Access; File_Stream.Name := File_Name'Unchecked_Access;
begin begin
S.Set_Input_Stream (SI, File_Stream); -- specify main input stream S.Set_Input_Stream (SI, File_Stream); -- specify main input stream

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

@ -28,7 +28,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CAR");
end if; end if;
Pop_Frame (Interp); -- Done with the current frame 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; end Apply_Car_Procedure;
procedure Apply_Cdr_Procedure is procedure Apply_Cdr_Procedure is
@ -47,7 +47,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CDR");
end if; end if;
Pop_Frame (Interp); -- Done with the current frame 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; end Apply_Cdr_Procedure;
procedure Apply_Cons_Procedure is 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 Ptr := Make_Cons (Interp.Self, A, B); -- change car
Pop_Frame (Interp); -- Done with the current frame 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; end Apply_Cons_Procedure;
procedure Apply_Setcar_Procedure is 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 Set_Car (A, B); -- change car
Pop_Frame (Interp); -- Done with the current frame 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; end Apply_Setcar_Procedure;
procedure Apply_Setcdr_Procedure is 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 Set_Cdr (A, B); -- change cdr
Pop_Frame (Interp); -- Done with the current frame 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; end Apply_Setcdr_Procedure;
-- ------------------------------------------------------------- -- -------------------------------------------------------------
@ -133,7 +133,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
end loop; end loop;
Pop_Frame (Interp); -- Done with the current frame 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; end Apply_Add_Procedure;
procedure Apply_Subtract_Procedure is procedure Apply_Subtract_Procedure is
@ -162,7 +162,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
end if; end if;
Pop_Frame (Interp); -- Done with the current frame 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; end Apply_Subtract_Procedure;
procedure Apply_Multiply_Procedure is procedure Apply_Multiply_Procedure is
@ -183,7 +183,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
end loop; end loop;
Pop_Frame (Interp); -- Done with the current frame 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; end Apply_Multiply_Procedure;
procedure Apply_Quotient_Procedure is procedure Apply_Quotient_Procedure is
@ -204,7 +204,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
end loop; end loop;
Pop_Frame (Interp); -- Done with the current frame 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; end Apply_Quotient_Procedure;
generic generic
@ -242,7 +242,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
end loop; end loop;
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Bool); Put_Frame_Result (Interp, Interp.Stack, Bool);
else else
Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
raise Syntax_Error; raise Syntax_Error;
@ -359,7 +359,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
end if; end if;
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); Set_Frame_Operand (Interp.Stack, Fbody);
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
@ -370,43 +370,155 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
-- Continuation -- Continuation
-- ------------------------------------------------------------- -- -------------------------------------------------------------
procedure Apply_Callcc_Procedure is function Is_Callcc_Friendly (A: Object_Pointer) return Standard.Boolean is
A: Object_Pointer; pragma Inline (Is_Callcc_Friendly);
C: Object_Pointer;
X: Object_Pointer;
begin begin
-- (define f (lambda (return) (return 2) 3)) return Is_Closure(A) or else Is_Procedure(A) or else Is_Continuation(A);
-- (f (lambda (x) x)) ; 3 end Is_Callcc_Friendly;
-- (call-with-current-continuation f) ; 2
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 if not Is_Cons(Args) or else Get_Cdr(Args) /= Nil_Pointer then
-- TODO: check others, extra arguments.. etc Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CALL/CC");
A := Get_Car(Args); raise Syntax_Error;
if not Is_Closure(A) then end if;
ada.text_io.put_line ("NON CLOSURE XXXXXXX");
if not Is_Callcc_Friendly(Get_Car(Args)) then
ada.text_io.put_line ("NON CLOSURE/PROCEDURE/CONTINUATION FOR CALL/CC");
raise Syntax_Error; raise Syntax_Error;
end if; 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); 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_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; end Apply_Callcc_Procedure;
procedure Apply_Continuation is procedure Apply_Continuation is
A: Object_Pointer; R: Object_Pointer;
begin begin
-- TODO: gc aware declare
-- more argument check. w: object_word;
A := Get_Car(Args); 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; end Apply_Continuation;
begin begin
@ -417,8 +529,15 @@ begin
Operand := Get_Frame_Operand(Interp.Stack); Operand := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Cons(Operand)); pragma Assert (Is_Cons(Operand));
ada.text_io.put ("OPERAND TO APPLY => "); declare
Print (Interp, Operand); 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); Func := Get_Car(Operand);
if not Is_Normal_Pointer(Func) then if not Is_Normal_Pointer(Func) then
Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE"); Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE");

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

@ -25,7 +25,7 @@ procedure Evaluate is
if Operand = Nil_Pointer then if Operand = Nil_Pointer then
-- (and) -- (and)
Pop_Frame (Interp); 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 elsif not Is_Cons(Operand) or else Get_Last_Cdr(Operand) /= Nil_Pointer then
-- (and . 10) -- (and . 10)
-- (and 1 2 . 10) -- (and 1 2 . 10)
@ -33,11 +33,11 @@ procedure Evaluate is
raise Syntax_Error; raise Syntax_Error;
else else
Set_Frame_Opcode (Interp.Stack, Opcode); Set_Frame_Opcode (Interp.Stack, Opcode);
Set_Frame_Operand (Interp.Stack, Get_Cdr(Operand)); -- <test2> onwards Set_Frame_Operand (Interp.Stack, Get_Cdr(Operand)); -- <test2> onwards
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
-- arrange to evaluate <test1> -- arrange to evaluate <test1>
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand)); Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand));
end if; end if;
end Generic_And_Or_Syntax; end Generic_And_Or_Syntax;
@ -77,6 +77,7 @@ procedure Evaluate is
-- Arrange to finish defining after value evaluation. -- Arrange to finish defining after value evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Define_Symbol); Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Define_Symbol);
Set_Frame_Operand (Interp.Stack, Car); Set_Frame_Operand (Interp.Stack, Car);
Clear_Frame_Result (Interp.Stack);
-- Arrange to evalaute the value part -- Arrange to evalaute the value part
Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); 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 <test> evaluation. -- Switch the current frame to execute action after <test> evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If_Syntax); Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If_Syntax);
Set_Frame_Operand (Interp.Stack, Operand); Set_Frame_Operand (Interp.Stack, Operand);
Clear_Frame_Result (Interp.Stack);
-- Arrange to evalaute the conditional -- Arrange to evalaute the conditional
Push_Frame (Interp, Opcode_Evaluate_Object, Car); Push_Frame (Interp, Opcode_Evaluate_Object, Car);
@ -216,7 +218,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
begin begin
Closure := Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack)); Closure := Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack));
Pop_Frame (Interp); -- Done Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Closure); Put_Frame_Result (Interp, Interp.Stack, Closure);
end; end;
end Evaluate_Lambda_Syntax; end Evaluate_Lambda_Syntax;
@ -242,9 +244,10 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if; end if;
Letbody := Get_Cdr(Operand); -- Cons cell to <body> Letbody := Get_Cdr(Operand); -- Cons cell to <body>
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)) )
-- (let ((x 2)) . 99) -- (let ((x 2)) . 99)
-- (let ((x 2)) (+ x 2) . 99)
Ada.Text_IO.Put_Line ("INVALID BODY FOR LET"); Ada.Text_IO.Put_Line ("INVALID BODY FOR LET");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
@ -308,6 +311,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
Set_Frame_Operand (Interp.Stack, Cdr); Set_Frame_Operand (Interp.Stack, Cdr);
Clear_Frame_Result (Interp.Stack);
-- Push a new environment onto the current frame. -- Push a new environment onto the current frame.
-- It's pushed even if <bindings> is empty because -- It's pushed even if <bindings> is empty because
@ -357,6 +361,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
Set_Frame_Operand (Interp.Stack, Cdr); Set_Frame_Operand (Interp.Stack, Cdr);
Clear_Frame_Result (Interp.Stack);
if Car /= Nil_Pointer then if Car /= Nil_Pointer then
-- <bindings> is not empty -- <bindings> is not empty
@ -378,6 +383,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
Set_Frame_Operand (Interp.Stack, Cdr); Set_Frame_Operand (Interp.Stack, Cdr);
Clear_Frame_Result (Interp.Stack);
-- Push a new environment. -- Push a new environment.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
@ -406,7 +412,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Pop_Frame (Interp); -- Done 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; end Evaluate_Quote_Syntax;
procedure Evaluate_Set_Syntax is procedure Evaluate_Set_Syntax is
@ -421,7 +427,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
-- e.g) (set!) -- e.g) (set!)
-- (set . 10) -- (set . 10)
-- (set x . 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; raise Syntax_Error;
end if; end if;
@ -429,14 +435,15 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Cdr := Get_Cdr(Operand); -- cons cell to <expression> Cdr := Get_Cdr(Operand); -- cons cell to <expression>
if Is_Symbol(Car) then if Is_Symbol(Car) then
if Get_Cdr(Cdr) /= Nil_Pointer 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; raise Syntax_Error;
end if; end if;
Cdr := Get_Car(Cdr); -- <expression> Cdr := Get_Car(Cdr); -- <expression>
-- Arrange to finish setting a variable after <expression> evaluation. -- Arrange to finish setting a variable after <expression> evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Set_Syntax); Set_Frame_Opcode (Interp.Stack, Opcode_Set_Finish);
Set_Frame_Operand (Interp.Stack, Car); Set_Frame_Operand (Interp.Stack, Car);
Clear_Frame_Result (Interp.Stack);
-- Arrange to evalaute the value part -- Arrange to evalaute the value part
Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); Push_Frame (Interp, Opcode_Evaluate_Object, Cdr);
@ -454,6 +461,18 @@ begin
<<Start_Over>> <<Start_Over>>
Operand := Get_Frame_Operand(Interp.Stack); 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 if not Is_Normal_Pointer(Operand) then
-- integer, character, specal pointers -- integer, character, specal pointers
-- TODO: some normal pointers may point to literal objects. e.g.) bignum -- TODO: some normal pointers may point to literal objects. e.g.) bignum
@ -487,29 +506,33 @@ begin
Evaluate_And_Syntax; Evaluate_And_Syntax;
when Begin_Syntax => when Begin_Syntax =>
Operand := Cdr; -- Skip "begin" Operand := Cdr; -- Skip "begin"
if not Is_Cons(Operand) then if Operand = Nil_Pointer then
-- e.g) (begin) -- (begin)
-- (begin . 10) Pop_Frame (Interp);
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN"); -- Return nil to the upper frame for (begin).
raise Syntax_Error; Put_Frame_Result (Interp, Interp.Stack, Nil_Pointer);
else else
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); if Get_Last_Cdr(Operand) /= Nil_Pointer then
Set_Frame_Operand (Interp.Stack, Operand); Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
raise Syntax_Error;
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; end if;
Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call);
Set_Frame_Operand (Interp.Stack, Operand);
Clear_Frame_Result (Interp.Stack);
end if; 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 => when Define_Syntax =>
Evaluate_Define_Syntax; Evaluate_Define_Syntax;
@ -543,79 +566,26 @@ begin
raise Internal_Error; raise Internal_Error;
end case; end case;
else else
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then -- procedure call
while not Is_Normal_Pointer(Car) loop -- (<operator> <operand1> ...)
-- This while block is for optimization only. It's not really needed. if Get_Last_Cdr(Operand) /= Nil_Pointer then
-- If I know that the next object to evaluate is a literal object, Ada.Text_IO.Put_Line ("ERROR: FUCKING CDR FOR PROCEDURE CALL.$$$$");
-- I can simply reverse-chain it to the return field of the current raise Syntax_Error;
-- 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 <<Literal>>.
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;
end if; end if;
if Is_Cons(Cdr) then -- Create a cons cell whose 'car' holds arguments and
-- Not the last cons cell yet -- 'cdr' holds evaluation results before applying them.
Set_Frame_Operand (Interp.Stack, Cdr); -- change the operand for the next call Cdr := Make_Cons (Interp.Self, Cdr, Nil_Pointer);
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;
-- Change the operand to a mark object so that the call to this -- Set it as a frame operand
-- procedure after the evaluation of the last car goes to the Set_Frame_Opcode (Interp.Stack, Opcode_Procedure_Call);
-- Mark_Object case. Set_Frame_Operand (Interp.Stack, Cdr);
Set_Frame_Operand (Interp.Stack, Interp.Mark); Clear_Frame_Result (Interp.Stack);
end if;
-- Arrange to evaluate the car object -- Arrange to evaluate <operator> first.
if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then Push_Frame (Interp, Opcode_Evaluate_Object, Car);
Push_Frame (Interp, Opcode_Evaluate_Object, Car);
goto Start_Over; -- for optimization only. not really needed.
end if;
end if; 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 => when others =>
-- normal literal object -- normal literal object
goto Literal; goto Literal;
@ -624,9 +594,14 @@ begin
<<Literal>> <<Literal>>
Pop_Frame (Interp); -- done 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); Print (Interp, Operand);
Chain_Frame_Result (Interp, Interp.Stack, Operand); end;
Put_Frame_Result (Interp, Interp.Stack, Operand);
goto Done; goto Done;
<<Done>> <<Done>>

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

@ -19,64 +19,6 @@ procedure Execute (Interp: in out Interpreter_Record) is
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object); Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object);
end Evaluate_Result; 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 generic
V: Object_Pointer; V: Object_Pointer;
@ -89,7 +31,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
X := Get_Frame_Operand(Interp.Stack); X := Get_Frame_Operand(Interp.Stack);
Y := Get_Frame_Result(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 <test1>. Y must not be Nil_Pointer even at the -- evaluate <test1>. Y must not be Nil_Pointer even at the
-- first time this procedure is called, -- first time this procedure is called,
pragma Assert (Is_Cons(Y)); pragma Assert (Is_Cons(Y));
@ -105,7 +47,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
else else
-- Return the result of the last expression evaluated. -- Return the result of the last expression evaluated.
Pop_Frame (Interp); Pop_Frame (Interp);
Chain_Frame_Result (Interp, Interp.Stack, Y); Put_Frame_Result (Interp, Interp.Stack, Y);
end if; end if;
end Evaluate_Up_To; end Evaluate_Up_To;
@ -131,7 +73,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
Put_Environment (Interp, X, Y); Put_Environment (Interp, X, Y);
Pop_Frame (Interp); -- Done Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Y); Put_Frame_Result (Interp, Interp.Stack, Y);
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Finish_Define_Symbol; end Finish_Define_Symbol;
@ -164,7 +106,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
else else
Pop_Frame (Interp); Pop_Frame (Interp);
-- Return nil if no <alternate> is specified -- Return nil if no <alternate> is specified
Chain_Frame_Result (Interp, Interp.Stack, Nil_Pointer); Put_Frame_Result (Interp, Interp.Stack, Nil_Pointer);
end if; end if;
else else
-- All values except #f are true values. evaluate <consequent> -- All values except #f are true values. evaluate <consequent>
@ -178,23 +120,99 @@ 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); procedure Do_Procedure_Call is
Set_Frame_Result (Interp.Stack, R); pragma Inline (Do_Procedure_Call);
ada.text_io.put_line ("resettting result"); X: aliased Object_Pointer;
print (interp, get_Frame_result(interp.stack)); S: aliased Object_Pointer;
end Do_Continuation_Finish; 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 <operator> evaluation frame
-- is pushed by Evaluate().
S := Get_Car(X);
R := Get_Cdr(X);
-- Threfore, the frame result is for <operator> 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 procedure Do_Let_Evaluation is
pragma Inline (Do_Let_Evaluation); pragma Inline (Do_Let_Evaluation);
@ -218,6 +236,7 @@ print (interp, get_Frame_result(interp.stack));
end if; end if;
end Do_Let_Evaluation; end Do_Let_Evaluation;
procedure Do_Let_Binding is procedure Do_Let_Binding is
pragma Inline (Do_Let_Binding); pragma Inline (Do_Let_Binding);
X: aliased Object_Pointer; X: aliased Object_Pointer;
@ -299,13 +318,14 @@ print (interp, get_Frame_result(interp.stack));
pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer); pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer);
-- Evaluate_Let_Syntax has places <body> in the operand of this frame. -- Evaluate_Let_Syntax has places <body> in the operand of this frame.
-- <body> can be evaluated as if it's in 'begin'. -- <body> 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; end Do_Let_Finish;
-- -------------------------------------------------------------------- -- --------------------------------------------------------------------
procedure Finish_Set_Syntax is procedure Do_Set_Finish is
pragma Inline (Finish_Set_Syntax); pragma Inline (Do_Set_Finish);
X: aliased Object_Pointer; X: aliased Object_Pointer;
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
begin begin
@ -314,6 +334,8 @@ print (interp, get_Frame_result(interp.stack));
X := Get_Frame_Operand(Interp.Stack); -- symbol X := Get_Frame_Operand(Interp.Stack); -- symbol
Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- value 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 (Is_Symbol(X));
pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer); pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
@ -323,10 +345,10 @@ print (interp, get_Frame_result(interp.stack));
end if; end if;
Pop_Frame (Interp); -- Done Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Y); Put_Frame_Result (Interp, Interp.Stack, Y);
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Finish_Set_Syntax; end Do_Set_Finish;
procedure Evaluate is separate; procedure Evaluate is separate;
procedure Apply is separate; procedure Apply is separate;
@ -867,6 +889,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
when others => when others =>
-- TODO: set various error info -- TODO: set various error info
Ada.Text_IO.Put_Line ("INFO: UNKNOWN TOKEN " & Token_Kind'Image(Interp.Token.Kind));
raise Syntax_Error; raise Syntax_Error;
end case; end case;
@ -951,9 +974,6 @@ begin
when Opcode_Evaluate_Object => when Opcode_Evaluate_Object =>
Evaluate; Evaluate;
when Opcode_Evaluate_Group =>
Evaluate_Group;
when Opcode_Finish_And_Syntax => when Opcode_Finish_And_Syntax =>
Finish_And_Syntax; -- Conditional Finish_And_Syntax; -- Conditional
@ -966,9 +986,10 @@ begin
when Opcode_Finish_If_Syntax => when Opcode_Finish_If_Syntax =>
Finish_If_Syntax; -- Conditional Finish_If_Syntax; -- Conditional
when Opcode_Continuation_Finish => when Opcode_Grouped_Call =>
Do_Continuation_Finish; Do_Grouped_Call;
when Opcode_Grouped_Call_Finish =>
Do_Grouped_Call_Finish;
when Opcode_Let_Binding => when Opcode_Let_Binding =>
Do_Let_Binding; Do_Let_Binding;
when Opcode_Letast_Binding => when Opcode_Letast_Binding =>
@ -978,12 +999,15 @@ begin
when Opcode_Let_Finish => when Opcode_Let_Finish =>
Do_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 => when Opcode_Finish_Or_Syntax =>
Finish_Or_Syntax; -- Conditional Finish_Or_Syntax; -- Conditional
when Opcode_Finish_Set_Syntax =>
Finish_Set_Syntax; -- Assignment
when Opcode_Apply => when Opcode_Apply =>
Apply; Apply;

95
lib/h2-scheme.adb
View File

@ -93,31 +93,31 @@ 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 .. 20; subtype Opcode_Type is Object_Integer range 0 .. 21;
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);
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply Opcode_Finish_And_Syntax: constant Opcode_Type := Opcode_Type'(3);
Opcode_Finish_And_Syntax: constant Opcode_Type := Opcode_Type'(4); Opcode_Finish_Define_Symbol: 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'(5);
Opcode_Finish_If_Syntax: constant Opcode_Type := Opcode_Type'(6); Opcode_Finish_Or_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_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_Apply: constant Opcode_Type := Opcode_Type'(15);
Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(10); Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(16);
Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(11); Opcode_Read_List: constant Opcode_Type := Opcode_Type'(17);
Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(12); Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(18);
Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(13); Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(19);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(20);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(14); Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(21);
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
@ -143,8 +143,10 @@ 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_Object_Size: constant Pointer_Object_Size := 3;
Continuation_Frame_Index: 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; procedure Set_New_Location (Object: in Object_Pointer;
Ptr: in Heap_Element_Pointer); Ptr: in Heap_Element_Pointer);
@ -1170,8 +1172,8 @@ Ada.Text_IO.Put_Line ("Make_String...");
return Frame.Pointer_Slot(Frame_Result_Index); return Frame.Pointer_Slot(Frame_Result_Index);
end Get_Frame_Result; end Get_Frame_Result;
procedure Set_Frame_Result (Frame: in out Object_Pointer; procedure Set_Frame_Result (Frame: in Object_Pointer;
Value: in Object_Pointer) is Value: in Object_Pointer) is
pragma Inline (Set_Frame_Result); pragma Inline (Set_Frame_Result);
pragma Assert (Is_Frame(Frame)); 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 -- but to set the result chain. so it can be useful
-- if you want to migrate a result chain from one frame -- if you want to migrate a result chain from one frame
-- to another. It's what this assertion is for. -- 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 begin
Frame.Pointer_Slot(Frame_Result_Index) := Value; Frame.Pointer_Slot(Frame_Result_Index) := Value;
end Set_Frame_Result; 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; procedure Chain_Frame_Result (Interp: in out Interpreter_Record;
Frame: in Object_Pointer; -- TODO: remove this parameter Frame: in Object_Pointer; -- TODO: remove this parameter
Value: in Object_Pointer) is Value: in Object_Pointer) is
@ -1207,6 +1220,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Interp.Stack.Pointer_Slot(Frame_Result_Index) := V; Interp.Stack.Pointer_Slot(Frame_Result_Index) := V;
end Chain_Frame_Result; end Chain_Frame_Result;
procedure Clear_Frame_Result (Frame: in Object_Pointer) is procedure Clear_Frame_Result (Frame: in Object_Pointer) is
begin begin
Frame.Pointer_Slot(Frame_Result_Index) := Nil_Pointer; 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; 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; Cont: Object_Pointer;
Aliased_Frame: aliased Object_Pointer := Frame; Aliased_Frame: aliased Object_Pointer := Frame;
Aliased_Save: aliased Object_Pointer := Save;
Aliased_Save2: aliased Object_Pointer := Save2;
begin begin
Push_Top (Interp.all, Aliased_Frame'Unchecked_Access); 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.Tag := Continuation_Object;
Cont.Pointer_Slot(Continuation_Frame_Index) := Aliased_Frame; 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); Pop_Tops (Interp.all, 1);
return Cont; return Cont;
end Make_Continuation; end Make_Continuation;
@ -1562,6 +1582,20 @@ Ada.Text_IO.Put_Line ("Make_String...");
return Cont.Pointer_Slot(Continuation_Frame_Index); return Cont.Pointer_Slot(Continuation_Frame_Index);
end Get_Continuation_Frame; 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 procedure Deinitialize_Heap (Interp: in out Interpreter_Record) is
begin begin
@ -1877,7 +1911,12 @@ Ada.Text_IO.Put_Line ("Make_String...");
Ada.Text_IO.Put ("#Closure"); Ada.Text_IO.Put ("#Closure");
when Continuation_Object => 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 => when Procedure_Object =>
Ada.Text_IO.Put ("#Procedure"); Ada.Text_IO.Put ("#Procedure");
@ -1891,7 +1930,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
elsif Atom.Tag = Mark_Object then elsif Atom.Tag = Mark_Object then
Ada.Text_IO.Put ("#INTERNAL MARK#"); Ada.Text_IO.Put ("#INTERNAL MARK#");
else else
Ada.Text_IO.Put ("#NOIMPL#"); Ada.Text_IO.Put ("#NOIMPL# => " & Object_Tag'Image(Atom.Tag));
end if; end if;
end case; end case;
end case; end case;