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

implemented letrec and corrected let and let*

Browse Source
This commit is contained in:
hyung-hwan 2014-01-26 14:58:02 +00:00
parent 4b4f8de4fd
commit 4208d8f2df
4 changed files with 79 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,7 +2,7 @@
separate (H2.Scheme.Execute) separate (H2.Scheme.Execute)
procedure Apply is procedure Apply is
pragma Inline (Apply); --pragma Inline (Apply);
Operand: aliased Object_Pointer; Operand: aliased Object_Pointer;
Func: aliased Object_Pointer; Func: aliased Object_Pointer;

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

@ -1,7 +1,7 @@
separate (H2.Scheme.Execute) separate (H2.Scheme.Execute)
procedure Evaluate is procedure Evaluate is
pragma Inline (Evaluate); --pragma Inline (Evaluate);
Operand: aliased Object_Pointer; Operand: aliased Object_Pointer;
Car: aliased Object_Pointer; Car: aliased Object_Pointer;
@ -301,7 +301,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
procedure Evaluate_Let_Syntax is procedure Evaluate_Let_Syntax is
pragma Inline (Evaluate_Let_Syntax); pragma Inline (Evaluate_Let_Syntax);
Envir: Object_Pointer; Envir: aliased Object_Pointer;
begin begin
Check_Let_Syntax; Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body> -- Car: <bindings>, Cdr: <body>
@ -309,7 +309,10 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
Set_Frame_Operand (Interp.Stack, Cdr); Set_Frame_Operand (Interp.Stack, Cdr);
-- Push a new environment to the current frame. -- 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)); Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir); Set_Frame_Environment (Interp.Stack, Envir);
@ -320,12 +323,25 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
-- x ; this must be 99. -- x ; this must be 99.
-- --
-- #2. -- #2.
-- ... -- (define x 10) ; x-outer
-- (define y (let ((x (+ x 1))) x)) ; x-inner := x-outer + 1, y := x-inner
-- y ; 11
-- x ; 10
--
if Car /= Nil_Pointer then if Car /= Nil_Pointer then
-- <bindings> is not empty -- <bindings> is not empty
Push_Top (Interp, Envir'Unchecked_Access);
Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack));
-- 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, Car);
Push_Frame (Interp, Opcode_Let_Evaluation, 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, Car, Envir);
Pop_Tops (Interp, 1);
end if; end if;
end Evaluate_Let_Syntax; end Evaluate_Let_Syntax;
@ -339,13 +355,14 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
Set_Frame_Operand (Interp.Stack, Cdr); Set_Frame_Operand (Interp.Stack, Cdr);
-- Push a new environment to the current frame.
Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
Set_Frame_Environment (Interp.Stack, Envir);
if Car /= Nil_Pointer then if Car /= Nil_Pointer then
-- <bindings> is not empty -- <bindings> is not empty
Push_Frame (Interp, Opcode_Letast_Binding, Car); 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);
end if; end if;
end Evaluate_Letast_Syntax; end Evaluate_Letast_Syntax;
@ -356,18 +373,20 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Check_Let_Syntax; Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body> -- Car: <bindings>, Cdr: <body>
ada.text_io.put_line ("XXXXX <<< LETREC IMPLEMENTATION NEEDED >>XXXXXXXXXXXXXXXXXXXXXXXXXXX"); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
--Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Operand (Interp.Stack, Cdr);
--Set_Frame_Operand (Interp.Stack, Cdr);
-- Push a new environment to the current frame. -- Push a new 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);
--if Car /= Nil_Pointer then if Car /= Nil_Pointer then
-- <bindings> is not empty -- <bindings> is not empty
-- Push_Frame (Interp, Opcode_Letrec_Binding, Car); -- Arrange to perform evaluataion and binding in the
--end if; -- new environment created.
Push_Frame (Interp, Opcode_Let_Binding, Car);
Push_Frame (Interp, Opcode_Let_Evaluation, Car);
end if;
end Evaluate_Letrec_Syntax; end Evaluate_Letrec_Syntax;
procedure Evaluate_Quote_Syntax is procedure Evaluate_Quote_Syntax is

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

