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

made let and letrec continuation-friendly

Browse Source
This commit is contained in:
hyung-hwan 2014-02-09 15:28:46 +00:00
parent b2088d0891
commit 81d910a0e1
5 changed files with 203 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -316,7 +316,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
-- Closure made of a lambda expression with a single formal argument -- Closure made of a lambda expression with a single formal argument
-- e.g) (lambda x (car x)) -- e.g) (lambda x (car x))
-- Apply the whole actual argument list to the closure. -- Apply the whole actual argument list to the closure.
Put_Environment (Interp, Formal, Actual); Set_Current_Environment (Interp, Formal, Actual);
else else
while Is_Cons(Formal) loop while Is_Cons(Formal) loop
if not Is_Cons(Actual) then if not Is_Cons(Actual) then
@ -325,7 +325,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
end if; end if;
-- Insert the key/value pair into the environment -- Insert the key/value pair into the environment
Put_Environment (Interp, Get_Car(Formal), Get_Car(Actual)); Set_Current_Environment (Interp, Get_Car(Formal), Get_Car(Actual));
Formal := Get_Cdr(Formal); Formal := Get_Cdr(Formal);
Actual := Get_Cdr(Actual); Actual := Get_Cdr(Actual);
@ -336,7 +336,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
-- The last formal argument to the closure is in a CDR. -- The last formal argument to the closure is in a CDR.
-- Assign the remaining actual arguments to the last formal argument -- Assign the remaining actual arguments to the last formal argument
-- e.g) ((lambda (x y . z) z) 1 2 3 4 5) -- e.g) ((lambda (x y . z) z) 1 2 3 4 5)
Put_Environment (Interp, Formal, Actual); Set_Current_Environment (Interp, Formal, Actual);
else else
-- The lambda evaluator must ensure all formal arguments are symbols. -- The lambda evaluator must ensure all formal arguments are symbols.
pragma Assert (Formal = Nil_Pointer); pragma Assert (Formal = Nil_Pointer);

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

