diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 9420028..d8aefdb 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -220,8 +220,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); end; end Evaluate_Lambda_Syntax; - procedure Evaluate_Let_Syntax is - pragma Inline (Evaluate_Let_Syntax); + procedure Check_Let_Syntax is + pragma Inline (Check_Let_Syntax); Bindings: Object_Pointer; LetBody: Object_Pointer; @@ -236,7 +236,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); end if; Bindings := Get_Car(Operand); -- - if not Is_Cons(Bindings) then + if Bindings /= Nil_Pointer and then not Is_Cons(Bindings) then Ada.Text_IO.Put_Line ("INVALID BINDINGS FOR LET"); raise Syntax_Error; end if; @@ -249,70 +249,103 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); raise Syntax_Error; end if; - Cdr := Bindings; - loop - Car := Get_Car(Cdr); -- - 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; - - if not Is_Symbol(Get_Car(Car)) then - Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET"); - raise Syntax_Error; - end if; - - -- Check for a duplicate binding name + if Is_Cons(Bindings) then + Cdr := Bindings; + loop + Car := Get_Car(Cdr); -- + 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; + + if not Is_Symbol(Get_Car(Car)) then + Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET"); + raise Syntax_Error; + end if; + + -- Check for a duplicate binding name -- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated - declare - V: Object_Pointer; - begin - V := Bindings; - loop - exit when V = Cdr; - - if Get_Car(Get_Car(V)) = Get_Car(Car) then - Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET"); - raise Syntax_Error; - end if; - - V := Get_Cdr(V); - end loop; - end; - + declare + V: Object_Pointer; + begin + V := Bindings; + loop + exit when V = Cdr; + + if Get_Car(Get_Car(V)) = Get_Car(Car) then + Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET"); + raise Syntax_Error; + end if; + + V := Get_Cdr(V); + end loop; + end; + -- Move on to the next binding - Cdr := Get_Cdr(Cdr); - exit when not Is_Cons(Cdr); - end loop; - - if Cdr /= Nil_Pointer then - -- The last cdr is not nil. - Ada.Text_IO.Put_Line ("FUCKING CDR FOR LET BINDING"); - raise Syntax_Error; - end if; + Cdr := Get_Cdr(Cdr); + exit when not Is_Cons(Cdr); + end loop; + + if Cdr /= Nil_Pointer then + -- The last cdr is not nil. + Ada.Text_IO.Put_Line ("FUCKING CDR FOR LET BINDING"); + raise Syntax_Error; + end if; + end if; -- To avoid problems of temporary object pointer problems. Car := Bindings; Cdr := LetBody; + end Check_Let_Syntax; + procedure Evaluate_Let_Syntax is + pragma Inline (Evaluate_Let_Syntax); + begin + Check_Let_Syntax; + -- Car: , Cdr: 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); + Interp.Environment := Make_Environment(Interp.Self, Interp.Environment); + Set_Frame_Environment (Interp.Stack, Interp.Environment); + + -- Some let samples: + -- #1. + -- (define x 99) + -- (let () (define x 100)) ; no actual bindings + -- x ; this must be 99 + -- + -- #2. + -- ... + + if Car /= Nil_Pointer then + -- is not empty + Push_Frame (Interp, Opcode_Let_Binding, Car); + Push_Frame (Interp, Opcode_Let_Evaluation, Car); + end if; end Evaluate_Let_Syntax; procedure Evaluate_Letast_Syntax is pragma Inline (Evaluate_Letast_Syntax); begin + Check_Let_Syntax; + -- Car: , Cdr: - --Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); - --Set_Frame_Operand (Interp.Stack, Cdr); + -- Letast_Binding must see this new environment + -- and must make the binding in this environment. + Interp.Environment := Make_Environment(Interp.Self, Interp.Environment); - --Push_Frame (Interp, Opcode_Let_Binding, Car); - --Push_Frame (Interp, Opcode_Let_Evaluation, Car); - null; + -- Body evaluation can be done the same way as normal let. + Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); + Set_Frame_Operand (Interp.Stack, Cdr); + -- but in the environment pushed above. + Set_Frame_Environment (Interp.Stack, Interp.Environment); + + if Car /= Nil_Pointer then + -- is not empty + Push_Frame (Interp, Opcode_Letast_Binding, Car); + end if; end Evaluate_Letast_Syntax; procedure Evaluate_Quote_Syntax is diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 353cfdf..d524b3a 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -212,19 +212,11 @@ procedure Execute (Interp: in out Interpreter_Record) is Push_Top (Interp, X'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access); + -- Evaluation of is completed. + -- Update the environments. X := Get_Frame_Operand(Interp.Stack); -- and onward Y := Reverse_Cons(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)); @@ -234,10 +226,44 @@ procedure Execute (Interp: in out Interpreter_Record) is end loop; Pop_Frame (Interp); -- done. - Pop_Tops (Interp, 2); end Do_Let_Binding; + procedure Do_Letast_Binding is + pragma Inline (Do_Letast_Binding); + X: aliased Object_Pointer; + Y: aliased Object_Pointer; + begin + Push_Top (Interp, X'Unchecked_Access); + Push_Top (Interp, Y'Unchecked_Access); + + X := Get_Frame_Operand(Interp.Stack); -- and onward + Y := Get_Frame_Result(Interp.Stack); + + if Y = Nil_Pointer then + -- First call + pragma Assert (Is_Cons(X)); -- Don't provoke this procedure if is empty. + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X)))); + else + -- Subsequence calls + -- Update the environment while evaluating + Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y)); + X := Get_Cdr(X); -- next binding + if Is_Cons(X) then + -- More bingings to evaluate + Set_Frame_Operand (Interp.Stack, X); + Clear_Frame_Result (Interp.Stack); + + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X)))); + else + -- No more bingings left + Pop_Frame (Interp); -- Done + end if; + end if; + + Pop_Tops (Interp, 2); + end Do_Letast_Binding; + procedure Do_Let_Finish is pragma Inline (Do_Let_Finish); begin @@ -913,14 +939,13 @@ begin when Opcode_Let_Binding => Do_Let_Binding; + when Opcode_Letast_Binding => + Do_Letast_Binding; when Opcode_Let_Evaluation => Do_Let_Evaluation; when Opcode_Let_Finish => Do_Let_Finish; - --when Opcode_Finish_Letast_Syntax => - --when Opcode_Finish_Letrec_Syntax => - when Opcode_Finish_Or_Syntax => Finish_Or_Syntax; -- Conditional diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 0ad0361..3bc6ed1 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -79,8 +79,7 @@ package body H2.Scheme is -- INTERNALLY-USED TYPES ----------------------------------------------------------------------------- type Heap_Element_Pointer is access all Heap_Element; - for Heap_Element_Pointer'Size use Object_Pointer_Bits; -- ensure that it can be overlayed by an ObjectPointer - + for Heap_Element_Pointer'Size use Object_Pointer_Bits; -- ensure that it can be overlaid by an ObjectPointer type Thin_Heap_Element_Array is array (1 .. Heap_Size'Last) of Heap_Element; type Thin_Heap_Element_Array_Pointer is access all Thin_Heap_Element_Array; @@ -88,7 +87,7 @@ package body H2.Scheme is subtype Moved_Object_Record is Object_Record (Moved_Object, 0); - subtype Opcode_Type is Object_Integer range 0 .. 18; + subtype Opcode_Type is Object_Integer range 0 .. 19; 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); @@ -100,16 +99,17 @@ package body H2.Scheme is Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(8); Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(9); - Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(10); - Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(11); + Opcode_Letast_Binding: constant Opcode_Type := Opcode_Type'(10); + Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(11); + Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(12); - Opcode_Apply: constant Opcode_Type := Opcode_Type'(12); - Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(13); - 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); + Opcode_Apply: constant Opcode_Type := Opcode_Type'(13); + Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(14); + Opcode_Read_List: constant Opcode_Type := Opcode_Type'(15); + Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(16); + Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(17); + Opcode_Close_List: constant Opcode_Type := Opcode_Type'(18); + Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(19); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -1650,7 +1650,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Dummy := Make_Syntax (Interp.Self, Lambda_Syntax, Label_Lambda); -- "lamba" Dummy := Make_Syntax (Interp.Self, Let_Syntax, Label_Let); -- "let" Dummy := Make_Syntax (Interp.Self, Letast_Syntax, Label_Letast); -- "let*" - Dummy := Make_Syntax (Interp.Self, Letrec_Syntax, Label_Letrec); -- "letrc" + Dummy := Make_Syntax (Interp.Self, Letrec_Syntax, Label_Letrec); -- "letrec" Dummy := Make_Syntax (Interp.Self, Or_Syntax, Label_Or); -- "or" Interp.Symbol.Quote := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote" Interp.Symbol.Quasiquote := Make_Syntax (Interp.Self, Quasiquote_Syntax, Label_Quasiquote); -- "quasiquote"