From 07503c4da7dd48880b88e9af8fbce799fc39887d Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Mon, 17 Feb 2014 15:11:00 +0000 Subject: [PATCH] added more code for 'do' --- lib/h2-scheme-execute-evaluate.adb | 197 ++++++++++++++++------------- lib/h2-scheme-execute.adb | 95 ++++++++++++++ lib/h2-scheme.adb | 5 + lib/h2-scheme.ads | 1 + 4 files changed, 210 insertions(+), 88 deletions(-) diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index a791011..f98b3c9 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -355,12 +355,99 @@ procedure Evaluate is -- ---------------------------------------------------------------- - procedure Evaluate_Do_Syntax is - pragma Inline (Evaluate_Do_Syntax); - Synlist: Object_Pointer; + procedure Check_Do_Syntax is Ptr1: Object_Pointer; Ptr2: Object_Pointer; Ptr3: Object_Pointer; + begin + Ptr1 := Operand; -- list + if not Is_Cons(Ptr1) then + -- (do) + -- (do . 10) + Ada.Text_IO.Put_LINE ("NO BIDNIGNS FOR DO"); + raise Syntax_Error; + end if; + + Ptr2 := Get_Car(Ptr1); -- + while Is_Cons(Ptr2) loop + Ptr3 := Get_Car(Ptr2); -- + if not Is_Cons(Ptr3) then + -- (do (i) (#f)) + Ada.Text_IO.Put_Line ("INVALID BINDING FOR DO"); + raise Syntax_Error; + end if; + + if not Is_Symbol(Get_Car(Ptr3)) then -- + -- (do ((10 10)) (#f)) + Ada.Text_IO.Put_Line ("INVALID BINDING VARIABLE FOR DO"); + raise Syntax_Error; + end if; + + Ptr3 := Get_Cdr(Ptr3); -- cons + if not Is_Cons(Ptr3) then + -- (do ((i . 10)) (#f)) + Ada.Text_IO.Put_Line ("NO INIT IN DO BINDING"); + raise Syntax_Error; + end if; + -- Get_Car(Ptr3); -- + + Ptr3 := Get_Cdr(Ptr3); -- cons + if Is_Cons(Ptr3) then + -- Get_Car(Ptr3); -- + if Get_Cdr(Ptr3) /= Nil_Pointer then + -- (do ((i 0 10 20)) ... ) + Ada.Text_IO.PUT_Line ("TOO MANY STEP EXPRESSIONS IN DO BINDING"); + raise Syntax_Error; + end if; + elsif Ptr3 /= Nil_Pointer then + -- (do ((i 0 . 10)) ... ) + Ada.Text_IO.Put_Line ("FUCKING CDR in DO BIDNING"); + raise Syntax_Error; + end if; + + Ptr2 := Get_Cdr(Ptr2); + end loop; + if Ptr2 /= Nil_Pointer then + -- (do 10 . 10) + -- (do 10 (#f)) + -- (do ((i 10) (j 20) . 10) (#f)) + Ada.Text_IO.Put_LINE ("INVALID BINDINGS FOR DO"); + raise Syntax_Error; + end if; + + Ptr1 := Get_Cdr(Ptr1); -- + if not Is_Cons(Ptr1) then + -- (do ( (i 10) (j 20))) + -- (do ( (i 10) (j 20)) . #f) + Ada.Text_IO.Put_LINE ("NO CLAUSE FOR DO"); + raise Syntax_Error; + end if; + + Ptr2 := Get_Car(Ptr1); -- in clause; + if not Is_Cons(Ptr2) then + -- (do ( (i 10) (j 20)) #f) + Ada.Text_IO.Put_Line ("INVALID CLAUSE TEST FOR DO"); + raise Syntax_Error; + end if; + if Get_Last_Cdr(Ptr2) /= Nil_Pointer then + -- (do ( (i 10) (j 20)) (#f . 10)) + -- (do ( (i 10) (j 20)) (#f 20 . 10)) + Ada.Text_IO.Put_LINE ("FUCKING CDR IN CLAUSE FOR DO"); + raise Syntax_Error; + end if; + + if Get_Last_Cdr(Ptr1) /= Nil_Pointer then + -- (do ( (i 10) (j 20 10)) (#f 20) . 10) + Ada.Text_IO.Put_LINE ("FUCKING CDR IN BODY FOR DO"); + raise Syntax_Error; + end if; + end Check_Do_Syntax; + + procedure Evaluate_Do_Syntax is + pragma Inline (Evaluate_Do_Syntax); + Synlist: Object_Pointer; + Bindings: aliased Object_Pointer; + Envir: aliased Object_Pointer; begin -- (do ) -- should be of the form: (( ) ...) @@ -402,94 +489,28 @@ procedure Evaluate is if (Interp.State and Force_Syntax_Check) /= 0 or else (Synlist.Flags and Syntax_Checked) = 0 then - - Ptr1 := Operand; -- list - if not Is_Cons(Ptr1) then - -- (do) - -- (do . 10) - Ada.Text_IO.Put_LINE ("NO BIDNIGNS FOR DO"); - raise Syntax_Error; - end if; - - Ptr2 := Get_Car(Ptr1); -- - while Is_Cons(Ptr2) loop - Ptr3 := Get_Car(Ptr2); -- - if not Is_Cons(Ptr3) then - -- (do (i) (#f)) - Ada.Text_IO.Put_Line ("INVALID BINDING FOR DO"); - raise Syntax_Error; - end if; - - if not Is_Symbol(Get_Car(Ptr3)) then -- - -- (do ((10 10)) (#f)) - Ada.Text_IO.Put_Line ("INVALID BINDING VARIABLE FOR DO"); - raise Syntax_Error; - end if; - - Ptr3 := Get_Cdr(Ptr3); -- cons - if not Is_Cons(Ptr3) then - -- (do ((i . 10)) (#f)) - Ada.Text_IO.Put_Line ("NO INIT IN DO BINDING"); - raise Syntax_Error; - end if; - -- Get_Car(Ptr3); -- - - Ptr3 := Get_Cdr(Ptr3); -- cons - if Is_Cons(Ptr3) then - -- Get_Car(Ptr3); -- - if Get_Cdr(Ptr3) /= Nil_Pointer then - -- (do ((i 0 10 20)) ... ) - Ada.Text_IO.PUT_Line ("TOO MANY STEP EXPRESSIONS IN DO BINDING"); - raise Syntax_Error; - end if; - elsif Ptr3 /= Nil_Pointer then - -- (do ((i 0 . 10)) ... ) - Ada.Text_IO.Put_Line ("FUCKING CDR in DO BIDNING"); - raise Syntax_Error; - end if; - - Ptr2 := Get_Cdr(Ptr2); - end loop; - if Ptr2 /= Nil_Pointer then - -- (do 10 . 10) - -- (do 10 (#f)) - -- (do ((i 10) (j 20) . 10) (#f)) - Ada.Text_IO.Put_LINE ("INVALID BINDINGS FOR DO"); - raise Syntax_Error; - end if; - - Ptr1 := Get_Cdr(Ptr1); -- - if not Is_Cons(Ptr1) then - -- (do ( (i 10) (j 20))) - -- (do ( (i 10) (j 20)) . #f) - Ada.Text_IO.Put_LINE ("NO CLAUSE FOR DO"); - raise Syntax_Error; - end if; - - Ptr2 := Get_Car(Ptr1); -- in clause; - if not Is_Cons(Ptr2) then - -- (do ( (i 10) (j 20)) #f) - Ada.Text_IO.Put_Line ("INVALID CLAUSE TEST FOR DO"); - raise Syntax_Error; - end if; - if Get_Last_Cdr(Ptr2) /= Nil_Pointer then - -- (do ( (i 10) (j 20)) (#f . 10)) - -- (do ( (i 10) (j 20)) (#f 20 . 10)) - Ada.Text_IO.Put_LINE ("FUCKING CDR IN CLAUSE FOR DO"); - raise Syntax_Error; - end if; - - if Get_Last_Cdr(Ptr1) /= Nil_Pointer then - -- (do ( (i 10) (j 20 10)) (#f 20) . 10) - Ada.Text_IO.Put_LINE ("FUCKING CDR IN BODY FOR DO"); - raise Syntax_Error; - end if; - + Check_Do_Syntax; Synlist.Flags := Synlist.Flags or Syntax_Checked; end if; - Ada.Text_IO.Put_LINE ("UNIMPLEMENTED"); - raise Evaluation_Error; + Reload_Frame (Interp, Opcode_Do_Test, Operand); + Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); + Set_Frame_Environment (Interp.Stack, Envir); -- update the environment + + Bindings := Get_Car(Operand); -- list + if Is_Cons(Bindings) then -- list + -- list is not nil. + Push_Top (Interp, Envir'Unchecked_Access); + Push_Top (Interp, Bindings'Unchecked_Access); + Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack)); + Push_Frame (Interp, Opcode_Do_Binding, Bindings); -- first + Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Bindings))), Envir); -- first + Pop_Tops (Interp, 2); + --else + -- -- list is nil/empty. + -- -- (do () (#f ... ) ...) + -- Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Car(Get_Cdr(Operand)))); -- + end if; end Evaluate_Do_Syntax; -- ---------------------------------------------------------------- diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 1682678..aa3af6f 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -162,6 +162,86 @@ procedure Execute (Interp: in out Interpreter_Record) is -- ---------------------------------------------------------------- + procedure Do_Do_Binding is + pragma Inline (Do_Do_Binding); + X: aliased Object_Pointer; + begin + Push_Top (Interp, X'Unchecked_Access); + X := Get_Frame_Operand(Interp.StacK); + Set_Parent_Environment (Interp, Get_Car(Get_Car(X)), Get_Frame_Result(Interp.Stack)); + + X := Get_Cdr(X); + if Is_Cons(X) then + declare + Envir: aliased Object_Pointer; + begin + pragma Assert (Get_Frame_Opcode(Get_Frame_Parent(Interp.Stack)) = Opcode_Do_Test); + + Push_top (Interp, Envir'Unchecked_Access); + Envir := Get_Frame_Environment(Get_Frame_Parent(Get_Frame_Parent(Interp.Stack))); + Reload_Frame (Interp, Opcode_Do_Binding, X); + Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X))), Envir); -- + Pop_Tops (Interp, 1); + end; + else + Pop_Frame (Interp); + end if; + + Pop_Tops (Interp, 1); + end Do_Do_Binding; + + procedure Do_Do_Test is + pragma Inline (Do_Do_Test); + X: aliased Object_Pointer; + begin + Push_Top (Interp, X'Unchecked_Access); + X := Get_Frame_Operand(Interp.Stack); + Reload_Frame (Interp, Opcode_Do_Break, X); + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Car(Get_Cdr(X)))); -- + Pop_Tops (Interp, 1); + end Do_Do_Test; + + procedure Do_Do_Break is + X: aliased Object_Pointer; + begin + X := Get_Frame_Operand(Interp.Stack); + if Is_True_Class(Get_Frame_Result(Interp.Stack)) then + -- is true + X := Get_Cdr(Get_Car(Get_Cdr(X))); + if X = Nil_Pointer then + -- no expression after + -- (do ((x 1)) (#t)) + Pop_Frame (Interp); + else + Reload_Frame (Interp, Opcode_Grouped_Call, X); + end if; + else + -- is false + Push_Top (Interp, X'Unchecked_Access); + Reload_Frame (Interp, Opcode_Do_Step, X); + X := Get_Cdr(Get_Cdr(X)); + if X /= Nil_Pointer then + Push_Frame (Interp, Opcode_Grouped_Call, X); + end if; + + Pop_Tops (Interp, 1); + end if; + end Do_Do_Break; + + procedure Do_Do_Step is + begin + -- arrange to evaluate and update binding . + print (interp, Get_Car(Get_Frame_Operand(Interp.Stack))); + Pop_Frame (Interp); + end Do_Do_Step; + + procedure Do_Do_Update is + begin + Pop_Frame (Interp); + null; + end Do_Do_Update; + -- ---------------------------------------------------------------- + procedure Do_If_Finish is pragma Inline (Do_If_Finish); X: Object_Pointer; @@ -980,6 +1060,21 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); when Opcode_Define_Finish => Do_Define_Finish; + when Opcode_Do_Binding => + Do_Do_Binding; + + when Opcode_Do_Break => + Do_Do_Break; + + when Opcode_Do_Step => + Do_Do_Step; + + when Opcode_Do_Test => + Do_Do_Test; + + when Opcode_Do_Update => + Do_Do_Update; + when Opcode_Grouped_Call => Do_Grouped_Call; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 878fee6..2c479d8 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -152,6 +152,11 @@ package body H2.Scheme is Opcode_Case_Finish, Opcode_Cond_Finish, Opcode_Define_Finish, + Opcode_Do_Binding, + Opcode_Do_Break, + Opcode_Do_Step, + Opcode_Do_Test, + Opcode_Do_Update, Opcode_Grouped_Call, -- (begin ...), closure apply, let body Opcode_If_Finish, Opcode_Let_Binding, diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index d99e585..2c6822a 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -164,6 +164,7 @@ package H2.Scheme is type Object_Flags is mod 2 ** 4; Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#); Syntax_Checked: constant Object_Flags := Object_Flags'(2#0010#); + Argument_Checked: constant Object_Flags := Object_Flags'(2#0100#); type Syntax_Code is ( And_Syntax,