diff --git a/cmd/scheme.adb b/cmd/scheme.adb index ffaf818..739edee 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -58,36 +58,6 @@ S.Run_Loop (SI, I); S.Print (SI, I); S.Close (SI); - declare - subtype x is S.Object_Record (S.Moved_Object, 0); - subtype y is S.Object_Record (S.Pointer_Object, 1); - subtype z is S.Object_Record (S.Character_Object, 1); - subtype q is S.Object_Record (S.Byte_Object, 1); - a: x; - b: y; - c: z; - d: q; - w: S.Object_Word; - begin - Ada.Text_Io.Put_Line (S.Object_Word'Image(w'Size)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Word'Size)); - Ada.Text_IO.Put_Line ("------"); - Ada.Text_Io.Put_Line (S.Object_Word'Image(x'Size)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(y'Size)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(z'Size)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(q'Size)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(x'Max_Size_In_Storage_Elements)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(y'Max_Size_In_Storage_Elements)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(z'Max_Size_In_Storage_Elements)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(q'Max_Size_In_Storage_Elements)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(a'Size)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(b'Size)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(c'Size)); - Ada.Text_Io.Put_Line (S.Object_Word'Image(c'Size)); - Ada.Text_Io.Put_Line (S.Object_Integer'Image(S.Object_Integer'First)); - Ada.Text_Io.Put_Line (S.Object_Integer'Image(S.Object_Integer'Last)); - end; - Ada.Text_IO.Put_Line ("BYE..."); end scheme; diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 7511227..11332f6 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -31,12 +31,10 @@ procedure Evaluate is 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)); -- onwards - Clear_Frame_Result (Interp.Stack); - - -- arrange to evaluate - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand)); + --Switch_Frame (Interp.Stack, Opcode, Get_Cdr(Operand), Nil_Pointer); -- onwards + --Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand)); -- + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Operand), Nil_Pointer); -- onwards + Push_Subframe (Interp, Opcode, Get_Cdr(Operand)); -- onwards end if; end Generic_And_Or_Syntax; @@ -64,7 +62,8 @@ procedure Evaluate is Cdr := Get_Cdr(Operand); if Is_Cons(Car) then -- define a function: (define (add x y) ...) - null; +ada.text_io.put_line ("NOT IMPLEMENTED YET"); +raise Syntax_Error; elsif Is_Symbol(Car) then -- define a symbol: (define x ...) if Get_Cdr(Cdr) /= Nil_Pointer then @@ -73,13 +72,12 @@ procedure Evaluate is end if; Cdr := Get_Car(Cdr); -- Value - -- Arrange to finish defining after value evaluation. - Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Define_Symbol); - Set_Frame_Operand (Interp.Stack, Car); - Clear_Frame_Result (Interp.Stack); - - -- Arrange to evalaute the value part - Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); + -- Arrange to finish defining after value evaluation + -- and to evaluate the value part. + --Switch_Frame (Interp.Stack, Opccode_Define_Finish, Car); + --Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Cdr, Nil_Pointer); + Push_Subframe (Interp, Opcode_Define_Finish, Car); else Ada.Text_IO.Put_LINE ("NO SYMBOL NOR ARGUMENT LIST AFTER DEFINE"); raise Syntax_Error; @@ -128,14 +126,13 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); raise Syntax_Error; end if; - -- Switch the current frame to execute action after evaluation. - Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If_Syntax); - Set_Frame_Operand (Interp.Stack, Operand); - Clear_Frame_Result (Interp.Stack); - - -- Arrange to evalaute the conditional - Push_Frame (Interp, Opcode_Evaluate_Object, Car); - + -- Arrange to evaluate or after + -- evaluation and to evaluate . Use Switch_Frame/Push_Subframe + -- instead of Switch_Frame/Push_Frame for continuation to work. + --Switch_Frame (Interp.Stack, Opcode_If_Finish, Operand, Nil_Pointer); + --Push_Frame (Interp, Opcode_Evaluate_Object, Car); + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car, Nil_Pointer); + Push_Subframe (Interp, Opcode_If_Finish, Operand); end Evaluate_If_Syntax; procedure Evaluate_Lambda_Syntax is @@ -573,7 +570,6 @@ end; -- Switch the current frame to evaluate Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car, Nil_Pointer); - -- Push a new frame to evaluate arguments. Push_Subframe (Interp, Opcode_Procedure_Call, Cdr); end if; diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 3dd29c0..f3b4aa2 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -27,6 +27,7 @@ procedure Execute (Interp: in out Interpreter_Record) is procedure Evaluate_Up_To is X: Object_Pointer; Y: Object_Pointer; + Opcode: Opcode_Type; begin X := Get_Frame_Operand(Interp.Stack); Y := Get_Frame_Result(Interp.Stack); @@ -38,9 +39,12 @@ procedure Execute (Interp: in out Interpreter_Record) is 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)); + --Switch_Frame (Interp.Stack, Get_Frame_Opcode(Interp.Stack), Get_Cdr(X), Nil_Pointer); + --Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); + + Opcode := Get_Frame_Opcode(Interp.Stack); + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer); + Push_SubFrame (Interp, Opcode, Get_Cdr(X)); else -- Return the result of the last expression evaluated. Return_Frame (Interp, Y); @@ -48,11 +52,11 @@ procedure Execute (Interp: in out Interpreter_Record) is 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_Or_Syntax is new Evaluate_Up_To(True_Pointer); -----> this is wrong, it shoudl be able to specify "/= False_Pointer". -- ---------------------------------------------------------------- - procedure Finish_Define_Symbol is - pragma Inline (Finish_Define_Symbol); + procedure Do_Define_Finish is + pragma Inline (Do_Define_Finish); X: Object_Pointer; Y: aliased Object_Pointer; begin @@ -63,21 +67,18 @@ procedure Execute (Interp: in out Interpreter_Record) is pragma Assert (Is_Symbol(X)); Y := Get_Frame_Result(Interp.Stack); -- value list - Put_Environment (Interp, X, Y); -- gc point - Return_Frame (Interp, Y); -- Y is referenced here. Pop_Tops (Interp, 1); -- Unmanage Y - end Finish_Define_Symbol; + end Do_Define_Finish; - procedure Finish_If_Syntax is - pragma Inline (Finish_If_Syntax); - X: aliased Object_Pointer; - Y: aliased Object_Pointer; + -- ---------------------------------------------------------------- + + procedure Do_If_Finish is + pragma Inline (Do_If_Finish); + X: Object_Pointer; + Y: Object_Pointer; begin - Push_Top (Interp, X'Unchecked_Access); - Push_Top (Interp, Y'Unchecked_Access); - X := Get_Frame_Operand(Interp.Stack); -- cons cell containing pragma Assert (Is_Cons(X)); @@ -87,26 +88,37 @@ procedure Execute (Interp: in out Interpreter_Record) is -- evaluated to #f. X := Get_Cdr(X); -- cons cell containing if Is_Cons(X) then - -- Switch the current current to evaluate - -- Keep the environment untouched. - Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object); - Set_Frame_Operand (Interp.Stack, Get_Car(X)); - Clear_Frame_Result (Interp.Stack); + -- Switch the current current to evaluate + -- keeping the environment untouched. Use Pop_Frame and + -- Push_Frame instead of Switch_Frame for continuation. + -- If continuation has been created in , continuation + -- can be made to this frame. + -- + -- For example, + -- (if (define xx (call/cc call/cc)) + -- (+ 10 20) (* 1 2 3 4)) + -- (xx 99) + -- When (xx 99) is evaluated, continuation is made to + -- this frame. For this frame to evaluate or + -- , its opcode must remain as Opcode_If_Finish. + + --Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer); + Pop_Frame (Interp); + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); else -- Return nil if no is specified Return_Frame (Interp, Nil_Pointer); end if; else - -- All values except #f are true values. evaluate - -- Switch the current current to evaluate - -- Keep the environment untouched. - Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object); - Set_Frame_Operand (Interp.Stack, Get_Car(X)); - Clear_Frame_Result (Interp.Stack); + -- All values except #f are true values. evaluate . + -- Switch the current current to evaluate keeping + -- the environment untouched. Use Pop_Frame and Push_Frame + -- instead of Switch_Frame for continuation to work. + --Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer); + Pop_Frame (Interp); + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); end if; - - Pop_Tops (Interp, 2); - end Finish_If_Syntax; + end Do_If_Finish; -- ---------------------------------------------------------------- @@ -165,7 +177,6 @@ procedure Execute (Interp: in out Interpreter_Record) is R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Nil_Pointer); X := Get_Frame_Operand(Interp.Stack); - pragma Assert (Is_Continuation(X)); -- this procedure can be called for continuation only. Pop_Frame (Interp); Push_Frame_With_Intermediate (Interp, Opcode_Apply, X, R); @@ -912,7 +923,7 @@ begin pragma Assert (Interp.Stack /= Nil_Pointer); loop ---ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); +ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); case Get_Frame_Opcode(Interp.Stack) is when Opcode_Exit => exit; @@ -929,15 +940,12 @@ begin --when Opcode_Finish_Case_Syntax => --when Opcode_Finish_Cond_Syntax => - when Opcode_Finish_Define_Symbol => - Finish_Define_Symbol; - - when Opcode_Finish_If_Syntax => - Finish_If_Syntax; -- Conditional - + 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 => diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 662f11f..9c97e31 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -98,11 +98,11 @@ package body H2.Scheme is Opcode_Evaluate_Result, Opcode_Evaluate_Object, Opcode_Finish_And_Syntax, - Opcode_Finish_Define_Symbol, - Opcode_Finish_If_Syntax, Opcode_Finish_Or_Syntax, + Opcode_Define_Finish, Opcode_Grouped_Call, -- (begin ...), closure apply, let body + Opcode_If_Finish, Opcode_Let_Binding, Opcode_Letast_Binding, Opcode_Letast_Binding_Finish,