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

fixed bugs in and/or handlers

Browse Source
This commit is contained in:
hyung-hwan 2014-02-08 03:53:53 +00:00
parent d3363e11e5
commit b2088d0891
3 changed files with 40 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8,8 +8,8 @@ procedure Evaluate is
Cdr: aliased Object_Pointer;
generic
V: Object_Pointer;
Opcode: Opcode_Type;
Result: Object_Pointer; -- Result to return if no <test> expressions exist.
Opcode: Opcode_Type; -- Switch to this opcode to evaluate the next <test>.
procedure Generic_And_Or_Syntax;
procedure Generic_And_Or_Syntax is
@ -17,14 +17,14 @@ procedure Evaluate is
-- (and <test1> <test2> ...)
-- (and (= 2 2) (> 2 1)) ==> #t
-- (and (= 2 2) (< 2 1)) ==> #f
-- (and (= 2 2) (< 2 1) (= 3 3)) ==> #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)
Return_Frame (Interp, V);
Return_Frame (Interp, Result);
elsif not Is_Cons(Operand) or else Get_Last_Cdr(Operand) /= Nil_Pointer then
-- (and . 10)
-- (and 1 2 . 10)
@ -38,8 +38,8 @@ procedure Evaluate is
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_And_Syntax is new Generic_And_Or_Syntax(True_Pointer, Opcode_And_Finish);
procedure Evaluate_Or_Syntax is new Generic_And_Or_Syntax(False_Pointer, Opcode_Or_Finish);
procedure Evaluate_Define_Syntax is
pragma Inline (Evaluate_Define_Syntax);

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

@ -21,10 +21,10 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- ----------------------------------------------------------------
generic
V: Object_Pointer;
procedure Evaluate_Up_To;
with function Is_Bool (X: in Object_Pointer) return Standard.Boolean;
procedure Evaluate_While;
procedure Evaluate_Up_To is
procedure Evaluate_While is
X: Object_Pointer;
Y: Object_Pointer;
Opcode: Opcode_Type;
@ -36,7 +36,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- evaluate <test1>. Y must be valid even at the first time
-- this procedure is called.
if Y /= V and then Is_Cons(X) then
if Is_Bool(Y) and then Is_Cons(X) then
-- The result is not what I look for.
-- Yet there are still more tests to evaluate.
--Switch_Frame (Interp.Stack, Get_Frame_Opcode(Interp.Stack), Get_Cdr(X), Nil_Pointer);
@ -49,10 +49,22 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- Return the result of the last expression evaluated.
Return_Frame (Interp, Y);
end if;
end Evaluate_Up_To;
end Evaluate_While;
procedure Finish_And_Syntax is new Evaluate_Up_To(False_Pointer);
procedure Finish_Or_Syntax is new Evaluate_Up_To(True_Pointer); -----> this is wrong, it shoudl be able to specify "/= False_Pointer".
function Is_False (X: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_False);
begin
return X = False_Pointer;
end Is_False;
function Is_True (X: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_True);
begin
return X /= False_Pointer;
end Is_True;
procedure Do_And_Finish is new Evaluate_While(Is_True);
procedure Do_Or_Finish is new Evaluate_While(Is_False);
-- ----------------------------------------------------------------
procedure Do_Define_Finish is
@ -934,39 +946,48 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
when Opcode_Evaluate_Object =>
Evaluate;
when Opcode_Finish_And_Syntax =>
Finish_And_Syntax; -- Conditional
when Opcode_And_Finish =>
Do_And_Finish;
--when Opcode_Finish_Case_Syntax =>
--when Opcode_Finish_Cond_Syntax =>
when Opcode_Define_Finish =>
Do_Define_Finish;
when Opcode_Grouped_Call =>
Do_Grouped_Call;
when Opcode_If_Finish =>
Do_If_Finish; -- Conditional
when Opcode_Let_Binding =>
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 =>
Do_Let_Finish;
when Opcode_Or_Finish =>
Do_Or_Finish;
when Opcode_Procedure_Call =>
Do_Procedure_Call;
when Opcode_Procedure_Call_Finish =>
Do_Procedure_Call_Finish;
when Opcode_Set_Finish =>
Do_Set_Finish; -- Assignment
when Opcode_Finish_Or_Syntax =>
Finish_Or_Syntax; -- Conditional
when Opcode_Apply =>
Apply;

4
lib/h2-scheme.adb
View File

@ -97,9 +97,9 @@ package body H2.Scheme is
Opcode_Exit,
Opcode_Evaluate_Result,
Opcode_Evaluate_Object,
Opcode_Finish_And_Syntax,
Opcode_Finish_Or_Syntax,
Opcode_And_Finish,
Opcode_Or_Finish,
Opcode_Define_Finish,
Opcode_Grouped_Call, -- (begin ...), closure apply, let body
Opcode_If_Finish,