@ -7,6 +7,8 @@ procedure Evaluate is
Car: aliased Object_Pointer; Car: aliased Object_Pointer;
Cdr: aliased Object_Pointer; Cdr: aliased Object_Pointer;
-- ----------------------------------------------------------------
generic generic
Result: Object_Pointer; -- Result to return if no <test> expressions exist. Result: Object_Pointer; -- Result to return if no <test> expressions exist.
Opcode: Opcode_Type; -- Switch to this opcode to evaluate the next <test>. Opcode: Opcode_Type; -- Switch to this opcode to evaluate the next <test>.
@ -41,6 +43,8 @@ procedure Evaluate is
procedure Evaluate_And_Syntax is new Generic_And_Or_Syntax(True_Pointer, Opcode_And_Finish); procedure Evaluate_And_Syntax is new Generic_And_Or_Syntax(True_Pointer, Opcode_And_Finish);
procedure Evaluate_Or_Syntax is new Generic_And_Or_Syntax(False_Pointer, Opcode_Or_Finish); procedure Evaluate_Or_Syntax is new Generic_And_Or_Syntax(False_Pointer, Opcode_Or_Finish);
-- ----------------------------------------------------------------
procedure Evaluate_Define_Syntax is procedure Evaluate_Define_Syntax is
pragma Inline (Evaluate_Define_Syntax); pragma Inline (Evaluate_Define_Syntax);
begin begin
@ -84,6 +88,8 @@ raise Syntax_Error;
end if; end if;
end Evaluate_Define_Syntax; end Evaluate_Define_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_If_Syntax is procedure Evaluate_If_Syntax is
pragma Inline (Evaluate_If_Syntax); pragma Inline (Evaluate_If_Syntax);
begin begin
@ -135,6 +141,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Push_Subframe (Interp, Opcode_If_Finish, Operand); Push_Subframe (Interp, Opcode_If_Finish, Operand);
end Evaluate_If_Syntax; end Evaluate_If_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_Lambda_Syntax is procedure Evaluate_Lambda_Syntax is
pragma Inline (Evaluate_Lambda_Syntax); pragma Inline (Evaluate_Lambda_Syntax);
begin begin
@ -213,6 +221,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Return_Frame (Interp, Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack))); Return_Frame (Interp, Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack)));
end Evaluate_Lambda_Syntax; end Evaluate_Lambda_Syntax;
-- ----------------------------------------------------------------
procedure Check_Let_Syntax is procedure Check_Let_Syntax is
pragma Inline (Check_Let_Syntax); pragma Inline (Check_Let_Syntax);
@ -297,20 +307,6 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
pragma Inline (Evaluate_Let_Syntax); pragma Inline (Evaluate_Let_Syntax);
Envir: aliased Object_Pointer; Envir: aliased Object_Pointer;
begin begin
Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body>
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
Set_Frame_Operand (Interp.Stack, Cdr);
Clear_Frame_Result (Interp.Stack);
-- Push a new environment onto the current frame.
-- It's pushed even if <bindings> is empty because
-- the new environment is still needed in such a case
-- as shown in the first sample below.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir);
-- Some let samples: -- Some let samples:
-- #1. -- #1.
-- (define x 99) ; define x in the root environment -- (define x 99) ; define x in the root environment
@ -327,22 +323,37 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
-- (define x (let ((x x)) x)) -- (define x (let ((x x)) x))
-- --
Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body>
-- Switch the frame to Opcode_Grouped_Call and let its environment
-- be the new environment created. Use Reload_Frame() instead
-- of Switch_Frame() for continuation. This frame is executed once
-- the Opcode_Let_Binding frame pushed in the 'if' block is finished.
Reload_Frame (Interp, Opcode_Grouped_Call, Cdr);
-- Create a new environment over the current environment.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment
if Car /= Nil_Pointer then if Car /= Nil_Pointer then
-- <bindings> is not empty -- <bindings> is not empty
Push_Top (Interp, Envir'Unchecked_Access); Push_Top (Interp, Envir'Unchecked_Access);
Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack)); Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));
-- Create an array to hold the binding list and the evaluation result -- Say, <bindings> is ((x 2) (y 2)).
Cdr := Make_Array (Interp.Self, 3); -- Get_Car(Car) is (x 2).
Cdr.Pointer_Slot(1) := Car; -- To get x, Get_Car(Get_Car(Car))
-- To get 2, Get_Car(Get_Cdr(Get_Car(Car)))
-- The actual binding after evaluation must be performed in the -- Arrange to evaluate the first <binding> expression in the parent environment.
-- new environment. Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Car))), Envir);
Push_Frame (Interp, Opcode_Let_Binding, Cdr);
-- Arrange to perform actual binding. Pass the <binding> name as an intermediate
-- and the next remaing <binding> list as an operand.
Push_Subframe_With_Environment_And_Intermediate (Interp, Opcode_Let_Binding, Get_Cdr(Car), Envir, Get_Car(Get_Car(Car)));
-- But evaluation must be done in the current environment which is
-- the environment before the environment update above.
Push_Frame_With_Environment (Interp, Opcode_Let_Evaluation, Cdr, Envir);
Pop_Tops (Interp, 1); Pop_Tops (Interp, 1);
end if; end if;
end Evaluate_Let_Syntax; end Evaluate_Let_Syntax;
@ -354,7 +365,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Check_Let_Syntax; Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body> -- Car: <bindings>, Cdr: <body>
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call);
Set_Frame_Operand (Interp.Stack, Cdr); Set_Frame_Operand (Interp.Stack, Cdr);
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
@ -376,26 +387,35 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Check_Let_Syntax; Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body> -- Car: <bindings>, Cdr: <body>
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); -- Switch the frame to Opcode_Grouped_Call and let its environment
Set_Frame_Operand (Interp.Stack, Cdr); -- be the new environment created. Use Reload_Frame() instead
Clear_Frame_Result (Interp.Stack); -- of Switch_Frame() for continuation. This frame is executed once
-- the Opcode_Letrec_Binding frame pushed in the 'if' block is finished.
Reload_Frame (Interp, Opcode_Grouped_Call, Cdr);
-- Push a new environment. -- Create a new environment over the current environment.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir); Set_Frame_Environment (Interp.Stack, Envir); -- update the environment
if Car /= Nil_Pointer then if Car /= Nil_Pointer then
-- <bindings> is not empty -- <bindings> is not empty
-- Arrange to perform evaluataion and binding in the
-- new environment created.
Cdr := Make_Array (Interp.Self, 3);
Cdr.Pointer_Slot(1) := Car;
Push_Frame (Interp, Opcode_Let_Binding, Cdr); -- Say, <bindings> is ((x 2) (y 2)).
Push_Frame (Interp, Opcode_Let_Evaluation, Cdr); -- Get_Car(Car) is (x 2).
-- To get x, Get_Car(Get_Car(Car))
-- To get 2, Get_Car(Get_Cdr(Get_Car(Car)))
-- Arrange to evaluate the first <binding> expression in the parent environment.
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Car))));
-- Arrange to perform actual binding. Pass the <binding> name as an intermediate
-- and the next remaing <binding> list as an operand.
Push_Subframe_With_Intermediate (Interp, Opcode_Letrec_Binding, Get_Cdr(Car), Get_Car(Get_Car(Car)));
end if; end if;
end Evaluate_Letrec_Syntax; end Evaluate_Letrec_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_Quote_Syntax is procedure Evaluate_Quote_Syntax is
pragma Inline (Evaluate_Quote_Syntax); pragma Inline (Evaluate_Quote_Syntax);
begin begin
@ -412,6 +432,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Return_Frame (Interp, Get_Car(Operand)); Return_Frame (Interp, Get_Car(Operand));
end Evaluate_Quote_Syntax; end Evaluate_Quote_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_Set_Syntax is procedure Evaluate_Set_Syntax is
pragma Inline (Evaluate_Set_Syntax); pragma Inline (Evaluate_Set_Syntax);
begin begin
@ -451,6 +473,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if; end if;
end Evaluate_Set_Syntax; end Evaluate_Set_Syntax;
-- ----------------------------------------------------------------
begin begin
Push_Top (Interp, Operand'Unchecked_Access); Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Car'Unchecked_Access); Push_Top (Interp, Car'Unchecked_Access);

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

@ -21,7 +21,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
generic generic
with function Is_Bool (X: in Object_Pointer) return Standard.Boolean; with function Is_Good_Result (X: in Object_Pointer) return Standard.Boolean;
procedure Evaluate_While; procedure Evaluate_While;
procedure Evaluate_While is procedure Evaluate_While is
@ -36,7 +36,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- evaluate <test1>. Y must be valid even at the first time -- evaluate <test1>. Y must be valid even at the first time
-- this procedure is called. -- this procedure is called.
if Is_Bool(Y) and then Is_Cons(X) then if Is_Good_Result(Y) and then Is_Cons(X) then
-- The result is not what I look for. -- The result is not what I look for.
-- Yet there are still more tests to evaluate. -- Yet there are still more tests to evaluate.
--Switch_Frame (Interp.Stack, Get_Frame_Opcode(Interp.Stack), Get_Cdr(X), Nil_Pointer); --Switch_Frame (Interp.Stack, Get_Frame_Opcode(Interp.Stack), Get_Cdr(X), Nil_Pointer);
@ -72,14 +72,14 @@ procedure Execute (Interp: in out Interpreter_Record) is
X: Object_Pointer; X: Object_Pointer;
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
begin begin
-- Keep Y managed as Y is referenced beyond the gc point. -- Manage Y as it's referenced after 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
pragma Assert (Is_Symbol(X)); pragma Assert (Is_Symbol(X));
Y := Get_Frame_Result(Interp.Stack); -- value list Y := Get_Frame_Result(Interp.Stack); -- value list
Put_Environment (Interp, X, Y); -- gc point Set_Current_Environment (Interp, X, Y); -- gc point
Return_Frame (Interp, Y); -- Y is referenced here. Return_Frame (Interp, Y); -- Y is referenced here.
Pop_Tops (Interp, 1); -- Unmanage Y Pop_Tops (Interp, 1); -- Unmanage Y
end Do_Define_Finish; end Do_Define_Finish;
@ -101,10 +101,10 @@ procedure Execute (Interp: in out Interpreter_Record) is
X := Get_Cdr(X); -- cons cell containing <alternate> X := Get_Cdr(X); -- cons cell containing <alternate>
if Is_Cons(X) then if Is_Cons(X) then
-- Switch the current current to evaluate <alternate> -- Switch the current current to evaluate <alternate>
-- keeping the environment untouched. Use Pop_Frame and -- keeping the environment untouched. Use Reload_Frame
-- Push_Frame instead of Switch_Frame for continuation. -- instead of Switch_Frame for continuation. If continuation
-- If continuation has been created in <test>, continuation -- has been created in <test>, continuation can be made to
-- can be made to this frame. -- this frame.
-- --
-- For example, -- For example,
-- (if (define xx (call/cc call/cc)) -- (if (define xx (call/cc call/cc))
@ -115,8 +115,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- <alternate>, its opcode must remain as Opcode_If_Finish. -- <alternate>, its opcode must remain as Opcode_If_Finish.
--Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer); --Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer);
Pop_Frame (Interp); Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
else else
-- Return nil if no <alternate> is specified -- Return nil if no <alternate> is specified
Return_Frame (Interp, Nil_Pointer); Return_Frame (Interp, Nil_Pointer);
@ -124,11 +123,10 @@ procedure Execute (Interp: in out Interpreter_Record) is
else else
-- All values except #f are true values. evaluate <consequent>. -- All values except #f are true values. evaluate <consequent>.
-- Switch the current current to evaluate <consequent> keeping -- Switch the current current to evaluate <consequent> keeping
-- the environment untouched. Use Pop_Frame and Push_Frame -- the environment untouched. Use Reload_Frame instead of
-- instead of Switch_Frame for continuation to work. -- Switch_Frame for continuation to work.
--Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer); --Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer);
Pop_Frame (Interp); Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
end if; end if;
end Do_If_Finish; end Do_If_Finish;
@ -189,8 +187,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Nil_Pointer); R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Nil_Pointer);
X := Get_Frame_Operand(Interp.Stack); X := Get_Frame_Operand(Interp.Stack);
Pop_Frame (Interp); Reload_Frame_With_Intermediate (Interp, Opcode_Apply, X, R);
Push_Frame_With_Intermediate (Interp, Opcode_Apply, X, R);
--Pop_Tops (Interp, 2); --Pop_Tops (Interp, 2);
end Do_Procedure_Call_Finish; end Do_Procedure_Call_Finish;
@ -218,96 +215,56 @@ procedure Execute (Interp: in out Interpreter_Record) is
end Do_Grouped_Call; end Do_Grouped_Call;
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------
procedure Do_Let_Evaluation is
pragma Inline (Do_Let_Evaluation);
X: aliased Object_Pointer;
S: aliased Object_Pointer;
R: aliased Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, S'Unchecked_Access);
Push_Top (Interp, R'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Array(X));
R := X.Pointer_Slot(3);
if R = Nil_Pointer then
-- First call;
X.Pointer_Slot(2) := X.Pointer_Slot(1);
else
-- Subsequent calls. Store the result in the room created
-- in the previous call.
pragma Assert (Is_Cons(R));
Set_Car (R, Get_Frame_Result(Interp.Stack));
end if;
S := X.Pointer_Slot(2);
if Is_Cons(S) then
-- Handle each binding.
-- Make an empty room to hold the result on the next call
R := Make_Cons (Interp.Self, Nil_Pointer, R);
X.Pointer_Slot(3) := R;
-- Remember the next <operator> to evaluate
X.Pointer_Slot(2) := Get_Cdr(S);
-- Say, <bindings> is ((x 2) (y 2)).
-- for the first call, Get_Car(S) is (x 2).
-- To get x, Get_Car(Get_Car(S))
-- To get 2, Get_Car(Get_Cdr(Get_Car(S)))
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(S))));
else
-- No more binding to handle.
Pop_Frame (Interp);
-- The operands at the Let_Evaluation and the Let_Binding frame
-- must be the identical objects. this way, i don't need to carry
-- over the binding result to the Let_Binding frame.
pragma Assert (X = Get_Frame_Operand(Interp.Stack));
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Binding);
--X := Get_Frame_Operand(Interp.Stack);
--pragma Assert (Is_Array(X));
--pragma Assert (X.Pointer_Slot(3) = Nil_Pointer);
--X.Pointer_Slot(3) := R;
end if;
Pop_Tops (Interp, 3);
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; O: aliased Object_Pointer;
S: aliased Object_Pointer;
R: aliased Object_Pointer;
begin begin
Push_Top (Interp, X'Unchecked_Access); -- Perform binding in the parent environment.
Push_Top (Interp, S'Unchecked_Access); Set_Parent_Environment (Interp, Get_Frame_Intermediate(Interp.Stack), Get_Frame_Result(Interp.Stack));
Push_Top (Interp, R'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward O := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Array(X));
S := X.Pointer_Slot(1); -- Say, <bindings> is ((x 2) (y 2)).
R := X.Pointer_Slot(3); -- Get_Car(O) is (x 2).
R := Reverse_Cons(R); -- To get x, Get_Car(Get_Car(O))
-- To get 2, Get_Car(Get_Cdr(Get_Car(O)))
if Is_Cons(O) then
Push_Top (Interp, O'Unchecked_Access);
while Is_Cons(S) loop Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(O))));
pragma Assert (Is_Cons(R)); Push_Subframe_With_Intermediate (Interp, Opcode_Let_Binding, Get_Cdr(O), Get_Car(Get_Car(O)));
Put_Environment (Interp, Get_Car(Get_Car(S)), Get_Car(R));
S := Get_Cdr(S);
R := Get_Cdr(R);
end loop;
Pop_Tops (Interp, 1);
else
Pop_Frame (Interp); -- done. Pop_Frame (Interp); -- done.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish); end if;
Pop_Tops (Interp, 3);
end Do_Let_Binding; end Do_Let_Binding;
procedure Do_Letrec_Binding is
pragma Inline (Do_Letrec_Binding);
O: aliased Object_Pointer;
begin
-- Perform binding in the parent environment.
Set_Current_Environment (Interp, Get_Frame_Intermediate(Interp.Stack), Get_Frame_Result(Interp.Stack));
O := Get_Frame_Operand(Interp.Stack);
-- Say, <bindings> is ((x 2) (y 2)).
-- Get_Car(O) is (x 2).
-- To get x, Get_Car(Get_Car(O))
-- To get 2, Get_Car(Get_Cdr(Get_Car(O)))
if Is_Cons(O) then
Push_Top (Interp, O'Unchecked_Access);
Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(O))));
Push_Subframe_With_Intermediate (Interp, Opcode_Letrec_Binding, Get_Cdr(O), Get_Car(Get_Car(O)));
Pop_Tops (Interp, 1);
else
Pop_Frame (Interp);
end if;
end Do_Letrec_Binding;
procedure Do_Letast_Binding is procedure Do_Letast_Binding is
pragma Inline (Do_Letast_Binding); pragma Inline (Do_Letast_Binding);
X: Object_Pointer; X: Object_Pointer;
@ -336,7 +293,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- Push a new environment for each binding. -- Push a new environment for each binding.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir); Set_Frame_Environment (Interp.Stack, Envir);
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Frame_Result(Interp.Stack)); Set_Current_Environment (Interp, Get_Car(Get_Car(X)), Get_Frame_Result(Interp.Stack));
X := Get_Cdr(X); -- next binding X := Get_Cdr(X); -- next binding
if Is_Cons(X) then if Is_Cons(X) then
@ -352,37 +309,28 @@ procedure Execute (Interp: in out Interpreter_Record) is
Pop_Frame (Interp); -- Done Pop_Frame (Interp); -- Done
-- Update the environment of the Let_Finish frame. -- Update the environment of the Let_Finish frame.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish); --pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish);
Set_Frame_Environment (Interp.Stack, Envir); Set_Frame_Environment (Interp.Stack, Envir);
end if; end if;
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Do_Letast_Binding_Finish; end Do_Letast_Binding_Finish;
procedure Do_Let_Finish is
pragma Inline (Do_Let_Finish);
begin
pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer);
-- Evaluate_Let_Syntax has places <body> in the operand of this frame.
-- <body> can be evaluated as if it's in 'begin'.
--Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call);
end Do_Let_Finish;
-- -------------------------------------------------------------------- -- --------------------------------------------------------------------
procedure Do_Set_Finish is procedure Do_Set_Finish is
pragma Inline (Do_Set_Finish); pragma Inline (Do_Set_Finish);
X: aliased Object_Pointer; X: Object_Pointer;
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
begin begin
Push_Top (Interp, X'Unchecked_Access);
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
Y := Get_Frame_Result(Interp.Stack); -- value Y := Get_Frame_Result(Interp.Stack); -- value
ada.text_io.put ("%%%%% FINISH SET SYNTAX => "); ada.text_io.put ("%%%%% FINISH SET SYNTAX => [");
print (interp, Get_Frame_Result(Interp.Stack)); print (interp, X);
print (interp, Y);
ada.text_io.put_line ("]");
pragma Assert (Is_Symbol(X)); pragma Assert (Is_Symbol(X));
if Set_Environment(Interp.Self, X, Y) = null then if Set_Environment(Interp.Self, X, Y) = null then
@ -392,7 +340,7 @@ print (interp, Get_Frame_Result(Interp.Stack));
Return_Frame (Interp, Y); Return_Frame (Interp, Y);
Pop_Tops (Interp, 2); Pop_Tops (Interp, 1);
end Do_Set_Finish; end Do_Set_Finish;
procedure Evaluate is separate; procedure Evaluate is separate;
@ -970,11 +918,8 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
when Opcode_Letast_Binding_Finish => when Opcode_Letast_Binding_Finish =>
Do_Letast_Binding_Finish; Do_Letast_Binding_Finish;
when Opcode_Let_Evaluation => when Opcode_Letrec_Binding =>
Do_Let_Evaluation; Do_Letrec_Binding;
when Opcode_Let_Finish =>
Do_Let_Finish;
when Opcode_Or_Finish => when Opcode_Or_Finish =>
Do_Or_Finish; Do_Or_Finish;

80
lib/h2-scheme.adb
View File

@ -106,8 +106,7 @@ package body H2.Scheme is
Opcode_Let_Binding, Opcode_Let_Binding,
Opcode_Letast_Binding, Opcode_Letast_Binding,
Opcode_Letast_Binding_Finish, Opcode_Letast_Binding_Finish,
Opcode_Let_Evaluation, Opcode_Letrec_Binding,
Opcode_Let_Finish,
Opcode_Procedure_Call, Opcode_Procedure_Call,
Opcode_Procedure_Call_Finish, Opcode_Procedure_Call_Finish,
Opcode_Set_Finish, Opcode_Set_Finish,
@ -1440,7 +1439,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Envir: Object_Pointer; Envir: Object_Pointer;
Arr: Object_Pointer; Arr: Object_Pointer;
begin begin
-- Search the whole environment chain unlike Put_Environment(). -- Search the whole environment chain unlike Set_Current_Environment().
-- It is mainly for set!. -- It is mainly for set!.
pragma Assert (Is_Symbol(Key)); pragma Assert (Is_Symbol(Key));
@ -1462,13 +1461,11 @@ Ada.Text_IO.Put_Line ("Make_String...");
end Set_Environment; end Set_Environment;
procedure Put_Environment (Interp: in out Interpreter_Record; procedure Put_Environment (Interp: in out Interpreter_Record;
Envir: in Object_Pointer;
Key: in Object_Pointer; Key: in Object_Pointer;
Value: in Object_Pointer) is Value: in Object_Pointer) is
Arr: Object_Pointer; Arr: Object_Pointer;
Envir: aliased Object_Pointer;
begin begin
Envir := Get_Frame_Environment(Interp.Stack);
-- Search the current environment only. It doesn't search the -- Search the current environment only. It doesn't search the
-- environment. If no key is found, add a new pair -- environment. If no key is found, add a new pair
-- This is mainly for define. -- This is mainly for define.
@ -1483,10 +1480,11 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- Add a new key/value pair in the current environment -- Add a new key/value pair in the current environment
-- if no existing pair has been found. -- if no existing pair has been found.
declare declare
Aliased_Envir: aliased Object_Pointer := Envir;
Aliased_Key: aliased Object_Pointer := Key; Aliased_Key: aliased Object_Pointer := Key;
Aliased_Value: aliased Object_Pointer := Value; Aliased_Value: aliased Object_Pointer := Value;
begin begin
Push_Top (Interp, Envir'Unchecked_Access); Push_Top (Interp, Aliased_Envir'Unchecked_Access);
Push_Top (Interp, Aliased_Key'Unchecked_Access); Push_Top (Interp, Aliased_Key'Unchecked_Access);
Push_Top (Interp, Aliased_Value'Unchecked_Access); Push_Top (Interp, Aliased_Value'Unchecked_Access);
@ -1495,14 +1493,30 @@ Ada.Text_IO.Put_Line ("Make_String...");
Arr.Pointer_Slot(2) := Aliased_Value; Arr.Pointer_Slot(2) := Aliased_Value;
-- Chain the pair to the head of the list -- Chain the pair to the head of the list
Arr.Pointer_Slot(3) := Get_Car(Envir); Arr.Pointer_Slot(3) := Get_Car(Aliased_Envir);
Set_Car (Envir, Arr); Set_Car (Aliased_Envir, Arr);
Pop_Tops (Interp, 3); Pop_Tops (Interp, 3);
end; end;
end if; end if;
end Put_Environment; end Put_Environment;
procedure Set_Current_Environment (Interp: in out Interpreter_Record;
Key: in Object_Pointer;
Value: in Object_Pointer) is
pragma Inline (Set_Current_Environment);
begin
Put_Environment (Interp, Get_Frame_Environment(Interp.Stack), Key, Value);
end Set_Current_Environment;
procedure Set_Parent_Environment (Interp: in out Interpreter_Record;
Key: in Object_Pointer;
Value: in Object_Pointer) is
pragma Inline (Set_Parent_Environment);
begin
Put_Environment (Interp, Get_Frame_Environment(Get_Frame_Parent(Interp.Stack)), Key, Value);
end Set_Parent_Environment;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
function Make_Syntax (Interp: access Interpreter_Record; function Make_Syntax (Interp: access Interpreter_Record;
@ -1545,7 +1559,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- Link it to the top environement -- Link it to the top environement
pragma Assert (Get_Frame_Environment(Interp.Stack) = Interp.Root_Environment); pragma Assert (Get_Frame_Environment(Interp.Stack) = Interp.Root_Environment);
pragma Assert (Get_Environment(Interp.Self, Symbol) = null); pragma Assert (Get_Environment(Interp.Self, Symbol) = null);
Put_Environment (Interp.all, Symbol, Proc); Set_Current_Environment (Interp.all, Symbol, Proc);
Pop_Tops (Interp.all, 2); Pop_Tops (Interp.all, 2);
return Proc; return Proc;
@ -2154,6 +2168,16 @@ end if;
Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Envir, Nil_Pointer); Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Envir, Nil_Pointer);
end Push_Frame_With_Environment; end Push_Frame_With_Environment;
procedure Push_Frame_With_Environment_And_Intermediate (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
Envir: in Object_Pointer;
Interm: in Object_Pointer) is
pragma Inline (Push_Frame_With_Environment_And_Intermediate);
begin
Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Envir, Interm);
end Push_Frame_With_Environment_And_Intermediate;
procedure Push_Frame_With_Intermediate (Interp: in out Interpreter_Record; procedure Push_Frame_With_Intermediate (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type; Opcode: in Opcode_Type;
Operand: in Object_Pointer; Operand: in Object_Pointer;
@ -2193,6 +2217,17 @@ end if;
Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm)); Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm));
end Push_Subframe_With_Intermediate; end Push_Subframe_With_Intermediate;
procedure Push_Subframe_With_Environment_And_Intermediate (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
Envir: in Object_Pointer;
Interm: in Object_Pointer) is
pragma Inline (Push_Subframe_With_Environment_And_Intermediate);
begin
-- Place a new frame below the existing top frame.
Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Envir, Interm));
end Push_Subframe_With_Environment_And_Intermediate;
procedure Pop_Frame (Interp: in out Interpreter_Record) is procedure Pop_Frame (Interp: in out Interpreter_Record) is
pragma Inline (Pop_Frame); pragma Inline (Pop_Frame);
begin begin
@ -2211,6 +2246,31 @@ end if;
Set_Frame_Result (Interp.Stack, Value); Set_Frame_Result (Interp.Stack, Value);
end Return_Frame; end Return_Frame;
procedure Reload_Frame (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer) is
pragma Inline (Reload_Frame);
Envir: Object_Pointer;
begin
-- Change various frame fields keeping the environment.
Envir := Get_Frame_Environment (Interp.Stack);
Pop_Frame (Interp);
Push_Frame_With_Environment (Interp, Opcode, Operand, Envir);
end Reload_Frame;
procedure Reload_Frame_With_Intermediate (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
Interm: in Object_Pointer) is
pragma Inline (Reload_Frame_With_Intermediate);
Envir: Object_Pointer;
begin
-- Change various frame fields keeping the environment.
Envir := Get_Frame_Environment (Interp.Stack);
Pop_Frame (Interp);
Push_Frame_With_Environment_And_Intermediate (Interp, Opcode, Operand, Envir, Interm);
end Reload_Frame_With_Intermediate;
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;

8
lib/h2-scheme.ads
View File

@ -230,7 +230,13 @@ package H2.Scheme is
Pointer_Slot: Object_Pointer_Array(1 .. Size) := (others => null); Pointer_Slot: Object_Pointer_Array(1 .. Size) := (others => null);
when Character_Object => when Character_Object =>
Character_Slot: Object_Character_Array(1 .. Size) := (others => Object_Character'First); Character_Slot: Object_Character_Array(1 .. Size) := (others => Object_Character'First);
Character_Terminator: Object_Character := Object_Character'First; -- TODO: can this guarantee terminating NULL? require some attribute for it to work? -- The character terminator is to ease integration with
-- other languages using a terminating null.
-- TODO: can this guarantee terminating NULL? is this
-- terminator guaranteed to be placed after the
-- character_slot without any gaps in between
-- under the current alignement condition?
Character_Terminator: Object_Character := Object_Character'First;
when Byte_Object => when Byte_Object =>
Byte_Slot: Object_Byte_Array(1 .. Size) := (others => 0); Byte_Slot: Object_Byte_Array(1 .. Size) := (others => 0);
when Word_Object => when Word_Object =>