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

implemented let

Browse Source
This commit is contained in:
hyung-hwan 2014-01-23 15:18:47 +00:00
parent 525e300dec
commit 99c7c03d14
4 changed files with 205 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -302,7 +302,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
-- For a closure created of "(lambda (x y) (+ x y) (* x y))" -- For a closure created of "(lambda (x y) (+ x y) (* x y))"
-- Get_Closure_Code(Func) returns "((x y) (+ x y) (* x y))" -- Get_Closure_Code(Func) returns "((x y) (+ x y) (* x y))"
-- Push a new environmen for the closure -- Push a new environment for the closure
Interp.Environment := Make_Environment(Interp.Self, Get_Closure_Environment(Func)); Interp.Environment := Make_Environment(Interp.Self, Get_Closure_Environment(Func));
Fbody := Get_Closure_Code(Func); Fbody := Get_Closure_Code(Func);

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

@ -170,6 +170,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
-- Check for a duplication formal argument
-- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated
V := Formals; V := Formals;
loop loop
exit when V = Cdr; exit when V = Cdr;
@ -182,6 +184,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
V := Get_Cdr(V); V := Get_Cdr(V);
end loop; end loop;
-- Move on to the next formal argument
Cdr := Get_Cdr(Cdr); Cdr := Get_Cdr(Cdr);
exit when not Is_Cons(Cdr); exit when not Is_Cons(Cdr);
end loop; end loop;
@ -219,6 +222,9 @@ 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);
Bindings: Object_Pointer;
LetBody: Object_Pointer;
begin begin
-- let <bindings> <body> -- let <bindings> <body>
Operand := Cdr; -- Skip "let". Operand := Cdr; -- Skip "let".
@ -229,74 +235,86 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Car := Get_Car(Operand); -- <bindings> Bindings := Get_Car(Operand); -- <bindings>
if not Is_Cons(Car) then if not Is_Cons(Bindings) then
Ada.Text_IO.Put_Line ("INVALID BINDINGS FOR LET"); Ada.Text_IO.Put_Line ("INVALID BINDINGS FOR LET");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Cdr := Get_Cdr(Operand); -- cons cell to <body> Letbody := Get_Cdr(Operand); -- Cons cell to <body>
if not Is_Cons(Cdr) then if not Is_Cons(Letbody) then
-- (let ((x 2)) ) -- (let ((x 2)) )
-- (let ((x 2)) . 99) -- (let ((x 2)) . 99)
Ada.Text_IO.Put_Line ("INVALID BODY FOR LET"); Ada.Text_IO.Put_Line ("INVALID BODY FOR LET");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Let_Syntax); Cdr := Bindings;
Set_Frame_Operand (Interp.Stack, Operand); loop
Car := Get_Car(Cdr); -- <binding>
if not Is_Cons(Car) or else not Is_Cons(Get_Cdr(Car)) or else Get_Cdr(Get_Cdr(Car)) /= Nil_Pointer then
-- no binding name or no binding value or garbage after that
Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET");
raise Syntax_Error;
end if;
declare if not Is_Symbol(Get_Car(Car)) then
Bindings: aliased Object_Pointer := Car; Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET");
Binding_Name: Object_Pointer; raise Syntax_Error;
Binding_Value: Object_Pointer; end if;
V: Object_Pointer;
begin
Push_Top (Interp, Bindings'Unchecked_Access);
Cdr := Bindings; -- Check for a duplicate binding name
loop -- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated
Car := Get_Car(Cdr); -- <binding> declare
if not Is_Cons(Car) or else not Is_Cons(Get_Cdr(Car)) or else Get_Cdr(Get_Cdr(Car)) /= Nil_Pointer then V: Object_Pointer;
Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET"); begin
raise Syntax_Error; V := Bindings;
end if; loop
exit when V = Cdr;
Binding_Name := Get_Car(Car); if Get_Car(Get_Car(V)) = Get_Car(Car) then
if not Is_Symbol(Binding_Name) then Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET");
Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET"); raise Syntax_Error;
raise Syntax_Error; end if;
end if;
Binding_Value := Get_Car(Get_Cdr(Car)); V := Get_Cdr(V);
Push_Frame (Interp, Opcode_Evaluate_Object, Binding_Value); end loop;
-- TODO: check duplicate end;
--V := Formals;
--loop
-- exit when V = Cdr;
-- if Get_Car(V) = Car then -- Move on to the next binding
-- Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET"); Cdr := Get_Cdr(Cdr);
-- raise Syntax_Error; exit when not Is_Cons(Cdr);
-- end if; end loop;
--
-- V := Get_Cdr(V);
-- end loop;
Cdr := Get_Cdr(Cdr); if Cdr /= Nil_Pointer then
exit when not Is_Cons(Cdr); -- The last cdr is not nil.
end loop; Ada.Text_IO.Put_Line ("FUCKING CDR FOR LET BINDING");
raise Syntax_Error;
end if;
Pop_Tops (Interp, 1); -- To avoid problems of temporary object pointer problems.
end; Car := Bindings;
Cdr := LetBody;
-- if Cdr /= Nil_Pointer and then not Is_Symbol(Cdr) then Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
-- Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA"); Set_Frame_Operand (Interp.Stack, Cdr);
-- raise Syntax_Error;
-- end if;
Push_Frame (Interp, Opcode_Let_Binding, Car);
Push_Frame (Interp, Opcode_Let_Evaluation, Car);
end Evaluate_Let_Syntax; end Evaluate_Let_Syntax;
procedure Evaluate_Letast_Syntax is
pragma Inline (Evaluate_Letast_Syntax);
begin
--Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
--Set_Frame_Operand (Interp.Stack, Cdr);
--Push_Frame (Interp, Opcode_Let_Binding, Car);
--Push_Frame (Interp, Opcode_Let_Evaluation, Car);
null;
end Evaluate_Letast_Syntax;
procedure Evaluate_Quote_Syntax is procedure Evaluate_Quote_Syntax is
pragma Inline (Evaluate_Quote_Syntax); pragma Inline (Evaluate_Quote_Syntax);
begin begin
@ -427,6 +445,9 @@ begin
when Let_Syntax => when Let_Syntax =>
Evaluate_Let_Syntax; Evaluate_Let_Syntax;
when Letast_Syntax =>
Evaluate_Letast_Syntax;
when Or_Syntax => when Or_Syntax =>
Evaluate_Or_Syntax; Evaluate_Or_Syntax;

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

@ -83,8 +83,8 @@ procedure Execute (Interp: in out Interpreter_Record) is
procedure Evaluate_Up_To; procedure Evaluate_Up_To;
procedure Evaluate_Up_To is procedure Evaluate_Up_To is
X: aliased Object_Pointer; X: Object_Pointer;
Y: aliased Object_Pointer; Y: Object_Pointer;
begin begin
X := Get_Frame_Operand(Interp.Stack); X := Get_Frame_Operand(Interp.Stack);
Y := Get_Frame_Result(Interp.Stack); Y := Get_Frame_Result(Interp.Stack);
@ -171,12 +171,74 @@ procedure Execute (Interp: in out Interpreter_Record) is
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Finish_If_Syntax; end Finish_If_Syntax;
procedure Finish_Let_Syntax is -- --------------------------------------------------------------------
pragma Inline (Finish_Let_Syntax);
procedure Do_Let_Evaluation is
pragma Inline (Do_Let_Evaluation);
X: Object_Pointer;
Y: Object_Pointer;
begin
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
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))));
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);
end if;
end Do_Let_Evaluation;
procedure Do_Let_Binding is
pragma Inline (Do_Let_Binding);
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
begin begin
ada.text_io.put_line ("Finish_Let_Syntax"); Push_Top (Interp, X'Unchecked_Access);
null; Push_Top (Interp, Y'Unchecked_Access);
end Finish_Let_Syntax;
X := Get_Frame_Operand(Interp.Stack); -- <bindings> and onward
Y := Get_Frame_Result(Interp.Stack);
pragma Assert (Interp.Environment = Get_Frame_Environment(Interp.Stack));
-- Push a new environment
Interp.Environment := Make_Environment(Interp.Self, Interp.Environment);
-- Change the frame's environment so that Pop_Frame() doesn't
-- restore the environment to the old one. The new environment
-- has been just pushed above after binding evaluation.
Set_Frame_Environment (Interp.Stack, Interp.Environment);
while Is_Cons(X) loop
pragma Assert (Is_Cons(Y));
Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y));
X := Get_Cdr(X);
Y := Get_Cdr(Y);
end loop;
Pop_Frame (Interp); -- done.
Pop_Tops (Interp, 2);
end Do_Let_Binding;
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);
end Do_Let_Finish;
-- --------------------------------------------------------------------
procedure Finish_Set_Syntax is procedure Finish_Set_Syntax is
pragma Inline (Finish_Set_Syntax); pragma Inline (Finish_Set_Syntax);
@ -828,33 +890,37 @@ begin
when Opcode_Evaluate_Group => when Opcode_Evaluate_Group =>
Evaluate_Group; Evaluate_Group;
when Opcode_Finish_And_Syntax =>
Finish_And_Syntax; -- Conditional
--when Opcode_Finish_Case_Syntax =>
--when Opcode_Finish_Cond_Syntax =>
when Opcode_Finish_Define_Symbol => when Opcode_Finish_Define_Symbol =>
Finish_Define_Symbol; Finish_Define_Symbol;
-- Conditionals
when Opcode_Finish_If_Syntax => when Opcode_Finish_If_Syntax =>
Finish_If_Syntax; Finish_If_Syntax; -- Conditional
--when Opcode_Finish_Cond_Syntax => -- Derived, Essential
--when Opcode_Finish_Case_Syntax => -- Derived
when Opcode_Finish_And_Syntax => -- Derived
Finish_And_Syntax;
when Opcode_Finish_Or_Syntax => -- Derived
Finish_Or_Syntax;
-- Assignments when Opcode_Let_Binding =>
when Opcode_Finish_Set_Syntax => Do_Let_Binding;
Finish_Set_Syntax; when Opcode_Let_Evaluation =>
Do_Let_Evaluation;
when Opcode_Let_Finish =>
Do_Let_Finish;
-- Bindings
when Opcode_Finish_Let_Syntax =>
Finish_Let_Syntax;
--when Opcode_Finish_Letast_Syntax => --when Opcode_Finish_Letast_Syntax =>
--when Opcode_Finish_Letrec_Syntax => --when Opcode_Finish_Letrec_Syntax =>
when Opcode_Finish_Or_Syntax =>
Finish_Or_Syntax; -- Conditional
when Opcode_Finish_Set_Syntax =>
Finish_Set_Syntax; -- Assignment
when Opcode_Apply => when Opcode_Apply =>
Apply; Apply;
-- Reading
when Opcode_Read_Object => when Opcode_Read_Object =>
Read_Object; Read_Object;

