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

fixed Procedure_Call handlers for proper continuation (not sure if this is a proper fix).

Browse Source 
fixed bugs caused by conflicts between an 'in out' parameter and GC.
shortened Pop_Frame()/Set_Frame_Result() to Return_Frame()
This commit is contained in:
hyung-hwan 2014-02-06 13:29:08 +00:00
parent c0ff07698d
commit 2262591205
6 changed files with 284 additions and 306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -27,8 +27,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CAR");
raise Evaluation_Error; raise Evaluation_Error;
end if; end if;
Pop_Frame (Interp); -- Done with the current frame Return_Frame (Interp, 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
@ -46,8 +45,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CDR");
raise Evaluation_Error; raise Evaluation_Error;
end if; end if;
Pop_Frame (Interp); -- Done with the current frame Return_Frame (Interp, 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
@ -64,8 +62,7 @@ Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CONS");
B := Get_Car(Get_Cdr(Ptr)); -- the second argument B := Get_Car(Get_Cdr(Ptr)); -- the second argument
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 Return_Frame (Interp, 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
@ -86,8 +83,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcar");
B := Get_Car(Get_Cdr(Ptr)); -- the second argument B := Get_Car(Get_Cdr(Ptr)); -- the second argument
Set_Car (A, B); -- change car Set_Car (A, B); -- change car
Pop_Frame (Interp); -- Done with the current frame Return_Frame (Interp, 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
@ -108,8 +104,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcdr");
B := Get_Car(Get_Cdr(Ptr)); -- the second argument B := Get_Car(Get_Cdr(Ptr)); -- the second argument
Set_Cdr (A, B); -- change cdr Set_Cdr (A, B); -- change cdr
Pop_Frame (Interp); -- Done with the current frame Return_Frame (Interp, A);
Put_Frame_Result (Interp, Interp.Stack, A);
end Apply_Setcdr_Procedure; end Apply_Setcdr_Procedure;
-- ------------------------------------------------------------- -- -------------------------------------------------------------
@ -132,8 +127,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
Ptr := Get_Cdr(Ptr); Ptr := Get_Cdr(Ptr);
end loop; end loop;
Pop_Frame (Interp); -- Done with the current frame Return_Frame (Interp, 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
@ -161,8 +155,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
end loop; end loop;
end if; end if;
Pop_Frame (Interp); -- Done with the current frame Return_Frame (Interp, 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
@ -182,8 +175,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
Ptr := Get_Cdr(Ptr); Ptr := Get_Cdr(Ptr);
end loop; end loop;
Pop_Frame (Interp); -- Done with the current frame Return_Frame (Interp, 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
@ -203,8 +195,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
Ptr := Get_Cdr(Ptr); Ptr := Get_Cdr(Ptr);
end loop; end loop;
Pop_Frame (Interp); -- Done with the current frame Return_Frame (Interp, Integer_To_Pointer(Num));
Put_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Quotient_Procedure; end Apply_Quotient_Procedure;
generic generic
@ -241,8 +232,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
Ptr := Get_Cdr(Ptr); Ptr := Get_Cdr(Ptr);
end loop; end loop;
Pop_Frame (Interp); -- Done with the current frame Return_Frame (Interp, 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,9 +349,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_Grouped_Call); Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Fbody, Nil_Pointer);
Set_Frame_Operand (Interp.Stack, Fbody);
Clear_Frame_Result (Interp.Stack);
Pop_Tops (Interp, 4); Pop_Tops (Interp, 4);
end Apply_Closure; end Apply_Closure;
@ -404,48 +392,28 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Push_Top (Interp, C'Unchecked_Access); Push_Top (Interp, C'Unchecked_Access); -- this is not needed. TOOD: remove this
C := Get_Frame_Parent(Interp.Stack); C := Make_Continuation (Interp.Self, Get_Frame_Parent(Interp.Stack));
declare declare
p: object_Pointer := get_frame_parent(interp.stack);
w: object_word; w: object_word;
for w'address use c'address; for w'address use p'address;
f: object_word;
for f'address use interp.stack'address;
r: object_pointer := get_frame_result(c);
begin begin
ada.text_io.put_line ("Frame" & object_word'image(f) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); ada.text_io.put_line ("making continuatination to " & object_word'image(w) & " opcode " & opcode_type'image(get_frame_opcode(p)));
ada.text_io.put (" CURRENT RESULT "); print (interp, get_Frame_operand(p));
print (interp, r); print (interp, get_Frame_intermediate(p));
ada.text_io.put_line (" PARENT FRAME " & object_word'image(w)); ada.text_io.put_line ("-----------------");
end; end;
C := Make_Continuation (Interp.Self, C);
C := Make_Cons (Interp.Self, C, Nil_Pointer);
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, C); Set_Frame_Operand (Interp.Stack, Get_Car(Args)); -- (call/cc xxx), xxx becomes this.
Set_Frame_Intermediate (Interp.Stack, Nil_Pointer); -- pass the continuation object
Chain_Frame_Intermediate (Interp, Interp.Stack, C); -- as an actual parameter. (xxx #continuation)
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
ada.text_io.put_line (" CLEARED RESULT BEFORE APPLYING");
Pop_Tops (Interp, 1); Pop_Tops (Interp, 1);
end Apply_Callcc_Procedure; end Apply_Callcc_Procedure;
procedure Apply_Continuation is procedure Apply_Continuation is
R: Object_Pointer;
begin begin
declare declare
w: object_word; w: object_word;
@ -465,11 +433,8 @@ Print (Interp, get_Frame_result(interp.stack));
raise Syntax_Error; raise Syntax_Error;
end if; end if;
-- Get the result of the continuation frame
-- R := Get_Frame_Result(Interp.Stack);
-- Restore the frame to the remembered one -- Restore the frame to the remembered one
Interp.Stack := Get_Continuation_Frame(Func); Interp.Stack := Get_Continuation_Frame(Func);
declare declare
f: object_word; f: object_word;
@ -480,32 +445,16 @@ ada.text_io.put (" CURRENT RESULT " );
print (interp, get_Frame_result(interp.stack)); print (interp, get_Frame_result(interp.stack));
ada.text_io.put (" CURRENT OPERAND " ); ada.text_io.put (" CURRENT OPERAND " );
print (interp, get_Frame_operand(interp.stack)); print (interp, get_Frame_operand(interp.stack));
ada.text_io.put (" CURRENT INTERMEDIATE " );
print (interp, get_Frame_intermediate(interp.stack));
ada.text_io.put_line (" CURRENT OPCODE " & opcode_type'image(get_Frame_opcode(interp.stack))); ada.text_io.put_line (" CURRENT OPCODE " & opcode_type'image(get_Frame_opcode(interp.stack)));
end; end;
Set_Frame_Result (Interp.Stack, Get_Car(Args));
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 "); ada.text_io.put (" FINAL RESULT ");
print (interp, get_Frame_result(interp.stack)); 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;
end Apply_Continuation; end Apply_Continuation;
begin begin
@ -514,7 +463,7 @@ begin
Push_Top (Interp, Args'Unchecked_Access); Push_Top (Interp, Args'Unchecked_Access);
Operand := Get_Frame_Operand(Interp.Stack); Operand := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Cons(Operand)); -- pragma Assert (Is_Cons(Operand));
declare declare
w: object_word; w: object_word;
@ -526,13 +475,15 @@ print (Interp, Operand);
ada.text_io.put (" CURRENT RESULT => "); ada.text_io.put (" CURRENT RESULT => ");
print (Interp, get_frame_result(interp.stack)); print (Interp, get_frame_result(interp.stack));
end; end;
Func := Get_Car(Operand); -- Func := Get_Car(Operand);
Func := Get_Frame_Operand(Interp.Stack);
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");
raise Evaluation_Error; raise Evaluation_Error;
end if; end if;
Args := Get_Cdr(Operand); -- Args := Get_Cdr(Operand);
Args := Get_Frame_Intermediate(Interp.Stack);
case Func.Tag is case Func.Tag is
when Procedure_Object => when Procedure_Object =>

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

@ -24,8 +24,7 @@ procedure Evaluate is
Operand := Cdr; -- Skip "And" Operand := Cdr; -- Skip "And"
if Operand = Nil_Pointer then if Operand = Nil_Pointer then
-- (and) -- (and)
Pop_Frame (Interp); Return_Frame (Interp, 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)
@ -213,13 +212,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
declare -- Create a closure object and return it the the upper frame.
Closure: Object_Pointer; Return_Frame (Interp, Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack)));
begin
Closure := Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack));
Pop_Frame (Interp); -- Done
Put_Frame_Result (Interp, Interp.Stack, Closure);
end;
end Evaluate_Lambda_Syntax; end Evaluate_Lambda_Syntax;
procedure Check_Let_Syntax is procedure Check_Let_Syntax is
@ -418,8 +412,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Ada.Text_IO.Put_LINE ("WRONG NUMBER OF ARGUMENTS FOR QUOTE"); Ada.Text_IO.Put_LINE ("WRONG NUMBER OF ARGUMENTS FOR QUOTE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Pop_Frame (Interp); -- Done Return_Frame (Interp, 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
@ -448,12 +441,12 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
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.
--Switch_Frame (Interp.Stack, Opcode_Set_Finish, Car); --Switch_Frame (Interp.Stack, Opcode_Set_Finish, Car, Nil_Pointer);
-- 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);
-- These 2 lines derives the same result as the 2 lines commented out above. -- These 2 lines derives the same result as the 2 lines commented out above.
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Cdr); Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Cdr, Nil_Pointer);
Push_Subframe (Interp, Opcode_Set_Finish, Car); Push_Subframe (Interp, Opcode_Set_Finish, Car);
else else
Ada.Text_IO.Put_LINE ("INVALID SYMBOL AFTER SET!"); Ada.Text_IO.Put_LINE ("INVALID SYMBOL AFTER SET!");
@ -518,16 +511,15 @@ end;
if Operand = Nil_Pointer then if Operand = Nil_Pointer then
-- (begin) -- (begin)
Pop_Frame (Interp);
-- Return nil to the upper frame for (begin). -- Return nil to the upper frame for (begin).
Put_Frame_Result (Interp, Interp.Stack, Nil_Pointer); Return_Frame (Interp, Nil_Pointer);
else else
if Get_Last_Cdr(Operand) /= Nil_Pointer then if Get_Last_Cdr(Operand) /= Nil_Pointer then
Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN"); Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Operand); Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Operand, Nil_Pointer);
end if; end if;
--if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then --if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then
@ -580,7 +572,7 @@ end;
end if; end if;
-- Switch the current frame to evaluate <operator> -- Switch the current frame to evaluate <operator>
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car); Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car, Nil_Pointer);
-- Push a new frame to evaluate arguments. -- Push a new frame to evaluate arguments.
Push_Subframe (Interp, Opcode_Procedure_Call, Cdr); Push_Subframe (Interp, Opcode_Procedure_Call, Cdr);
@ -593,7 +585,6 @@ end;
goto Done; goto Done;
<<Literal>> <<Literal>>
Pop_Frame (Interp); -- done
declare declare
w: object_word; w: object_word;
for w'address use operand'address; for w'address use operand'address;
@ -601,7 +592,7 @@ begin
Ada.Text_IO.Put ("Return => (" & object_word'image(w) & ") =>" ); Ada.Text_IO.Put ("Return => (" & object_word'image(w) & ") =>" );
Print (Interp, Operand); Print (Interp, Operand);
end; end;
Put_Frame_Result (Interp, Interp.Stack, Operand); Return_Frame (Interp, Operand);
goto Done; goto Done;
<<Done>> <<Done>>

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

