hyung-hwan/hcl
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 04aa5de83c
commit 0af4a9347d
3 changed files with 129 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
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);
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
-- 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
-- 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);
end if;
end Evaluate_Let_Syntax;
@ -393,8 +397,11 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
-- <bindings> is not empty
-- Arrange to perform evaluataion and binding in the
-- new environment created.
Push_Frame (Interp, Opcode_Let_Binding, Car);
Push_Frame (Interp, Opcode_Let_Evaluation, Car);
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);
end if;
end Evaluate_Letrec_Syntax;

163
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);
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.
-- apply the evaluated arguments to the evaluated operator.
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
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;
Pop_Tops (Interp, 3);
@ -216,56 +216,108 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
procedure Do_Let_Evaluation is
pragma Inline (Do_Let_Evaluation);
X: Object_Pointer;
Y: Object_Pointer;
X: aliased Object_Pointer;
S: aliased Object_Pointer;
R: aliased Object_Pointer;
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
Set_Frame_Operand (Interp.Stack, Get_Cdr(X));
-- Say, <bindings> is ((x 2) (y 2)).
-- for the first call, Get_Car(X) is (x 2).
-- To get x, Get_Car(Get_Car(X))
-- To get 2, Get_Car(Get_Cdr(Get_Car(X)))
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
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
-- Pass the result to the Perform_Let_Binding frame.
Y := Get_Frame_Result(Interp.Stack);
Pop_Frame (Interp);
Set_Frame_Result (Interp.Stack, Y);
-- Subsequent calls. Store the result in the room created
-- in the previous call.
pragma Assert (Is_Cons(R));
Set_Car (R, Get_Car(Get_Frame_Result(Interp.Stack)));
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
pragma Inline (Do_Let_Binding);
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
S: aliased Object_Pointer;
R: aliased Object_Pointer;
begin
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
Y := Reverse_Cons(Get_Frame_Result(Interp.Stack));
pragma Assert (Is_Array(X));
while Is_Cons(X) loop
pragma Assert (Is_Cons(Y));
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y));
S := X.Pointer_Slot(1);
R := X.Pointer_Slot(3);
R := Reverse_Cons(R);
X := Get_Cdr(X);
Y := Get_Cdr(Y);
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;
Pop_Frame (Interp); -- done.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish);
Pop_Tops (Interp, 2);
Pop_Tops (Interp, 3);
end Do_Let_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;
Y: aliased Object_Pointer;
Envir: aliased Object_Pointer;
@ -277,40 +329,33 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer);
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
Y := Get_Frame_Result(Interp.Stack);
if Y = Nil_Pointer then
-- 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));
-- 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);
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y));
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
-- Subsequence calls. Update the environment while evaluating <bindings>
-- No more bingings left
Pop_Frame (Interp); -- Done
-- Push a new environment for each binding.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
-- Update the environment of the Let_Finish frame.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish);
Set_Frame_Environment (Interp.Stack, Envir);
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y));
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;
end if;
Pop_Tops (Interp, 3);
end Do_Letast_Binding;
end Do_Letast_Binding_Finish;
procedure Do_Let_Finish is
pragma Inline (Do_Let_Finish);
@ -994,6 +1039,8 @@ begin
Do_Let_Binding;
when Opcode_Letast_Binding =>
Do_Letast_Binding;
when Opcode_Letast_Binding_Finish =>
Do_Letast_Binding_Finish;
when Opcode_Let_Evaluation =>
Do_Let_Evaluation;
when Opcode_Let_Finish =>

25
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 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_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1);
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_Let_Binding: constant Opcode_Type := Opcode_Type'(9);
Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(10);
Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(11);
Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(12);
Opcode_Procedure_Call: constant Opcode_Type := Opcode_Type'(13);
Opcode_Set_Finish: constant Opcode_Type := Opcode_Type'(14);
Opcode_Letast_Binding_Finish:constant Opcode_Type := Opcode_Type'(11);
Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(12);
Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(13);
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_Read_Object: constant Opcode_Type := Opcode_Type'(16);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(17);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(18);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(19);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(20);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(21);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(16);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(17);
Opcode_Read_List: 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'(20);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(21);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(22);
-----------------------------------------------------------------------------
-- COMMON OBJECTS