79
lib/h2-scheme.adb
View File

@ -88,7 +88,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 .. 16; subtype Opcode_Type is Object_Integer range 0 .. 18;
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);
@ -96,16 +96,20 @@ package body H2.Scheme is
Opcode_Finish_And_Syntax: constant Opcode_Type := Opcode_Type'(4); Opcode_Finish_And_Syntax: constant Opcode_Type := Opcode_Type'(4);
Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(5); Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(5);
Opcode_Finish_If_Syntax: constant Opcode_Type := Opcode_Type'(6); Opcode_Finish_If_Syntax: constant Opcode_Type := Opcode_Type'(6);
Opcode_Finish_Let_Syntax: constant Opcode_Type := Opcode_Type'(7); Opcode_Finish_Or_Syntax: constant Opcode_Type := Opcode_Type'(7);
Opcode_Finish_Or_Syntax: constant Opcode_Type := Opcode_Type'(8); Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(8);
Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(9);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(10); Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(9);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(11); Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(10);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(12); Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(11);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(13);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(14); Opcode_Apply: constant Opcode_Type := Opcode_Type'(12);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(15); Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(13);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(16); Opcode_Read_List: constant Opcode_Type := Opcode_Type'(14);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(15);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(16);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(17);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(18);
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- COMMON OBJECTS -- COMMON OBJECTS
@ -1253,21 +1257,20 @@ Ada.Text_IO.Put_Line ("Make_String...");
end if; end if;
end Put_Environment; end Put_Environment;
procedure Push_Environment (Interp: in out Interpreter_Record) is --procedure Push_Environment (Interp: in out Interpreter_Record) is
pragma Inline (Push_Environment); -- pragma Inline (Push_Environment);
pragma Assert (Is_Cons(Interp.Environment)); -- pragma Assert (Is_Cons(Interp.Environment));
begin --begin
Interp.Environment := Make_Environment(Interp.Self, Interp.Environment); -- Interp.Environment := Make_Environment(Interp.Self, Interp.Environment);
end Push_Environment; --end Push_Environment;
procedure Pop_Environment (Interp: in out Interpreter_Record) is --procedure Pop_Environment (Interp: in out Interpreter_Record) is
pragma Inline (Pop_Environment); -- pragma Inline (Pop_Environment);
pragma Assert (Is_Cons(Interp.Environment)); -- pragma Assert (Is_Cons(Interp.Environment));
begin --begin
Interp.Environment := Get_Cdr(Interp.Environment); -- Interp.Environment := Get_Cdr(Interp.Environment);
end Pop_Environment; --end Pop_Environment;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
function Make_Syntax (Interp: access Interpreter_Record; function Make_Syntax (Interp: access Interpreter_Record;
@ -1379,13 +1382,19 @@ Ada.Text_IO.Put_Line ("Make_String...");
return Frame.Pointer_Slot(Frame_Result_Index); return Frame.Pointer_Slot(Frame_Result_Index);
end Get_Frame_Result; end Get_Frame_Result;
--procedure Set_Frame_Result (Frame: in out Object_Pointer; procedure Set_Frame_Result (Frame: in out Object_Pointer;
-- Value: in Object_Pointer) is Value: in Object_Pointer) is
-- pragma Inline (Set_Frame_Result); pragma Inline (Set_Frame_Result);
-- pragma Assert (Is_Frame(Frame)); pragma Assert (Is_Frame(Frame));
--begin
-- Frame.Pointer_Slot(Frame_Result_Index) := Value; -- This procedure is not to set a single result,
--end Set_Frame_Result; -- but to set the result chain. so it can be useful
-- if you want to migrate a result chain from one frame
-- to another. It's what this assertion is for.
pragma Assert (Is_Cons(Value));
begin
Frame.Pointer_Slot(Frame_Result_Index) := Value;
end Set_Frame_Result;
procedure Chain_Frame_Result (Interp: in out Interpreter_Record; procedure Chain_Frame_Result (Interp: in out Interpreter_Record;
Frame: in Object_Pointer; -- TODO: remove this parameter Frame: in Object_Pointer; -- TODO: remove this parameter
@ -1422,6 +1431,14 @@ Ada.Text_IO.Put_Line ("Make_String...");
return Frame.Pointer_Slot(Frame_Environment_Index); return Frame.Pointer_Slot(Frame_Environment_Index);
end Get_Frame_Environment; end Get_Frame_Environment;
procedure Set_Frame_Environment (Frame: in Object_Pointer;
Value: in Object_Pointer) is
pragma Inline (Set_Frame_Environment);
pragma Assert (Is_Frame(Frame));
begin
Frame.Pointer_Slot(Frame_Environment_Index) := Value;
end Set_Frame_Environment;
function Get_Frame_Opcode (Frame: in Object_Pointer) return Opcode_Type is function Get_Frame_Opcode (Frame: in Object_Pointer) return Opcode_Type is
pragma Inline (Get_Frame_Opcode); pragma Inline (Get_Frame_Opcode);
pragma Assert (Is_Frame(Frame)); pragma Assert (Is_Frame(Frame));