@ -43,8 +43,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
else else
-- Return the result of the last expression evaluated. -- Return the result of the last expression evaluated.
Pop_Frame (Interp); Return_Frame (Interp, Y);
Put_Frame_Result (Interp, Interp.Stack, Y);
end if; end if;
end Evaluate_Up_To; end Evaluate_Up_To;
@ -54,10 +53,10 @@ procedure Execute (Interp: in out Interpreter_Record) is
procedure Finish_Define_Symbol is procedure Finish_Define_Symbol is
pragma Inline (Finish_Define_Symbol); pragma Inline (Finish_Define_Symbol);
X: aliased Object_Pointer; X: Object_Pointer;
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
begin begin
Push_Top (Interp, X'Unchecked_Access); -- Keep Y managed as Y is referenced beyond the gc point.
Push_Top (Interp, Y'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- symbol X := Get_Frame_Operand(Interp.Stack); -- symbol
@ -65,19 +64,16 @@ procedure Execute (Interp: in out Interpreter_Record) is
Y := Get_Frame_Result(Interp.Stack); -- value list Y := Get_Frame_Result(Interp.Stack); -- value list
Put_Environment (Interp, X, Y); Put_Environment (Interp, X, Y); -- gc point
Pop_Frame (Interp); -- Done Return_Frame (Interp, Y); -- Y is referenced here.
Put_Frame_Result (Interp, Interp.Stack, Y); Pop_Tops (Interp, 1); -- Unmanage Y
Pop_Tops (Interp, 2);
end Finish_Define_Symbol; end Finish_Define_Symbol;
procedure Finish_If_Syntax is procedure Finish_If_Syntax is
pragma Inline (Finish_If_Syntax); pragma Inline (Finish_If_Syntax);
X: aliased Object_Pointer; X: aliased Object_Pointer;
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
Z: aliased Object_Pointer;
begin begin
Push_Top (Interp, X'Unchecked_Access); Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access);
@ -97,9 +93,8 @@ procedure Execute (Interp: in out Interpreter_Record) is
Set_Frame_Operand (Interp.Stack, Get_Car(X)); Set_Frame_Operand (Interp.Stack, Get_Car(X));
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
else else
Pop_Frame (Interp);
-- Return nil if no <alternate> is specified -- Return nil if no <alternate> is specified
Put_Frame_Result (Interp, Interp.Stack, Nil_Pointer); Return_Frame (Interp, 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>
@ -117,27 +112,66 @@ procedure Execute (Interp: in out Interpreter_Record) is
procedure Do_Procedure_Call is procedure Do_Procedure_Call is
pragma Inline (Do_Procedure_Call); pragma Inline (Do_Procedure_Call);
X: aliased Object_Pointer; R: Object_Pointer;
R: aliased Object_Pointer; X: Object_Pointer;
begin begin
Push_Top (Interp, X'Unchecked_Access); -- Note: if you change the assignment order of R and X,
Push_Top (Interp, R'Unchecked_Access); -- Push_Top() and Pop_Tops() are needed.
--Push_Top (Interp, X'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); --Push_Top (Interp, R'Unchecked_Access);
R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Get_Frame_Intermediate(Interp.Stack)); R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Get_Frame_Intermediate(Interp.Stack));
X := Get_Frame_Operand(Interp.Stack);
if Is_Cons(X) then if Is_Cons(X) then
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X)); Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer);
Push_Subframe_With_Intermediate (Interp, Opcode_Procedure_Call, Get_Cdr(X), R); Push_Subframe_With_Intermediate (Interp, Opcode_Procedure_Call, Get_Cdr(X), R);
else else
-- no more argument to evaluate. -- no more argument to evaluate.
-- apply the evaluated arguments to the evaluated operator. -- apply the evaluated arguments to the evaluated operator.
Switch_Frame (Interp.Stack, Opcode_Apply, Reverse_Cons(R)); R := Reverse_Cons(R);
--ada.text_io.put_line ("xxxxxxxxxxxxxxxxxx");
--print (interp, r);
--print (interp, get_car(r));
--print (interp, get_cdr(r));
--ada.text_io.put_line ("xxxxxxxxxxxxxxxxxx");
-- This frame can be resumed. Switching the current frame to Opcode_Apply
-- affects continuation objects that point to the current frame. However,
-- keeping it unchanged causes this frame to repeat actions that has been
-- taken previously when it's resumed. So i change the frame to something
-- special designed for continuation only.
Switch_Frame (Interp.Stack, Opcode_Procedure_Call_Finish, Get_Car(R), Nil_Pointer);
Pop_Frame (Interp);
-- Replace the current frame popped by a new applying frame.
Push_Frame_With_Intermediate (Interp, Opcode_Apply, Get_Car(R), Get_Cdr(R));
end if; end if;
Pop_Tops (Interp, 2); --Pop_Tops (Interp, 2);
end Do_Procedure_Call; end Do_Procedure_Call;
procedure Do_Procedure_Call_Finish is
pragma Inline (Do_Procedure_Call_Finish);
R: Object_Pointer;
X: Object_Pointer;
begin
-- TODO: is this really correct? verify this.
-- Note: if you change the assignment order of R and X,
-- Push_Top() and Pop_Tops() are needed.
--Push_Top (Interp, X'Unchecked_Access);
--Push_Top (Interp, R'Unchecked_Access);
R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Nil_Pointer);
X := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Continuation(X)); -- this procedure can be called for continuation only.
Pop_Frame (Interp);
Push_Frame_With_Intermediate (Interp, Opcode_Apply, X, R);
--Pop_Tops (Interp, 2);
end Do_Procedure_Call_Finish;
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
procedure Do_Grouped_Call is procedure Do_Grouped_Call is
@ -149,7 +183,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
pragma Assert (Is_Cons(X)); -- The caller must ensure this. pragma Assert (Is_Cons(X)); -- The caller must ensure this.
-- Switch the current frame to evaluate the first -- Switch the current frame to evaluate the first
-- expression in the group. -- expression in the group.
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X)); Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer);
X := Get_Cdr(X); X := Get_Cdr(X);
if Is_Cons(X) then if Is_Cons(X) then
@ -333,8 +367,7 @@ print (interp, Get_Frame_Result(Interp.Stack));
raise Evaluation_Error; raise Evaluation_Error;
end if; end if;
Pop_Frame (Interp); -- Done Return_Frame (Interp, Y);
Put_Frame_Result (Interp, Interp.Stack, Y);
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Do_Set_Finish; end Do_Set_Finish;
@ -342,6 +375,8 @@ print (interp, Get_Frame_Result(Interp.Stack));
procedure Evaluate is separate; procedure Evaluate is separate;
procedure Apply is separate; procedure Apply is separate;
-- --------------------------------------------------------------------
procedure Unfetch_Character is procedure Unfetch_Character is
pragma Inline (Unfetch_Character); pragma Inline (Unfetch_Character);
pragma Assert (not Interp.LC_Unfetched); pragma Assert (not Interp.LC_Unfetched);
@ -672,33 +707,15 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
Push_Frame (Interp, Opcode_Close_Quote_In_List, Nil_Pointer); Push_Frame (Interp, Opcode_Close_Quote_In_List, Nil_Pointer);
Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer); Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
when Integer_Token =>
-- TODO: bignum
V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when Character_Token =>
pragma Assert (Interp.Token.Value.Last = 1);
V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1));
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when String_Token =>
V := Make_String(Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when Identifier_Token =>
V := Make_Symbol(Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when True_Token =>
Chain_Frame_Intermediate (Interp, Interp.Stack, True_Pointer);
when False_Token =>
Chain_Frame_Intermediate (Interp, Interp.Stack, False_Pointer);
when others => when others =>
-- TODO: set various error info V := Token_To_Pointer (Interp.Self, Interp.Token);
raise Syntax_Error; if V = null then
-- TODO: set various error info
raise Syntax_Error;
else
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
end if;
end case; end case;
end Read_List; end Read_List;
@ -729,39 +746,16 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
Push_Frame (Interp, Opcode_Close_Quote_In_List, Nil_Pointer); Push_Frame (Interp, Opcode_Close_Quote_In_List, Nil_Pointer);
Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer); Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
when Integer_Token =>
-- TODO: bignum
V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when Character_Token =>
pragma Assert (Interp.Token.Value.Last = 1);
V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1));
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when Identifier_Token =>
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
when True_Token =>
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Intermediate (Interp, Interp.Stack, True_Pointer);
when False_Token =>
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Intermediate (Interp, Interp.Stack, False_Pointer);
when others => when others =>
-- TODO: set various error info V := Token_To_Pointer (Interp.Self, Interp.Token);
raise Syntax_Error; if V = null then
-- TODO: set various error info
raise Syntax_Error;
else
Chain_Frame_Intermediate (Interp, Interp.Stack, V);
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
end if;
end case; end case;
end Read_List_Cdr; end Read_List_Cdr;
@ -775,7 +769,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
case Interp.Token.Kind is case Interp.Token.Kind is
when Right_Parenthesis_Token => when Right_Parenthesis_Token =>
V := Get_Frame_Intermediate(Interp.Stack); V := Get_Frame_Intermediate(Interp.Stack);
pragma Assert (V /= Nil_Pointer); pragma Assert (Is_Cons(V));
-- The first item in the chain is actually Cdr of the last cell. -- The first item in the chain is actually Cdr of the last cell.
V := Reverse_Cons(Get_Cdr(V), Get_Car(V)); V := Reverse_Cons(Get_Cdr(V), Get_Car(V));
Pop_Frame (Interp); Pop_Frame (Interp);
@ -792,8 +786,9 @@ Ada.Text_IO.Put_Line ("Right parenthesis expected");
V: Object_Pointer; V: Object_Pointer;
begin begin
V := Get_Frame_Intermediate(Interp.Stack); V := Get_Frame_Intermediate(Interp.Stack);
Pop_Frame (Interp); pragma Assert (Is_Cons(V));
Set_Frame_Result (Interp.Stack, Get_Car(V)); pragma Assert (Get_Cdr(V) = Nil_Pointer); -- only 1 item as it's used for the top-level list only
Return_Frame (Interp, Get_Car(V));
end Close_List; end Close_List;
procedure Close_Quote_In_List is procedure Close_Quote_In_List is
@ -814,8 +809,7 @@ Ada.Text_IO.Put_Line ("Right parenthesis expected");
V := Get_Frame_Result(Interp.Stack); V := Get_Frame_Result(Interp.Stack);
V := Make_Cons(Interp.Self, V, Nil_Pointer); V := Make_Cons(Interp.Self, V, Nil_Pointer);
V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V); V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V);
Pop_Frame (Interp); Return_Frame (Interp, V);
Set_Frame_Result (Interp.Stack, V);
end Close_Quote; end Close_Quote;
procedure Read_Object is procedure Read_Object is
@ -837,46 +831,24 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
Set_Frame_Opcode (Interp.Stack, Opcode_Close_Quote); Set_Frame_Opcode (Interp.Stack, Opcode_Close_Quote);
Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer); Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
when Integer_Token =>
-- TODO: bignum
V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Pop_Frame (Interp); -- Done with the current frame
Set_Frame_Result (Interp.Stack, V);
when Character_Token =>
pragma Assert (Interp.Token.Value.Last = 1);
V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1));
Pop_Frame (Interp); -- Done with the current frame
Set_Frame_Result (Interp.Stack, V);
when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Pop_Frame (Interp); -- Done with the current frame
Set_Frame_Result (Interp.Stack, V);
when Identifier_Token =>
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Pop_Frame (Interp); -- Done with the current frame
Set_Frame_Result (Interp.Stack, V);
when True_Token =>
Pop_Frame (Interp); -- Done with the current frame
Set_Frame_Result (Interp.Stack, True_Pointer);
when False_Token =>
Pop_Frame (Interp); -- Done with the current frame
Set_Frame_Result (Interp.Stack, False_Pointer);
when others => when others =>
-- TODO: set various error info V := Token_To_Pointer (Interp.Self, Interp.Token);
if V = null then
-- TODO: set various error info
Ada.Text_IO.Put_Line ("INFO: UNKNOWN TOKEN " & Token_Kind'Image(Interp.Token.Kind)); Ada.Text_IO.Put_Line ("INFO: UNKNOWN TOKEN " & Token_Kind'Image(Interp.Token.Kind));
raise Syntax_Error; raise Syntax_Error;
else
Return_Frame (Interp, V);
end if;
end case; end case;
end Read_Object; end Read_Object;
-- --------------------------------------------------------------------
begin begin
-- TODO: This comment is out-dated. Update it with Intermediate.
-- Stack frames looks like this upon initialization -- Stack frames looks like this upon initialization
-- --
-- | Opcode | Operand | Result -- | Opcode | Operand | Result
@ -940,7 +912,7 @@ begin
pragma Assert (Interp.Stack /= Nil_Pointer); pragma Assert (Interp.Stack /= Nil_Pointer);
-- The caller must ensure there are no temporary object pointers. -- The caller must ensure there are no temporary object pointers.
pragma Assert (Interp.Top.Last < Interp.Top.Data'First); --pragma Assert (Interp.Top.Last < Interp.Top.Data'First);
loop loop
ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
@ -982,6 +954,8 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
when Opcode_Procedure_Call => when Opcode_Procedure_Call =>
Do_Procedure_Call; Do_Procedure_Call;
when Opcode_Procedure_Call_Finish =>
Do_Procedure_Call_Finish;
when Opcode_Set_Finish => when Opcode_Set_Finish =>
Do_Set_Finish; -- Assignment Do_Set_Finish; -- Assignment

