diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index f749e8a..ec1a075 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -208,36 +208,34 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car); Fbody := Get_Closure_Code(Func); pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this. - Param := Get_Car(Fbody); -- Parameter list - --Arg := Get_Car(Args); -- Actual argument list + Param := Get_Car(Fbody); -- Formal argument list Arg := Args; -- Actual argument list - Fbody := Get_Cdr (Fbody); -- Real function body + Fbody := Get_Cdr(Fbody); -- Real function body pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this as wel.. while Is_Cons(Param) loop - if not Is_Cons(Arg) then Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<"); raise Evaluation_Error; end if; -- Insert the key/value pair into the environment - Set_Environment (Interp, Get_Car(Param), Get_Car(Arg)); + Put_Environment (Interp, Get_Car(Param), Get_Car(Arg)); Param := Get_Cdr(Param); Arg := Get_Cdr(Arg); end loop; -- Perform cosmetic checks for the parameter list - if Param /= Nil_Pointer then - Ada.Text_IO.Put_Line (">>> GARBAGE IN PARAMETER LIST <<<"); - raise Syntax_Error; - end if; + --if Param /= Nil_Pointer then -- this check handled in reading (lambda ...) + -- Ada.Text_IO.Put_Line (">>> GARBAGE IN PARAMETER LIST <<<"); + -- raise Syntax_Error; + --end if; -- Perform cosmetic checks for the argument list if Is_Cons(Arg) then - Ada.Text_IO.Put_Line (">>>> Two many arguments <<<<"); + Ada.Text_IO.Put_Line (">>>> TOO MANY ARGUMETNS FOR CLOSURE <<<<"); raise Evaluation_Error; elsif Arg /= Nil_Pointer then Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<"); diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 4496d9a..071dae4 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -17,6 +17,7 @@ procedure Evaluate is if not Is_Cons(Operand) or else not Is_Cons(Get_Cdr(Operand)) then -- e.g) (define) -- (define . 10) + -- (define x . 10) Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR DEFINE"); raise Syntax_Error; end if; @@ -52,9 +53,9 @@ procedure Evaluate is begin -- (if ) -- (if ) - -- (if (> 3 2) 'yes) - -- (if (> 3 2) 'yes 'no) - -- (if (> 3 2) (- 3 2) (+ 3 2)) + -- e.g) (if (> 3 2) 'yes) + -- (if (> 3 2) 'yes 'no) + -- (if (> 3 2) (- 3 2) (+ 3 2)) Operand := Cdr; -- Skip "if" if Not Is_Cons(Operand) then -- e.g) (if) @@ -101,8 +102,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); procedure Evaluate_Lambda_Syntax is pragma Inline (Evaluate_Lambda_Syntax); begin - -- (lambda (x y) (+ x y)); - Operand := Cdr; -- Skip "lambda" + -- (lambda ) + -- (lambda (x y) (+ x y)); + Operand := Cdr; -- Skip "lambda". cons cell pointing to if not Is_Cons(Operand) then -- e.g) (lambda) -- (lambda . 10) @@ -110,17 +112,31 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); raise Syntax_Error; end if; - if not Is_Cons(Get_Car(Operand)) then - Ada.Text_IO.Put_Line ("INVALID PARRAMETER LIST"); + Car := Get_Car(Operand); -- + if not Is_Cons(Car) then + Ada.Text_IO.Put_Line ("INVALID FORMALS FOR LAMBDA"); raise Syntax_Error; end if; ---Print (Interp, Get_Cdr(Operand)); - if not Is_Cons(Get_Cdr(Operand)) then + Cdr := Get_Last_Cdr(Car); + if Cdr /= Nil_Pointer then + -- (lambda (x y . z) ...) + Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA"); + raise Syntax_Error; + end if; + + Cdr := Get_Cdr(Operand); -- cons cell containing + if not Is_Cons(Cdr) then Ada.Text_IO.Put_Line ("NO BODY"); raise Syntax_Error; end if; + if Get_Last_Cdr(Cdr) /= Nil_Pointer then + -- (lambda (x y) (+ x y) . 99) + Ada.Text_IO.Put_Line ("FUCKING CDR IN BODY FOR LAMBDA"); + raise Syntax_Error; + end if; + declare Closure: Object_Pointer; begin @@ -147,6 +163,43 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand)); end Evaluate_Quote_Syntax; + procedure Evaluate_Set_Syntax is + pragma Inline (Evaluate_Set_Syntax); + begin + -- (set! ) + -- e.g) (set! x 10) + + Operand := Cdr; -- Skip "set!" + + if not Is_Cons(Operand) or else not Is_Cons(Get_Cdr(Operand)) then + -- e.g) (set!) + -- (set . 10) + -- (set x . 10) + Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR SET"); + raise Syntax_Error; + end if; + + Car := Get_Car(Operand); -- + Cdr := Get_Cdr(Operand); -- cons cell to + if Is_Symbol(Car) then + if Get_Cdr(Cdr) /= Nil_Pointer then + Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR set!"); + raise Syntax_Error; + end if; + Cdr := Get_Car(Cdr); -- + + -- Arrange to finish setting a variable after evaluation. + Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Set); + Set_Frame_Operand (Interp.Stack, Car); + + -- Arrange to evalaute the value part + Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); + else + Ada.Text_IO.Put_LINE ("INVALID SYMBOL AFTER SET!"); + raise Syntax_Error; + end if; + end Evaluate_Set_Syntax; + begin Push_Top (Interp, Operand'Unchecked_Access); Push_Top (Interp, Car'Unchecked_Access); @@ -220,6 +273,9 @@ begin when Quote_Syntax => Evaluate_Quote_Syntax; + when Set_Syntax => -- set! + Evaluate_Set_Syntax; + when others => Ada.Text_IO.Put_Line ("Unknown syntax"); --Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax); -- Switch to syntax evaluation @@ -242,6 +298,12 @@ begin Cdr := Get_Cdr(Operand); else -- last cons + if Cdr /= Nil_Pointer then + -- The last CDR is not Nil. + Ada.Text_IO.Put_Line ("WARNING: $$$$$$$$$$$$$$$$$$$$$..FUCKING CDR.....................OPTIMIZATIN $$$$"); + raise Syntax_Error; + end if; + Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack)); Clear_Frame_Result (Interp.Stack); Set_Frame_Opcode (Interp.Stack, Opcode_Apply); diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index e8d6c0c..b439a1f 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -91,7 +91,7 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL"); pragma Assert (Is_Symbol(X)); pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer); - Set_Environment (Interp, X, Y); + Put_Environment (Interp, X, Y); Pop_Frame (Interp); -- Done Chain_Frame_Result (Interp, Interp.Stack, Y); @@ -134,6 +134,32 @@ Ada.Text_IO.PUt_Line ("FINISH IF"); Pop_Tops (Interp, 2); end Finish_If; + procedure Finish_Set is + pragma Inline (Finish_Set); + X: aliased Object_Pointer; + Y: aliased Object_Pointer; + begin +Ada.Text_IO.PUt_Line ("FINISH Set"); + Push_Top (Interp, X'Unchecked_Access); + Push_Top (Interp, Y'Unchecked_Access); + + X := Get_Frame_Operand(Interp.Stack); -- symbol + Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- value + pragma Assert (Is_Symbol(X)); + pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer); + + if Set_Environment(Interp.Self, X, Y) = null then + Ada.Text_IO.PUt_LINE ("ERROR: UNBOUND SYMBOL"); + raise Evaluation_Error; + end if; + + Pop_Frame (Interp); -- Done + Chain_Frame_Result (Interp, Interp.Stack, Y); + + Pop_Tops (Interp, 2); + end Finish_Set; + + procedure Evaluate is separate; procedure Apply is separate; @@ -761,6 +787,9 @@ begin when Opcode_Finish_If => Finish_If; + + when Opcode_Finish_Set => + Finish_Set; when Opcode_Apply => Apply; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 491f86c..0e17e4d 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -80,20 +80,21 @@ package body H2.Scheme is subtype Moved_Object_Record is Object_Record (Moved_Object, 0); - subtype Opcode_Type is Object_Integer range 0 .. 12; + subtype Opcode_Type is Object_Integer range 0 .. 13; 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_Apply: constant Opcode_Type := Opcode_Type'(6); - Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(7); - Opcode_Read_List: constant Opcode_Type := Opcode_Type'(8); - Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(9); - Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(10); - Opcode_Close_List: constant Opcode_Type := Opcode_Type'(11); - Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(12); + Opcode_Finish_Set: constant Opcode_Type := Opcode_Type'(6); + Opcode_Apply: constant Opcode_Type := Opcode_Type'(7); + Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(8); + Opcode_Read_List: constant Opcode_Type := Opcode_Type'(9); + Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(10); + Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(11); + Opcode_Close_List: constant Opcode_Type := Opcode_Type'(12); + Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(13); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -990,6 +991,17 @@ end if; Source.Pointer_Slot(Cons_Cdr_Index) := Value; end Set_Cdr; + function Get_Last_Cdr (Source: in Object_Pointer) return Object_Pointer is + pragma Assert (Is_Cons(Source)); + Ptr: Object_Pointer := Source; + begin + loop + Ptr := Get_Cdr(Ptr); + exit when not Is_Cons(Ptr); + end loop; + return Ptr; + end Get_Last_Cdr; + function Reverse_Cons (Source: in Object_Pointer; Last_Cdr: in Object_Pointer := Nil_Pointer) return Object_Pointer is pragma Assert (Is_Cons(Source)); @@ -1151,7 +1163,24 @@ Ada.Text_IO.Put_Line ("Make_String..."); return null; -- not found. note that it's not Nil_Pointer. end Find_In_Environment_List; - procedure Set_Environment (Interp: in out Interpreter_Record; + function Set_Environment (Interp: access Interpreter_Record; + Key: in Object_Pointer; + Value: in Object_Pointer) return Object_Pointer is + Arr: Object_Pointer; + begin + pragma Assert (Is_Symbol(Key)); + + Arr := Find_In_Environment_List(Interp, Get_Car(Interp.Environment), Key); + if Arr = null then + return null; + else + -- overwrite an existing pair + Arr.Pointer_Slot(2) := Value; + return Value; + end if; + end Set_Environment; + + procedure Put_Environment (Interp: in out Interpreter_Record; Key: in Object_Pointer; Value: in Object_Pointer) is Arr: Object_Pointer; @@ -1182,8 +1211,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- overwrite an existing pair Arr.Pointer_Slot(2) := Value; end if; - - end Set_Environment; + end Put_Environment; function Get_Environment (Interp: access Interpreter_Record; Key: in Object_Pointer) return Object_Pointer is @@ -1261,7 +1289,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- Link it to the top environement pragma Assert (Interp.Environment = Interp.Root_Environment); pragma Assert (Get_Environment (Interp.Self, Symbol) = null); - Set_Environment (Interp.all, Symbol, Proc); + Put_Environment (Interp.all, Symbol, Proc); Pop_Tops (Interp.all, 2); return Proc;