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

made let* continuation-friendly

Browse Source
This commit is contained in:
hyung-hwan 2014-02-09 17:20:59 +00:00
parent 81d910a0e1
commit 54274fe6df
3 changed files with 96 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -360,23 +360,35 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
procedure Evaluate_Letast_Syntax is
pragma Inline (Evaluate_Letast_Syntax);
Envir: Object_Pointer;
Envir: aliased Object_Pointer;
begin
Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body>
Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call);
Set_Frame_Operand (Interp.Stack, Cdr);
Clear_Frame_Result (Interp.Stack);
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_Frame (Interp, Opcode_Letast_Binding, Car);
else
-- <bindings> is empty. push the new environment
-- for <body> evaluation.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir);
Push_Top (Interp, Envir'Unchecked_Access);
-- 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_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_Letast_Binding, Get_Cdr(Car), Envir, Get_Car(Get_Car(Car)));
Pop_Tops (Interp, 1);
end if;
end Evaluate_Letast_Syntax;

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

@ -240,6 +240,55 @@ procedure Execute (Interp: in out Interpreter_Record) is
end if;
end Do_Let_Binding;
procedure Do_Letast_Binding is
pragma Inline (Do_Letast_Binding);
O: aliased Object_Pointer;
Envir: 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);
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir);
Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(O))));
Push_Subframe_With_Intermediate (Interp, Opcode_Letast_Binding, Get_Cdr(O), Get_Car(Get_Car(O)));
Pop_Tops (Interp, 1);
else
--envir := get_frame_environment(interp.stack);
--declare
--w: object_word;
--for w'address use envir'address;
--begin
--ada.text_io.put_line ("i$$$$$$$$$$$$$$$$$$$$$$$$44 ENVIR => " & object_word'image(w));
--print (interp, envir);
--end;
-- Get the final environment
Envir := Get_Frame_Environment(Interp.Stack);
-- Get <body> stored in the Opcode_Grouped_Call frame
-- pushed in Evalute_Letast_Syntax().
O := Get_Frame_Operand(Get_Frame_Parent(Interp.Stack));
Pop_Frame (Interp); -- Current frame
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Grouped_Call);
-- Refresh the Opcode_Grouped_Call frame pushed in Evaluate_Letast_Syntax()
-- with the final environment.
Reload_Frame_With_Environment (Interp, Opcode_Grouped_Call, O, Envir);
end if;
end Do_Letast_Binding;
procedure Do_Letrec_Binding is
pragma Inline (Do_Letrec_Binding);
O: aliased Object_Pointer;
@ -265,57 +314,6 @@ procedure Execute (Interp: in out Interpreter_Record) is
end if;
end Do_Letrec_Binding;
procedure Do_Letast_Binding is
pragma Inline (Do_Letast_Binding);
X: Object_Pointer;
begin
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
-- Don't call this procedure if <bindings> is empty. The caller must ensure this
pragma Assert (Is_Cons(X));
Set_Frame_Opcode (Interp.Stack, Opcode_Letast_Binding_Finish);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
end Do_Letast_Binding;
procedure Do_Letast_Binding_Finish is
pragma Inline (Do_Letast_Binding_Finish);
X: aliased Object_Pointer;
Envir: aliased Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Envir'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
-- Update the environment while evaluating <bindings>
-- Push a new environment for each binding.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir);
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
-- More bingings to evaluate
Set_Frame_Operand (Interp.Stack, X);
Clear_Frame_Result (Interp.Stack);
-- the next evaluation must be done in the environment where the
-- current binding has been made.
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
else
-- No more bingings left
Pop_Frame (Interp); -- Done
-- Update the environment of the Let_Finish frame.
--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_Set_Finish is
@ -915,9 +913,6 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
when Opcode_Letast_Binding =>
Do_Letast_Binding;
when Opcode_Letast_Binding_Finish =>
Do_Letast_Binding_Finish;
when Opcode_Letrec_Binding =>
Do_Letrec_Binding;

29
lib/h2-scheme.adb
View File

@ -105,7 +105,6 @@ package body H2.Scheme is
Opcode_If_Finish,
Opcode_Let_Binding,
Opcode_Letast_Binding,
Opcode_Letast_Binding_Finish,
Opcode_Letrec_Binding,
Opcode_Procedure_Call,
Opcode_Procedure_Call_Finish,
@ -1977,6 +1976,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
when Array_Object =>
Ada.Text_IO.Put ("#Array");
when Others =>
if Atom.Kind = Character_Object then
@ -2036,7 +2036,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
loop
Car := Get_Car(Cons);
if Is_Cons (Car) then
if Is_Cons(Car) or else Is_Array(Car) then
Print_Object (Car);
else
Print_Atom (Car);
@ -2057,6 +2057,16 @@ Ada.Text_IO.Put_Line ("Make_String...");
end loop;
Ada.Text_IO.Put (")");
elsif Is_Array(Obj) then
Ada.Text_IO.Put (" #(");
for X in Obj.Pointer_Slot'Range loop
if Is_Cons(Obj.Pointer_Slot(X)) or else Is_Array(Obj.Pointer_Slot(X)) then
Print_Object (Obj.Pointer_Slot(X));
else
Print_Atom (Obj.Pointer_Slot(X));
end if;
end loop;
Ada.Text_IO.Put (") ");
else
Print_Atom (Obj);
end if;
@ -2253,11 +2263,22 @@ end if;
Envir: Object_Pointer;
begin
-- Change various frame fields keeping the environment.
Envir := Get_Frame_Environment (Interp.Stack);
Envir := Get_Frame_Environment(Interp.Stack);
Pop_Frame (Interp);
Push_Frame_With_Environment (Interp, Opcode, Operand, Envir);
end Reload_Frame;
procedure Reload_Frame_With_Environment (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
Envir: in Object_Pointer) is
pragma Inline (Reload_Frame_With_Environment);
begin
-- Change various frame fields
Pop_Frame (Interp);
Push_Frame_With_Environment (Interp, Opcode, Operand, Envir);
end Reload_Frame_With_Environment;
procedure Reload_Frame_With_Intermediate (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
@ -2266,7 +2287,7 @@ end if;
Envir: Object_Pointer;
begin
-- Change various frame fields keeping the environment.
Envir := Get_Frame_Environment (Interp.Stack);
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;