1
lib/h2-scheme-token.adb
View File

@ -130,5 +130,4 @@ package body Token is
Append_Buffer (Interp, Interp.Token.Value, Tmp); Append_Buffer (Interp, Interp.Token.Value, Tmp);
end Append_Character; end Append_Character;
end Token; end Token;

219
lib/h2-scheme.adb
View File

@ -109,6 +109,7 @@ package body H2.Scheme is
Opcode_Let_Evaluation, Opcode_Let_Evaluation,
Opcode_Let_Finish, Opcode_Let_Finish,
Opcode_Procedure_Call, Opcode_Procedure_Call,
Opcode_Procedure_Call_Finish,
Opcode_Set_Finish, Opcode_Set_Finish,
Opcode_Apply, Opcode_Apply,
@ -413,6 +414,35 @@ package body H2.Scheme is
return Integer_To_Pointer(Opcode_Type'Pos(Opcode)); return Integer_To_Pointer(Opcode_Type'Pos(Opcode));
end Opcode_To_Pointer; end Opcode_To_Pointer;
function Token_To_Pointer (Interp: access Interpreter_Record;
Token: in Token_Record) return Object_Pointer is
begin
case Token.Kind is
when Integer_Token =>
-- TODO: bignum
return String_To_Integer_Pointer(Token.Value.Ptr.all(1..Token.Value.Last));
when Character_Token =>
pragma Assert (Token.Value.Last = 1);
return Character_To_Pointer(Token.Value.Ptr.all(1));
when String_Token =>
return Make_String (Interp, Token.Value.Ptr.all(1..Token.Value.Last));
when Identifier_Token =>
return Make_Symbol (Interp, Token.Value.Ptr.all(1..Token.Value.Last));
when True_Token =>
return True_Pointer;
when False_Token =>
return False_Pointer;
when others =>
return null;
end case;
end Token_To_Pointer;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- MEMORY MANAGEMENT -- MEMORY MANAGEMENT
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@ -724,6 +754,7 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
begin begin
Ada.Text_IO.Put_LINE ("GC RUNNING");
--declare --declare
--Avail: Heap_Size; --Avail: Heap_Size;
--begin --begin
@ -1143,21 +1174,20 @@ Ada.Text_IO.Put_Line ("Make_String...");
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
function Make_Frame (Interp: access Interpreter_Record; function Make_Frame (Interp: access Interpreter_Record;
Stack: in Object_Pointer; -- current stack pointer Parent: in Object_Pointer; -- current stack pointer
Opcode: in Object_Pointer; Opcode: in Object_Pointer;
Operand: in Object_Pointer; Operand: in Object_Pointer;
Envir: in Object_Pointer; Envir: in Object_Pointer;
Interm: in Object_Pointer) return Object_Pointer is Interm: in Object_Pointer) return Object_Pointer is
Frame: Object_Pointer; Frame: Object_Pointer;
Aliased_Stack: aliased Object_Pointer := Stack; Aliased_Parent: aliased Object_Pointer := Parent;
Aliased_Opcode: aliased Object_Pointer := Opcode; Aliased_Opcode: aliased Object_Pointer := Opcode;
Aliased_Operand: aliased Object_Pointer := Operand; Aliased_Operand: aliased Object_Pointer := Operand;
Aliased_Envir: aliased Object_Pointer := Envir; Aliased_Envir: aliased Object_Pointer := Envir;
Aliased_Interm: aliased Object_Pointer := Interm; Aliased_Interm: aliased Object_Pointer := Interm;
begin begin
Push_Top (Interp.all, Aliased_Parent'Unchecked_Access);
Push_Top (Interp.all, Aliased_Stack'Unchecked_Access);
Push_Top (Interp.all, Aliased_Opcode'Unchecked_Access); Push_Top (Interp.all, Aliased_Opcode'Unchecked_Access);
Push_Top (Interp.all, Aliased_Operand'Unchecked_Access); Push_Top (Interp.all, Aliased_Operand'Unchecked_Access);
Push_Top (Interp.all, Aliased_Envir'Unchecked_Access); Push_Top (Interp.all, Aliased_Envir'Unchecked_Access);
@ -1167,12 +1197,11 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- Since it's used for stack, it can be made special. -- Since it's used for stack, it can be made special.
Frame := Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer); Frame := Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer);
Frame.Tag := Frame_Object; Frame.Tag := Frame_Object;
Frame.Pointer_Slot(Frame_Parent_Index) := Aliased_Stack; Frame.Pointer_Slot(Frame_Parent_Index) := Aliased_Parent;
Frame.Pointer_Slot(Frame_Opcode_Index) := Aliased_Opcode; Frame.Pointer_Slot(Frame_Opcode_Index) := Aliased_Opcode;
Frame.Pointer_Slot(Frame_Operand_Index) := Aliased_Operand; Frame.Pointer_Slot(Frame_Operand_Index) := Aliased_Operand;
Frame.Pointer_Slot(Frame_Environment_Index) := Aliased_Envir; Frame.Pointer_Slot(Frame_Environment_Index) := Aliased_Envir;
Frame.Pointer_Slot(Frame_Intermediate_Index) := Aliased_Interm; Frame.Pointer_Slot(Frame_Intermediate_Index) := Aliased_Interm;
--Print_Object_Pointer ("Make_Frame Result - ", Result);
Pop_Tops (Interp.all, 5); Pop_Tops (Interp.all, 5);
return Frame; return Frame;
@ -1244,15 +1273,6 @@ Ada.Text_IO.Put_Line ("Make_String...");
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));
begin
Interp.Stack.Pointer_Slot(Frame_Result_Index) := Value;
end Put_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;
@ -1310,14 +1330,23 @@ Ada.Text_IO.Put_Line ("Make_String...");
return Frame.Pointer_Slot(Frame_Parent_Index); return Frame.Pointer_Slot(Frame_Parent_Index);
end Get_Frame_Parent; end Get_Frame_Parent;
procedure Set_Frame_Parent (Frame: in Object_Pointer;
Value: in Object_Pointer) is
pragma Inline (Set_Frame_Parent);
pragma Assert (Is_Frame(Frame));
begin
Frame.Pointer_Slot(Frame_Parent_Index) := Value;
end Set_Frame_Parent;
procedure Switch_Frame (Frame: in Object_Pointer; procedure Switch_Frame (Frame: in Object_Pointer;
Opcode: in Opcode_Type; Opcode: in Opcode_Type;
Operand: in Object_Pointer) is Operand: in Object_Pointer;
Interm: in Object_Pointer) is
begin begin
Set_Frame_Opcode (Frame, Opcode); Set_Frame_Opcode (Frame, Opcode);
Set_Frame_Operand (Frame, Operand); Set_Frame_Operand (Frame, Operand);
Set_Frame_Intermediate (Frame, Interm);
Set_Frame_Result (Frame, Nil_Pointer); Set_Frame_Result (Frame, Nil_Pointer);
--Set_Frame_Intermediate (Frame, Nil_Pointer);
end Switch_Frame; end Switch_Frame;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@ -2023,9 +2052,11 @@ Ada.Text_IO.Put_Line ("Make_String...");
begin begin
if DEBUG_GC then if DEBUG_GC then
ADA.TEXT_IO.PUT_LINE ("XXXXXXXXXXXXXXXXXXXXXXXXX NO PROINTING XXXXXXXXXXXXXXXXXXXXXXXxxx"); Print_Object (Source); -- use a recursive version
Ada.Text_IO.New_Line;
return; return;
end if; end if;
-- TODO: Let Make_Frame use a dedicated stack space that's apart from the heap. -- TODO: Let Make_Frame use a dedicated stack space that's apart from the heap.
-- This way, the stack frame doesn't have to be managed by GC. -- This way, the stack frame doesn't have to be managed by GC.
@ -2038,69 +2069,68 @@ end if;
loop loop
case Opcode is case Opcode is
when 1 => when 1 =>
if Is_Cons(Operand) then if Is_Cons(Operand) then
-- push cdr -- push cdr
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push cdr Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push cdr
Ada.Text_IO.Put ("("); Ada.Text_IO.Put ("(");
Operand := Get_Car(Operand); Operand := Get_Car(Operand);
Opcode := 1; Opcode := 1;
else
Print_Atom (Operand);
if Stack = Nil_Pointer then
Opcode := 0; -- stack empty. arrange to exit
Operand := True_Pointer; -- return value
else else
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
Operand := Stack.Pointer_Slot(Frame_Operand_Index);
Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop
end if;
end if;
when 2 =>
if Is_Cons(Operand) then
-- push cdr
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push
Ada.Text_IO.Put (" ");
Operand := Get_Car(Operand); -- car
Opcode := 1;
else
if Operand /= Nil_Pointer then
-- cdr of the last cons cell is not null.
Ada.Text_IO.Put (" . ");
Print_Atom (Operand); Print_Atom (Operand);
if Stack = Nil_Pointer then
Opcode := 0; -- stack empty. arrange to exit
Operand := True_Pointer; -- return value
else
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
Operand := Stack.Pointer_Slot(Frame_Operand_Index);
Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop
end if;
end if; end if;
Ada.Text_IO.Put (")");
if Stack = Nil_Pointer then when 2 =>
Opcode := 0; -- stack empty. arrange to exit
if Is_Cons(Operand) then
-- push cdr
Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push
Ada.Text_IO.Put (" ");
Operand := Get_Car(Operand); -- car
Opcode := 1;
else else
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); if Operand /= Nil_Pointer then
Operand := Stack.Pointer_Slot(Frame_Operand_Index); -- cdr of the last cons cell is not null.
Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop Ada.Text_IO.Put (" . ");
end if; Print_Atom (Operand);
end if; end if;
Ada.Text_IO.Put (")");
when others => if Stack = Nil_Pointer then
exit; Opcode := 0; -- stack empty. arrange to exit
else
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
Operand := Stack.Pointer_Slot(Frame_Operand_Index);
Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop
end if;
end if;
when others =>
exit;
end case; end case;
end loop; end loop;
--Print_Object (Source);
Ada.Text_IO.New_Line; Ada.Text_IO.New_Line;
end Print; end Print;
procedure Insert_Frame (Interp: in out Interpreter_Record; function Insert_Frame (Interp: access Interpreter_Record;
Parent: in out Object_Pointer; Parent: in Object_Pointer;
Opcode: in Opcode_Type; Opcode: in Opcode_Type;
Operand: in Object_Pointer; Operand: in Object_Pointer;
Envir: in Object_Pointer; Envir: in Object_Pointer;
Interm: in Object_Pointer) is Interm: in Object_Pointer) return Object_Pointer is
pragma Inline (Insert_Frame); pragma Inline (Insert_Frame);
pragma Assert (Parent = Nil_Pointer or else Is_Frame(Parent)); pragma Assert (Parent = Nil_Pointer or else Is_Frame(Parent));
begin begin
Parent := Make_Frame(Interp.Self, Parent, Opcode_To_Pointer(Opcode), Operand, Envir, Interm); return Make_Frame(Interp, Parent, Opcode_To_Pointer(Opcode), Operand, Envir, Interm);
end Insert_Frame; end Insert_Frame;
procedure Push_Frame (Interp: in out Interpreter_Record; procedure Push_Frame (Interp: in out Interpreter_Record;
@ -2108,9 +2138,7 @@ end if;
Operand: in Object_Pointer) is Operand: in Object_Pointer) is
pragma Inline (Push_Frame); pragma Inline (Push_Frame);
begin begin
--Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Interp.Stack :=Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer);
-- Operand, Get_Frame_Environment(Interp.Stack));
Insert_Frame (Interp, Interp.Stack, Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer);
end Push_Frame; end Push_Frame;
procedure Push_Frame_With_Environment (Interp: in out Interpreter_Record; procedure Push_Frame_With_Environment (Interp: in out Interpreter_Record;
@ -2119,19 +2147,26 @@ end if;
Envir: in Object_Pointer) is Envir: in Object_Pointer) is
pragma Inline (Push_Frame_With_Environment); pragma Inline (Push_Frame_With_Environment);
begin begin
--Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Envir, Nil_Pointer);
-- Operand, Envir);
Insert_Frame (Interp, Interp.Stack, Opcode, Operand, Envir, Nil_Pointer);
end Push_Frame_With_Environment; end Push_Frame_With_Environment;
procedure Push_Frame_With_Intermediate (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
Interm: in Object_Pointer) is
pragma Inline (Push_Frame_With_Intermediate);
begin
-- Place a new frame below the existing top frame.
Interp.Stack := Insert_Frame (Interp.Self, Interp.Stack, Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm);
end Push_Frame_With_Intermediate;
procedure Push_Subframe (Interp: in out Interpreter_Record; procedure Push_Subframe (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type; Opcode: in Opcode_Type;
Operand: in Object_Pointer) is Operand: in Object_Pointer) is
pragma Inline (Push_Subframe); pragma Inline (Push_Subframe);
begin begin
-- Place a new frame below the existing top frame. -- Place a new frame below the existing top frame.
Insert_Frame (Interp, Interp.Stack.Pointer_Slot(Frame_Parent_Index), Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer));
Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer);
end Push_Subframe; end Push_Subframe;
procedure Push_Subframe_With_Environment (Interp: in out Interpreter_Record; procedure Push_Subframe_With_Environment (Interp: in out Interpreter_Record;
@ -2141,8 +2176,7 @@ end if;
pragma Inline (Push_Subframe_With_Environment); pragma Inline (Push_Subframe_With_Environment);
begin begin
-- Place a new frame below the existing top frame. -- Place a new frame below the existing top frame.
Insert_Frame (Interp, Interp.Stack.Pointer_Slot(Frame_Parent_Index), Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Envir, Nil_Pointer));
Opcode, Operand, Envir, Nil_Pointer);
end Push_Subframe_With_Environment; end Push_Subframe_With_Environment;
procedure Push_Subframe_With_Intermediate (Interp: in out Interpreter_Record; procedure Push_Subframe_With_Intermediate (Interp: in out Interpreter_Record;
@ -2152,8 +2186,7 @@ end if;
pragma Inline (Push_Subframe_With_Intermediate); pragma Inline (Push_Subframe_With_Intermediate);
begin begin
-- Place a new frame below the existing top frame. -- Place a new frame below the existing top frame.
Insert_Frame (Interp, Interp.Stack.Pointer_Slot(Frame_Parent_Index), Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm));
Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm);
end Push_Subframe_With_Intermediate; end Push_Subframe_With_Intermediate;
procedure Pop_Frame (Interp: in out Interpreter_Record) is procedure Pop_Frame (Interp: in out Interpreter_Record) is
@ -2164,6 +2197,16 @@ end if;
Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Parent_Index); -- pop Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Parent_Index); -- pop
end Pop_Frame; end Pop_Frame;
procedure Return_Frame (Interp: in out Interpreter_Record;
Value: in Object_Pointer) is
pragma Inline (Return_Frame);
begin
-- Remove the current frame and return a value
-- to a new active(top) frame.
Pop_Frame (Interp);
Set_Frame_Result (Interp.Stack, Value);
end Return_Frame;
procedure Execute (Interp: in out Interpreter_Record) is separate; procedure Execute (Interp: in out Interpreter_Record) is separate;
procedure Evaluate (Interp: in out Interpreter_Record; procedure Evaluate (Interp: in out Interpreter_Record;
@ -2193,10 +2236,11 @@ end if;
procedure Run_Loop (Interp: in out Interpreter_Record; procedure Run_Loop (Interp: in out Interpreter_Record;
Result: out Object_Pointer) is Result: out Object_Pointer) is
-- standard read-eval-print loop -- standard read-eval-print loop
Aliased_Result: aliased Object_Pointer;
begin begin
pragma Assert (Interp.Base_Input.Stream /= null); pragma Assert (Interp.Base_Input.Stream /= null);
--DEBUG_GC := Standard.True; DEBUG_GC := Standard.True;
Result := Nil_Pointer; Result := Nil_Pointer;
@ -2206,6 +2250,7 @@ end if;
Interp.Stack := Interp.Root_Frame; Interp.Stack := Interp.Root_Frame;
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
Push_Top (Interp, Aliased_Result'Unchecked_Access);
loop loop
pragma Assert (Interp.Stack = Interp.Root_Frame); pragma Assert (Interp.Stack = Interp.Root_Frame);
pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer); pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer);
@ -2218,19 +2263,27 @@ end if;
pragma Assert (Interp.Stack = Interp.Root_Frame); pragma Assert (Interp.Stack = Interp.Root_Frame);
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit); pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);
-- TODO: this result must be kept at some where that GC dowsn't sweep. Aliased_Result := Get_Frame_Result(Interp.Stack);
Result := Get_Frame_Result(Interp.Stack);
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
Ada.Text_IO.Put ("RESULT>>>>>"); Ada.Text_IO.Put ("RESULT: ");
Print (Interp, Result); Print (Interp, Aliased_Result);
Ada.Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> LOOP ITERATION XXXXXX CHECKPOINT"); Ada.Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> LOOP ITERATION XXXXXX CHECKPOINT");
end loop; end loop;
-- Jump into the exception handler not to repeat the same code here.
-- In fact, this part must not be reached since the loop above can't
-- be broken.
raise Stream_End_Error;
exception exception
when Stream_End_Error => when Stream_End_Error =>
-- this is not a real error. this indicates the end of input stream. -- this is not a real error. this indicates the end of input stream.
Ada.Text_IO.Put_LINE ("=== BYE ==="); Ada.Text_IO.Put_LINE ("=== BYE ===");
Pop_Tops (Interp, 1);
if Aliased_Result /= null then
Result := Aliased_Result;
end if;
when X: others => when X: others =>
Ada.TEXT_IO.PUT_LINE ("ERROR ERROR ERROR -> " & Ada.Exceptions.Exception_Name(X)); Ada.TEXT_IO.PUT_LINE ("ERROR ERROR ERROR -> " & Ada.Exceptions.Exception_Name(X));

10
lib/h2-scheme.ads
View File

@ -431,6 +431,15 @@ package H2.Scheme is
procedure Run_Loop (Interp: in out Interpreter_Record; procedure Run_Loop (Interp: in out Interpreter_Record;
Result: out Object_Pointer); Result: out Object_Pointer);
procedure Collect_Garbage (Interp: in out Interpreter_Record);
function Make_String (Interp: access Interpreter_Record;
Source: in Object_Character_Array) return Object_Pointer;
function Make_Symbol (Interp: access Interpreter_Record;
Source: in Object_Character_Array) return Object_Pointer;
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
@ -534,6 +543,7 @@ private
procedure Append_Character (Interp: in out Interpreter_Record; procedure Append_Character (Interp: in out Interpreter_Record;
Value: in Object_Character); Value: in Object_Character);
pragma Inline (Append_Character); pragma Inline (Append_Character);
end Token; end Token;