@ -224,6 +224,8 @@ procedure Execute (Interp: in out Interpreter_Record) is
end loop; end loop;
Pop_Frame (Interp); -- done. Pop_Frame (Interp); -- done.
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish);
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Do_Let_Binding; end Do_Let_Binding;
@ -231,9 +233,11 @@ procedure Execute (Interp: in out Interpreter_Record) is
pragma Inline (Do_Letast_Binding); pragma Inline (Do_Letast_Binding);
X: aliased Object_Pointer; X: aliased Object_Pointer;
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
Envir: 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, Y'Unchecked_Access);
Push_Top (Interp, Envir'Unchecked_Access);
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);
@ -241,25 +245,36 @@ procedure Execute (Interp: in out Interpreter_Record) is
if Y = Nil_Pointer then if Y = Nil_Pointer then
-- First call -- First call
pragma Assert (Is_Cons(X)); -- Don't provoke this procedure if <bindings> is empty. 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)))); Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
else else
-- Subsequence calls -- Subsequence calls. Update the environment while evaluating <bindings>
-- 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)); Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y));
X := Get_Cdr(X); -- next binding X := Get_Cdr(X); -- next binding
if Is_Cons(X) then if Is_Cons(X) then
-- More bingings to evaluate -- More bingings to evaluate
Set_Frame_Operand (Interp.Stack, X); Set_Frame_Operand (Interp.Stack, X);
Clear_Frame_Result (Interp.Stack); 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)))); Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))));
else else
-- No more bingings left -- No more bingings left
Pop_Frame (Interp); -- Done 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;
end if; end if;
Pop_Tops (Interp, 2); Pop_Tops (Interp, 3);
end Do_Letast_Binding; end Do_Letast_Binding;
procedure Do_Let_Finish is procedure Do_Let_Finish is

29
lib/h2-scheme.adb
View File

@ -119,7 +119,7 @@ package body H2.Scheme is
Cons_Cdr_Index: constant Pointer_Object_Size := 2; Cons_Cdr_Index: constant Pointer_Object_Size := 2;
Frame_Object_Size: constant Pointer_Object_Size := 5; Frame_Object_Size: constant Pointer_Object_Size := 5;
Frame_Stack_Index: constant Pointer_Object_Size := 1; Frame_Parent_Index: constant Pointer_Object_Size := 1;
Frame_Opcode_Index: constant Pointer_Object_Size := 2; Frame_Opcode_Index: constant Pointer_Object_Size := 2;
Frame_Operand_Index: constant Pointer_Object_Size := 3; Frame_Operand_Index: constant Pointer_Object_Size := 3;
Frame_Environment_Index: constant Pointer_Object_Size := 4; Frame_Environment_Index: constant Pointer_Object_Size := 4;
@ -1135,7 +1135,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- Since it's used for stack, it can be made special. -- Since it's used for stack, it can be made special.
Frame := Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer); Frame := Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer);
Frame.Tag := Frame_Object; Frame.Tag := Frame_Object;
Frame.Pointer_Slot(Frame_Stack_Index) := Aliased_Stack; Frame.Pointer_Slot(Frame_Parent_Index) := Aliased_Stack;
Frame.Pointer_Slot(Frame_Opcode_Index) := Aliased_Opcode; Frame.Pointer_Slot(Frame_Opcode_Index) := Aliased_Opcode;
Frame.Pointer_Slot(Frame_Operand_Index) := Aliased_Operand; Frame.Pointer_Slot(Frame_Operand_Index) := Aliased_Operand;
Frame.Pointer_Slot(Frame_Environment_Index) := Aliased_Envir; Frame.Pointer_Slot(Frame_Environment_Index) := Aliased_Envir;
@ -1247,6 +1247,13 @@ Ada.Text_IO.Put_Line ("Make_String...");
end Set_Frame_Operand; end Set_Frame_Operand;
function Get_Frame_Parent (Frame: in Object_Pointer) return Object_Pointer is
pragma Inline (Get_Frame_Parent);
pragma Assert (Is_Frame(Frame));
begin
return Frame.Pointer_Slot(Frame_Parent_Index);
end Get_Frame_Parent;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
@ -1962,7 +1969,7 @@ end if;
else else
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
Operand := Stack.Pointer_Slot(Frame_Operand_Index); Operand := Stack.Pointer_Slot(Frame_Operand_Index);
Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop
end if; end if;
end if; end if;
@ -1987,7 +1994,7 @@ end if;
else else
Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
Operand := Stack.Pointer_Slot(Frame_Operand_Index); Operand := Stack.Pointer_Slot(Frame_Operand_Index);
Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop
end if; end if;
end if; end if;
@ -2008,15 +2015,25 @@ end if;
Operand: in Object_Pointer) is Operand: in Object_Pointer) is
pragma Inline (Push_Frame); pragma Inline (Push_Frame);
begin begin
Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Operand, Get_Frame_Environment(Interp.Stack)); Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode),
Operand, Get_Frame_Environment(Interp.Stack));
end Push_Frame; end Push_Frame;
procedure Push_Frame_With_Environment (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer;
Envir: in Object_Pointer) is
pragma Inline (Push_Frame_With_Environment);
begin
Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Operand, Envir);
end Push_Frame_With_Environment;
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
pragma Assert (Interp.Stack /= Interp.Root_Frame); pragma Assert (Interp.Stack /= Interp.Root_Frame);
pragma Assert (Interp.Stack /= Nil_Pointer); pragma Assert (Interp.Stack /= Nil_Pointer);
Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Parent_Index); -- pop
end Pop_Frame; end Pop_Frame;
procedure Execute (Interp: in out Interpreter_Record) is separate; procedure Execute (Interp: in out Interpreter_Record) is separate;