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

implemented and and or

Browse Source
This commit is contained in:
hyung-hwan 2014-01-23 13:41:41 +00:00
parent 6eb0e65d00
commit 525e300dec
3 changed files with 126 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7,6 +7,43 @@ procedure Evaluate is
Car: aliased Object_Pointer;
Cdr: aliased Object_Pointer;
generic
V: Object_Pointer;
Opcode: Opcode_Type;
procedure Generic_And_Or_Syntax;
procedure Generic_And_Or_Syntax is
begin
-- (and <test1> <test2> ...)
-- (and (= 2 2) (> 2 1)) ==> #t
-- (and (= 2 2) (< 2 1)) ==> #f
-- (and (= 2 2) (< 2 1) (= 3 3)) ==> #f
-- (and 1 2 'c '(f g)) ==> (f g)
-- (and) ==> #t
Operand := Cdr; -- Skip "And"
if Operand = Nil_Pointer then
-- (and)
Pop_Frame (Interp);
Chain_Frame_Result (Interp, Interp.Stack, V);
elsif not Is_Cons(Operand) or else Get_Last_Cdr(Operand) /= Nil_Pointer then
-- (and . 10)
-- (and 1 2 . 10)
Ada.Text_IO.Put_LINE ("FUCKING cDR FOR DEFINE");
raise Syntax_Error;
else
Set_Frame_Opcode (Interp.Stack, Opcode);
Set_Frame_Operand (Interp.Stack, Get_Cdr(Operand)); -- <test2> onwards
Clear_Frame_Result (Interp.Stack);
-- arrange to evaluate <test1>
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand));
end if;
end Generic_And_Or_Syntax;
procedure Evaluate_And_Syntax is new Generic_And_Or_Syntax(True_Pointer, Opcode_Finish_And_Syntax);
procedure Evaluate_Or_Syntax is new Generic_And_Or_Syntax(False_Pointer, Opcode_Finish_Or_Syntax);
procedure Evaluate_Define_Syntax is
pragma Inline (Evaluate_Define_Syntax);
begin
@ -92,7 +129,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if;
-- Switch the current frame to execute action after <test> evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If);
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If_Syntax);
Set_Frame_Operand (Interp.Stack, Operand);
-- Arrange to evalaute the conditional
@ -206,7 +243,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error;
end if;
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Let);
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Let_Syntax);
Set_Frame_Operand (Interp.Stack, Operand);
declare
@ -303,7 +340,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Cdr := Get_Car(Cdr); -- <expression>
-- Arrange to finish setting a variable after <expression> evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Set);
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Set_Syntax);
Set_Frame_Operand (Interp.Stack, Car);
-- Arrange to evalaute the value part
@ -351,6 +388,9 @@ begin
-- apply for special syntax objects.
case Car.Scode is
when And_Syntax =>
Evaluate_And_Syntax;
when Begin_Syntax =>
Operand := Cdr; -- Skip "begin"
@ -387,6 +427,9 @@ begin
when Let_Syntax =>
Evaluate_Let_Syntax;
when Or_Syntax =>
Evaluate_Or_Syntax;
when Quote_Syntax =>
Evaluate_Quote_Syntax;

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

