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
-- e.g) (lambda x (car x))
-- Apply the whole actual argument list to the closure.
Put_Environment (Interp, Formal, Actual);
Set_Current_Environment (Interp, Formal, Actual);
else
while Is_Cons(Formal) loop
if not Is_Cons(Actual) then
@ -325,7 +325,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
end if;
-- 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);
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.
-- Assign the remaining actual arguments to the last formal argument
-- e.g) ((lambda (x y . z) z) 1 2 3 4 5)
Put_Environment (Interp, Formal, Actual);
Set_Current_Environment (Interp, Formal, Actual);
else
-- The lambda evaluator must ensure all formal arguments are symbols.
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;
Cdr: aliased Object_Pointer;
-- ----------------------------------------------------------------
generic
Result: Object_Pointer; -- Result to return if no <test> expressions exist.
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_Or_Syntax is new Generic_And_Or_Syntax(False_Pointer, Opcode_Or_Finish);
-- ----------------------------------------------------------------
procedure Evaluate_Define_Syntax is
pragma Inline (Evaluate_Define_Syntax);
begin
@ -84,6 +88,8 @@ raise Syntax_Error;
end if;
end Evaluate_Define_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_If_Syntax is
pragma Inline (Evaluate_If_Syntax);
begin
@ -135,6 +141,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Push_Subframe (Interp, Opcode_If_Finish, Operand);
end Evaluate_If_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_Lambda_Syntax is
pragma Inline (Evaluate_Lambda_Syntax);
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)));
end Evaluate_Lambda_Syntax;
-- ----------------------------------------------------------------
procedure Check_Let_Syntax is
pragma Inline (Check_Let_Syntax);
@ -297,20 +307,6 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
pragma Inline (Evaluate_Let_Syntax);
Envir: aliased Object_Pointer;
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:
-- #1.
-- (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))
--
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
-- <bindings> is not empty
Push_Top (Interp, Envir'Unchecked_Access);
Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));
-- Create an array to hold the binding list and the evaluation result
Cdr := Make_Array (Interp.Self, 3);
Cdr.Pointer_Slot(1) := Car;
-- Say, <bindings> is ((x 2) (y 2)).
-- Get_Car(Car) is (x 2).
-- 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
-- new environment.
Push_Frame (Interp, Opcode_Let_Binding, Cdr);
-- Arrange to evaluate the first <binding> expression in the parent environment.
Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Car))), Envir);
-- 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);
end if;
end Evaluate_Let_Syntax;
@ -354,7 +365,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Check_Let_Syntax;
-- 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);
Clear_Frame_Result (Interp.Stack);
@ -376,26 +387,35 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
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);
-- 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_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));
Set_Frame_Environment (Interp.Stack, Envir);
Set_Frame_Environment (Interp.Stack, Envir); -- update the environment
if Car /= Nil_Pointer then
-- <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);
Push_Frame (Interp, Opcode_Let_Evaluation, Cdr);
-- Say, <bindings> is ((x 2) (y 2)).
-- 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 Evaluate_Letrec_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_Quote_Syntax is
pragma Inline (Evaluate_Quote_Syntax);
begin
@ -412,6 +432,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Return_Frame (Interp, Get_Car(Operand));
end Evaluate_Quote_Syntax;
-- ----------------------------------------------------------------
procedure Evaluate_Set_Syntax is
pragma Inline (Evaluate_Set_Syntax);
begin
@ -451,6 +473,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if;
end Evaluate_Set_Syntax;
-- ----------------------------------------------------------------
begin
Push_Top (Interp, Operand'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
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 is
@ -36,7 +36,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- evaluate <test1>. Y must be valid even at the first time
-- 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.
-- Yet there are still more tests to evaluate.
--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;
Y: aliased Object_Pointer;
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);
X := Get_Frame_Operand(Interp.Stack); -- symbol
pragma Assert (Is_Symbol(X));
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.
Pop_Tops (Interp, 1); -- Unmanage Y
end Do_Define_Finish;
@ -101,10 +101,10 @@ procedure Execute (Interp: in out Interpreter_Record) is
X := Get_Cdr(X); -- cons cell containing <alternate>
if Is_Cons(X) then
-- Switch the current current to evaluate <alternate>
-- keeping the environment untouched. Use Pop_Frame and
-- Push_Frame instead of Switch_Frame for continuation.
-- If continuation has been created in <test>, continuation
-- can be made to this frame.
-- keeping the environment untouched. Use Reload_Frame
-- instead of Switch_Frame for continuation. If continuation
-- has been created in <test>, continuation can be made to
-- this frame.
--
-- For example,
-- (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.
--Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer);
Pop_Frame (Interp);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
else
-- Return nil if no <alternate> is specified
Return_Frame (Interp, Nil_Pointer);
@ -124,11 +123,10 @@ procedure Execute (Interp: in out Interpreter_Record) is
else
-- All values except #f are true values. evaluate <consequent>.
-- Switch the current current to evaluate <consequent> keeping
-- the environment untouched. Use Pop_Frame and Push_Frame
-- instead of Switch_Frame for continuation to work.
-- the environment untouched. Use Reload_Frame instead of
-- Switch_Frame for continuation to work.
--Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer);
Pop_Frame (Interp);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
end if;
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);
X := Get_Frame_Operand(Interp.Stack);
Pop_Frame (Interp);
Push_Frame_With_Intermediate (Interp, Opcode_Apply, X, R);
Reload_Frame_With_Intermediate (Interp, Opcode_Apply, X, R);
--Pop_Tops (Interp, 2);
end Do_Procedure_Call_Finish;
@ -218,96 +215,56 @@ procedure Execute (Interp: in out Interpreter_Record) is
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
pragma Inline (Do_Let_Binding);
X: aliased Object_Pointer;
S: aliased Object_Pointer;
R: aliased Object_Pointer;
O: aliased Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, S'Unchecked_Access);
Push_Top (Interp, R'Unchecked_Access);
-- Perform binding in the parent environment.
Set_Parent_Environment (Interp, Get_Frame_Intermediate(Interp.Stack), Get_Frame_Result(Interp.Stack));
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
pragma Assert (Is_Array(X));
O := Get_Frame_Operand(Interp.Stack);
S := X.Pointer_Slot(1);
R := X.Pointer_Slot(3);
R := Reverse_Cons(R);
-- 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);
while Is_Cons(S) loop
pragma Assert (Is_Cons(R));
Put_Environment (Interp, Get_Car(Get_Car(S)), Get_Car(R));
S := Get_Cdr(S);
R := Get_Cdr(R);
end loop;
Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(O))));
Push_Subframe_With_Intermediate (Interp, Opcode_Let_Binding, Get_Cdr(O), Get_Car(Get_Car(O)));
Pop_Tops (Interp, 1);
else
Pop_Frame (Interp); -- done.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish);
Pop_Tops (Interp, 3);
end if;
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
pragma Inline (Do_Letast_Binding);
X: Object_Pointer;
@ -336,7 +293,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- Push a new environment for each binding.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
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
if Is_Cons(X) then
@ -352,37 +309,28 @@ procedure Execute (Interp: in out Interpreter_Record) is
Pop_Frame (Interp); -- Done
-- 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);
end if;
Pop_Tops (Interp, 2);
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
pragma Inline (Do_Set_Finish);
X: aliased Object_Pointer;
X: Object_Pointer;
Y: aliased Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- symbol
Y := Get_Frame_Result(Interp.Stack); -- value
ada.text_io.put ("%%%%% FINISH SET SYNTAX => ");
print (interp, Get_Frame_Result(Interp.Stack));
ada.text_io.put ("%%%%% FINISH SET SYNTAX => [");
print (interp, X);
print (interp, Y);
ada.text_io.put_line ("]");
pragma Assert (Is_Symbol(X));
if Set_Environment(Interp.Self, X, Y) = null then
@ -392,7 +340,7 @@ print (interp, Get_Frame_Result(Interp.Stack));
Return_Frame (Interp, Y);
Pop_Tops (Interp, 2);
Pop_Tops (Interp, 1);
end Do_Set_Finish;
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 =>
Do_Letast_Binding_Finish;
when Opcode_Let_Evaluation =>
Do_Let_Evaluation;
when Opcode_Let_Finish =>
Do_Let_Finish;
when Opcode_Letrec_Binding =>
Do_Letrec_Binding;
when Opcode_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_Letast_Binding,
Opcode_Letast_Binding_Finish,
Opcode_Let_Evaluation,
Opcode_Let_Finish,
Opcode_Letrec_Binding,
Opcode_Procedure_Call,
Opcode_Procedure_Call_Finish,
Opcode_Set_Finish,
@ -1440,7 +1439,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Envir: Object_Pointer;
Arr: Object_Pointer;
begin
-- Search the whole environment chain unlike Put_Environment().
-- Search the whole environment chain unlike Set_Current_Environment().
-- It is mainly for set!.
pragma Assert (Is_Symbol(Key));
@ -1462,13 +1461,11 @@ Ada.Text_IO.Put_Line ("Make_String...");
end Set_Environment;
procedure Put_Environment (Interp: in out Interpreter_Record;
Envir: in Object_Pointer;
Key: in Object_Pointer;
Value: in Object_Pointer) is
Arr: Object_Pointer;
Envir: aliased Object_Pointer;
begin
Envir := Get_Frame_Environment(Interp.Stack);
-- Search the current environment only. It doesn't search the
-- environment. If no key is found, add a new pair
-- 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
-- if no existing pair has been found.
declare
Aliased_Envir: aliased Object_Pointer := Envir;
Aliased_Key: aliased Object_Pointer := Key;
Aliased_Value: aliased Object_Pointer := Value;
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_Value'Unchecked_Access);
@ -1495,14 +1493,30 @@ Ada.Text_IO.Put_Line ("Make_String...");
Arr.Pointer_Slot(2) := Aliased_Value;
-- Chain the pair to the head of the list
Arr.Pointer_Slot(3) := Get_Car(Envir);
Set_Car (Envir, Arr);
Arr.Pointer_Slot(3) := Get_Car(Aliased_Envir);
Set_Car (Aliased_Envir, Arr);
Pop_Tops (Interp, 3);
end;
end if;
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;
@ -1545,7 +1559,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- Link it to the top environement
pragma Assert (Get_Frame_Environment(Interp.Stack) = Interp.Root_Environment);
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);
return Proc;
@ -2154,6 +2168,16 @@ end if;
Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Envir, Nil_Pointer);
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;
Opcode: in Opcode_Type;
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));
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
pragma Inline (Pop_Frame);
begin
@ -2211,6 +2246,31 @@ end if;
Set_Frame_Result (Interp.Stack, Value);
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 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);
when Character_Object =>
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 =>
Byte_Slot: Object_Byte_Array(1 .. Size) := (others => 0);
when Word_Object =>