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

repaired broken let, letast, letrec handling

Browse Source
This commit is contained in:
hyung-hwan
2014-01-28 17:03:52 +00:00
parent a6320b76b8
commit ff9ab83844
3 changed files with 129 additions and 74 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -341,13 +341,17 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
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
Cdr := Make_Array (Interp.Self, 3);
Cdr.Pointer_Slot(1) := Car;
-- The actual binding after evaluation must be performed in the -- The actual binding after evaluation must be performed in the
-- new environment. -- new environment.
Push_Frame (Interp, Opcode_Let_Binding, Car); Push_Frame (Interp, Opcode_Let_Binding, Cdr);
-- But evaluation must be done in the current environment which is -- But evaluation must be done in the current environment which is
-- the environment before the environment update above. -- the environment before the environment update above.
Push_Frame_With_Environment (Interp, Opcode_Let_Evaluation, Car, Envir); 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;
@ -393,8 +397,11 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
-- <bindings> is not empty -- <bindings> is not empty
-- Arrange to perform evaluataion and binding in the -- Arrange to perform evaluataion and binding in the
-- new environment created. -- new environment created.
Push_Frame (Interp, Opcode_Let_Binding, Car); Cdr := Make_Array (Interp.Self, 3);
Push_Frame (Interp, Opcode_Let_Evaluation, Car); Cdr.Pointer_Slot(1) := Car;
Push_Frame (Interp, Opcode_Let_Binding, Cdr);
Push_Frame (Interp, Opcode_Let_Evaluation, Cdr);
end if; end if;
end Evaluate_Letrec_Syntax; end Evaluate_Letrec_Syntax;

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

@ -145,15 +145,15 @@ procedure Execute (Interp: in out Interpreter_Record) is
R := Make_Cons(Interp.Self, Get_Car(Get_Frame_Result(Interp.Stack)), R); R := Make_Cons(Interp.Self, Get_Car(Get_Frame_Result(Interp.Stack)), R);
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
if not Is_Cons(S) then if Is_Cons(S) then
Set_Cdr (X, R); -- chain the result
Set_Car (X, Get_Cdr(S)); -- remember the next <operator> to evaluate
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(S));
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.
Set_Frame_Opcode (Interp.Stack, Opcode_Apply); Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Reverse_Cons(R)); Set_Frame_Operand (Interp.Stack, Reverse_Cons(R));
else
Set_Cdr (X, R);
Set_Car (X, Get_Cdr(S));
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(S));
end if; end if;
Pop_Tops (Interp, 3); Pop_Tops (Interp, 3);
@ -216,56 +216,108 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
procedure Do_Let_Evaluation is procedure Do_Let_Evaluation is
pragma Inline (Do_Let_Evaluation); pragma Inline (Do_Let_Evaluation);
X: Object_Pointer; X: aliased Object_Pointer;
Y: Object_Pointer; S: aliased Object_Pointer;
R: aliased Object_Pointer;
begin begin
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, S'Unchecked_Access);
Push_Top (Interp, R'Unchecked_Access);
if Is_Cons(X) then X := Get_Frame_Operand(Interp.Stack);
Set_Frame_Operand (Interp.Stack, Get_Cdr(X)); pragma Assert (Is_Array(X));
-- Say, <bindings> is ((x 2) (y 2)).
-- for the first call, Get_Car(X) is (x 2). R := X.Pointer_Slot(3);
-- To get x, Get_Car(Get_Car(X)) if R = Nil_Pointer then
-- To get 2, Get_Car(Get_Cdr(Get_Car(X))) -- First call;
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X)))); X.Pointer_Slot(2) := X.Pointer_Slot(1);
else else
-- Pass the result to the Perform_Let_Binding frame. -- Subsequent calls. Store the result in the room created
Y := Get_Frame_Result(Interp.Stack); -- in the previous call.
Pop_Frame (Interp); pragma Assert (Is_Cons(R));
Set_Frame_Result (Interp.Stack, Y); Set_Car (R, Get_Car(Get_Frame_Result(Interp.Stack)));
end if; end if;
end Do_Let_Evaluation; 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; X: aliased Object_Pointer;
Y: aliased Object_Pointer; S: aliased Object_Pointer;
R: 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, S'Unchecked_Access);
Push_Top (Interp, R'Unchecked_Access);
-- Evaluation of <bindings> is completed.
-- Update the environments.
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
Y := Reverse_Cons(Get_Frame_Result(Interp.Stack)); pragma Assert (Is_Array(X));
while Is_Cons(X) loop S := X.Pointer_Slot(1);
pragma Assert (Is_Cons(Y)); R := X.Pointer_Slot(3);
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y)); R := Reverse_Cons(R);
X := Get_Cdr(X); while Is_Cons(S) loop
Y := Get_Cdr(Y); 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; end loop;
Pop_Frame (Interp); -- done. Pop_Frame (Interp); -- done.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish); pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish);
Pop_Tops (Interp, 2); Pop_Tops (Interp, 3);
end Do_Let_Binding; end Do_Let_Binding;
procedure Do_Letast_Binding is procedure Do_Letast_Binding is
pragma Inline (Do_Letast_Binding); 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; X: aliased Object_Pointer;
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
Envir: aliased Object_Pointer; Envir: aliased Object_Pointer;
@ -277,13 +329,7 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
Y := Get_Frame_Result(Interp.Stack); Y := Get_Frame_Result(Interp.Stack);
if Y = Nil_Pointer then -- Update the environment while evaluating <bindings>
-- First call
pragma Assert (Is_Cons(X)); -- Don't provoke this procedure if <bindings> is empty.
Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
else
-- Subsequence calls. Update the environment while evaluating <bindings>
-- 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));
@ -307,10 +353,9 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
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;
end if;
Pop_Tops (Interp, 3); Pop_Tops (Interp, 3);
end Do_Letast_Binding; end Do_Letast_Binding_Finish;
procedure Do_Let_Finish is procedure Do_Let_Finish is
pragma Inline (Do_Let_Finish); pragma Inline (Do_Let_Finish);
@ -994,6 +1039,8 @@ begin
Do_Let_Binding; Do_Let_Binding;
when Opcode_Letast_Binding => when Opcode_Letast_Binding =>
Do_Letast_Binding; Do_Letast_Binding;
when Opcode_Letast_Binding_Finish =>
Do_Letast_Binding_Finish;
when Opcode_Let_Evaluation => when Opcode_Let_Evaluation =>
Do_Let_Evaluation; Do_Let_Evaluation;
when Opcode_Let_Finish => when Opcode_Let_Finish =>