@ -77,6 +77,42 @@ procedure Execute (Interp: in out Interpreter_Record) is
Pop_Tops (Interp, 3);
end Evaluate_Group;
-- ----------------------------------------------------------------
generic
V: Object_Pointer;
procedure Evaluate_Up_To;
procedure Evaluate_Up_To is
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
begin
X := Get_Frame_Operand(Interp.Stack);
Y := Get_Frame_Result(Interp.Stack);
-- Evaluate_And_Syntax/Evaluate-Or_Syntax has arranged to
-- evaluate <test1>. Y must not be Nil_Pointer even at the
-- first time this procedure is called,
pragma Assert (Is_Cons(Y));
pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure 1 resul
Y := Get_Car(Y); -- actual result
if Y /= V and then Is_Cons(X) then
-- The result is not what I look for.
-- Yet there are still more tests to evaluate.
Set_Frame_Operand (Interp.Stack, Get_Cdr(X));
Clear_Frame_Result (Interp.Stack);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
else
-- Return the result of the last expression evaluated.
Pop_Frame (Interp);
Chain_Frame_Result (Interp, Interp.Stack, Y);
end if;
end Evaluate_Up_To;
procedure Finish_And_Syntax is new Evaluate_Up_To(False_Pointer);
procedure Finish_Or_Syntax is new Evaluate_Up_To(True_Pointer);
-- ----------------------------------------------------------------
procedure Finish_Define_Symbol is
pragma Inline (Finish_Define_Symbol);
X: aliased Object_Pointer;
@ -100,8 +136,8 @@ procedure Execute (Interp: in out Interpreter_Record) is
Pop_Tops (Interp, 2);
end Finish_Define_Symbol;
procedure Finish_If is
pragma Inline (Finish_If);
procedure Finish_If_Syntax is
pragma Inline (Finish_If_Syntax);
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
Z: aliased Object_Pointer;
@ -133,17 +169,17 @@ procedure Execute (Interp: in out Interpreter_Record) is
end if;
Pop_Tops (Interp, 2);
end Finish_If;
end Finish_If_Syntax;
procedure Finish_Let is
pragma Inline (Finish_Let);
procedure Finish_Let_Syntax is
pragma Inline (Finish_Let_Syntax);
begin
ada.text_io.put_line ("Finish_Let");
ada.text_io.put_line ("Finish_Let_Syntax");
null;
end Finish_Let;
end Finish_Let_Syntax;
procedure Finish_Set is
pragma Inline (Finish_Set);
procedure Finish_Set_Syntax is
pragma Inline (Finish_Set_Syntax);
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
begin
@ -164,7 +200,7 @@ ada.text_io.put_line ("Finish_Let");
Chain_Frame_Result (Interp, Interp.Stack, Y);
Pop_Tops (Interp, 2);
end Finish_Set;
end Finish_Set_Syntax;
procedure Evaluate is separate;
procedure Apply is separate;
@ -795,18 +831,30 @@ begin
when Opcode_Finish_Define_Symbol =>
Finish_Define_Symbol;
when Opcode_Finish_If =>
Finish_If;
-- Conditionals
when Opcode_Finish_If_Syntax =>
Finish_If_Syntax;
--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;
when Opcode_Finish_Let =>
Finish_Let;
-- Assignments
when Opcode_Finish_Set_Syntax =>
Finish_Set_Syntax;
when Opcode_Finish_Set =>
Finish_Set;
-- Bindings
when Opcode_Finish_Let_Syntax =>
Finish_Let_Syntax;
--when Opcode_Finish_Letast_Syntax =>
--when Opcode_Finish_Letrec_Syntax =>
when Opcode_Apply =>
Apply;
-- Reading
when Opcode_Read_Object =>
Read_Object;

27
lib/h2-scheme.adb
View File

@ -88,22 +88,24 @@ package body H2.Scheme is
subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
subtype Opcode_Type is Object_Integer range 0 .. 14;
subtype Opcode_Type is Object_Integer range 0 .. 16;
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);
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply
Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4);
Opcode_Finish_If: constant Opcode_Type := Opcode_Type'(5);
Opcode_Finish_Let: constant Opcode_Type := Opcode_Type'(6);
Opcode_Finish_Set: constant Opcode_Type := Opcode_Type'(7);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(9);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(10);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(11);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(12);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(13);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(14);
Opcode_Finish_And_Syntax: constant Opcode_Type := Opcode_Type'(4);
Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(5);
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'(8);
Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(9);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(10);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(11);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(12);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(13);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(14);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(15);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(16);
-----------------------------------------------------------------------------
-- COMMON OBJECTS
@ -1222,6 +1224,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- environment. If no key is found, add a new pair
-- This is mainly for define.
pragma Assert (Is_Symbol(Key));
pragma Assert (Is_Cons(Interp.Environment));
Arr := Find_In_Environment_List(Interp.Self, Get_Car(Interp.Environment), Key);
if Arr /= null then