25
h2/lib/h2-scheme.adb
View File

@ -93,7 +93,7 @@ package body H2.Scheme is
subtype Moved_Object_Record is Object_Record (Moved_Object, 0); subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
subtype Opcode_Type is Object_Integer range 0 .. 21; subtype Opcode_Type is Object_Integer range 0 .. 22;
Opcode_Exit: constant Opcode_Type := Opcode_Type'(0); Opcode_Exit: constant Opcode_Type := Opcode_Type'(0);
Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1); Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1);
Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2); Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2);
@ -106,18 +106,19 @@ package body H2.Scheme is
Opcode_Grouped_Call_Finish: constant Opcode_Type := Opcode_Type'(8); Opcode_Grouped_Call_Finish: constant Opcode_Type := Opcode_Type'(8);
Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(9); Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(9);
Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(10); Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(10);
Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(11); Opcode_Letast_Binding_Finish:constant Opcode_Type := Opcode_Type'(11);
Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(12); Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(12);
Opcode_Procedure_Call: constant Opcode_Type := Opcode_Type'(13); Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(13);
Opcode_Set_Finish: constant Opcode_Type := Opcode_Type'(14); Opcode_Procedure_Call: constant Opcode_Type := Opcode_Type'(14);
Opcode_Set_Finish: constant Opcode_Type := Opcode_Type'(15);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(15); Opcode_Apply: constant Opcode_Type := Opcode_Type'(16);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(16); Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(17);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(17); Opcode_Read_List: constant Opcode_Type := Opcode_Type'(18);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(18); Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(19);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(19); Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(20);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(20); Opcode_Close_List: constant Opcode_Type := Opcode_Type'(21);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(21); Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(22);
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- COMMON OBJECTS -- COMMON OBJECTS