diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index ec1a075..3ecbd2f 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -212,34 +212,42 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car); Arg := Args; -- Actual argument list Fbody := Get_Cdr(Fbody); -- Real function body - pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this as wel.. + pragma Assert (Is_Cons(Fbody)); -- the lambda evaluator must ensure this. - while Is_Cons(Param) loop - if not Is_Cons(Arg) then - Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<"); - raise Evaluation_Error; + if Is_Symbol(Param) then + -- Closure made of a lambda expression with a single formal argument + -- e.g) (lambda x (car x)) + -- Apply the whole actual argument list to the closure. +Print (Interp, Arg); + Put_Environment (Interp, Param, Arg); + else + 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 + 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; - -- Insert the key/value pair into the environment - 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 -- 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 (">>>> TOO MANY ARGUMETNS FOR CLOSURE <<<<"); - raise Evaluation_Error; - elsif Arg /= Nil_Pointer then - Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<"); - raise Syntax_Error; + -- Perform cosmetic checks for the argument list + if Is_Cons(Arg) then + 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 <<<"); + raise Syntax_Error; + end if; end if; -- TODO: is it correct to keep the environement in the frame? diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 071dae4..5e9104b 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -103,7 +103,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); pragma Inline (Evaluate_Lambda_Syntax); begin -- (lambda ) - -- (lambda (x y) (+ x y)); + -- e.g) (lambda (x y) (+ x y)) + -- e.g) (lambda (x y . z) z) + -- e.g) (lambda x (car x)) Operand := Cdr; -- Skip "lambda". cons cell pointing to if not Is_Cons(Operand) then -- e.g) (lambda) @@ -113,18 +115,32 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); end if; Car := Get_Car(Operand); -- - if not Is_Cons(Car) then + if Is_Symbol(Car) then + -- (lambda x ...) + null; + elsif Is_Cons(Car) then + Cdr := Car; + loop + Cdr := Get_Cdr(Cdr); + exit when not Is_Cons(Cdr); + + Car := Get_Car(Cdr); + if not Is_Symbol(Car) then + Ada.Text_IO.Put_Line ("WRONG FORMALS FOR LAMBDA"); + raise Syntax_Error; + end if; +-- TODO: Check duplicate symbol names??? + end loop; + + if Cdr /= Nil_Pointer and then not Is_Symbol(Cdr) then + Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA"); + raise Syntax_Error; + end if; + else Ada.Text_IO.Put_Line ("INVALID FORMALS FOR LAMBDA"); raise Syntax_Error; end if; - 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"); @@ -140,7 +156,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); declare Closure: Object_Pointer; begin - Closure := Make_Closure (Interp.Self, Operand, Interp.Environment); + Closure := Make_Closure(Interp.Self, Operand, Interp.Environment); Pop_Frame (Interp); -- Done Chain_Frame_Result (Interp, Interp.Stack, Closure); end; diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index b439a1f..2110f05 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -61,7 +61,7 @@ procedure Execute (Interp: in out Interpreter_Record) is Push_Frame (Interp, Opcode_Evaluate_Object, Car); when Mark_Object => - Operand := Get_Frame_Result (Interp.Stack); + Operand := Get_Frame_Result(Interp.Stack); Pop_Frame (Interp); -- Done -- There must be only 1 return value chained in the Group frame. @@ -82,14 +82,15 @@ procedure Execute (Interp: in out Interpreter_Record) is X: aliased Object_Pointer; Y: aliased Object_Pointer; begin -Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL"); 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); + + Y := Get_Frame_Result(Interp.Stack); -- value list + pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure only 1 return value + Y := Get_Car(Y); -- the first value Put_Environment (Interp, X, Y); @@ -105,15 +106,15 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL"); Y: aliased Object_Pointer; Z: aliased Object_Pointer; begin -Ada.Text_IO.PUt_Line ("FINISH IF"); - Push_Top (Interp, X'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access); X := Get_Frame_Operand(Interp.Stack); -- cons cell containing - Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- result of conditional pragma Assert (Is_Cons(X)); - pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer); + + Y := Get_Frame_Result(Interp.Stack); -- result list of + pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure only 1 return value + Y := Get_Car(Y); -- the first value Pop_Frame (Interp); if Y = False_Pointer then @@ -139,7 +140,6 @@ Ada.Text_IO.PUt_Line ("FINISH IF"); 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); @@ -159,7 +159,6 @@ Ada.Text_IO.PUt_Line ("FINISH Set"); Pop_Tops (Interp, 2); end Finish_Set; - procedure Evaluate is separate; procedure Apply is separate; @@ -607,6 +606,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END"); Pop_Frame (Interp); Chain_Frame_Result (Interp, Interp.Stack, V); when others => +Ada.Text_IO.Put_Line ("Right parenthesis expected"); raise Syntax_Error; end case; diff --git a/lib/h2-scheme-token.adb b/lib/h2-scheme-token.adb index 118f272..0979620 100644 --- a/lib/h2-scheme-token.adb +++ b/lib/h2-scheme-token.adb @@ -31,7 +31,7 @@ package body Token is Pool.Deallocate (Tmp); end; - Buffer := ( Ptr => null, Len => 0, Last => 0); + Buffer := (Ptr => null, Len => 0, Last => 0); end if; end Purge_Buffer; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 0e17e4d..3d301a5 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -1159,27 +1159,9 @@ Ada.Text_IO.Put_Line ("Make_String..."); Arr := Arr.Pointer_Slot(3); end loop; - - return null; -- not found. note that it's not Nil_Pointer. + return null; -- not found. end Find_In_Environment_List; - 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 @@ -1213,6 +1195,23 @@ Ada.Text_IO.Put_Line ("Make_String..."); end if; end Put_Environment; + 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; + function Get_Environment (Interp: access Interpreter_Record; Key: in Object_Pointer) return Object_Pointer is Envir: Object_Pointer; @@ -1222,7 +1221,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); while Envir /= Nil_Pointer loop pragma Assert (Is_Cons(Envir)); Arr := Find_In_Environment_List(Interp, Get_Car(Envir), Key); - if Arr /= Nil_Pointer then + if Arr /= null then return Arr.Pointer_Slot(2); end if; @@ -1254,7 +1253,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Name: in Object_Character_Array) return Object_Pointer is Result: Object_Pointer; begin - Result := Make_Symbol (Interp, Name); + Result := Make_Symbol(Interp, Name); Result.Flags := Result.Flags or Syntax_Object; Result.Scode := Opcode; --Ada.Text_IO.Put ("Creating Syntax Symbol "); @@ -1279,16 +1278,16 @@ Ada.Text_IO.Put_Line ("Make_String..."); Push_Top (Interp.all, Proc'Unchecked_Access); -- Make a symbol for the procedure - Symbol := Make_Symbol (Interp, Name); + Symbol := Make_Symbol(Interp, Name); -- Make the actual procedure object - Proc := Allocate_Pointer_Object (Interp, Procedure_Object_Size, Nil_Pointer); + Proc := Allocate_Pointer_Object(Interp, Procedure_Object_Size, Nil_Pointer); Proc.Tag := Procedure_Object; Proc.Pointer_Slot(Procedure_Opcode_Index) := Integer_To_Pointer(Opcode); -- Link it to the top environement pragma Assert (Interp.Environment = Interp.Root_Environment); - pragma Assert (Get_Environment (Interp.Self, Symbol) = null); + pragma Assert (Get_Environment(Interp.Self, Symbol) = null); Put_Environment (Interp.all, Symbol, Proc); Pop_Tops (Interp.all, 2); @@ -1669,12 +1668,19 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- TODO: disallow garbage collecion during initialization. Initialize_Heap (Initial_Heap_Size); - Interp.Mark := Make_Mark(Interp.Self, 0); -- to indicate the end of cons evluation +ada.text_io.put_line ("kkkkkkkkkkkkkk"); + Interp.Mark := Make_Mark(Interp.Self, 0); -- to indicate the end of cons evaluation +ada.text_io.put_line ("xxxxxxxxxxxxxx"); Interp.Root_Environment := Make_Environment(Interp.Self, Nil_Pointer); +ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz"); Interp.Environment := Interp.Root_Environment; Make_Syntax_Objects; +print (interp, interp.mark); +ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 00"); Make_Procedure_Objects; +ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 00--00"); Make_Common_Symbol_Objects; +ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 11"); exception when others => @@ -1801,6 +1807,8 @@ Ada.Text_IO.Put_Line ("Make_String..."); when Others => if Atom.Kind = Character_Object then Output_Character_Array (Atom.Character_Slot); + elsif Atom.Tag = Mark_Object then + Ada.Text_IO.Put ("#INTERNAL MARK#"); else Ada.Text_IO.Put ("#NOIMPL#"); end if; @@ -2007,7 +2015,6 @@ end if; pragma Assert (Interp.Stack = Nil_Pointer); Interp.Stack := Nil_Pointer; -Print_Object_Pointer ("STACK IN EVALUTE => ", Interp.Stack); -- Push a pseudo-frame to terminate the evaluation loop Push_Frame (Interp, Opcode_Exit, Nil_Pointer); diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 1e0a853..68ae6a6 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -367,28 +367,29 @@ package H2.Scheme is -- The nil/true/false object are represented by special pointer values. -- The special values are defined under the assumption that actual objects - -- are never allocated on one of these addresses. Addresses of 0, 4, 8 are - -- very low, making the assumption pretty safe. - Nil_Word: constant Object_Word := 2#0000#; -- 0 + -- are never allocated on one of these addresses. Addresses of 4, 8, 12 are + -- very low, making the assumption pretty safe. I don't use 0 for Nil_Word + -- as it may conflict with ada's null. + Nil_Word: constant Object_Word := 2#0100#; -- 4 --Nil_Pointer: constant Object_Pointer; --for Nil_Pointer'Address use Nil_Word'Address; --pragma Import (Ada, Nil_Pointer); - True_Word: constant Object_Word := 2#0100#; -- 4 + True_Word: constant Object_Word := 2#1000#; -- 8 --True_Pointer: constant Object_Pointer; --for True_Pointer'Address use True_Word'Address; --pragma Import (Ada, True_Pointer); - False_Word: constant Object_Word := 2#1000#; -- 8 + False_Word: constant Object_Word := 2#1100#; -- 12 --False_Pointer: constant Object_Pointer; --for False_Pointer'Address use False_Word'Address; --pragma Import (Ada, False_Pointer); function Object_Word_To_Pointer is new Ada.Unchecked_Conversion (Object_Word, Object_Pointer); function Object_Pointer_To_Word is new Ada.Unchecked_Conversion (Object_Pointer, Object_Word); - Nil_Pointer: constant Object_Pointer := Object_Word_To_Pointer (Nil_Word); - True_Pointer: constant Object_Pointer := Object_Word_To_Pointer (True_Word); - False_Pointer: constant Object_Pointer := Object_Word_To_Pointer (False_Word); + Nil_Pointer: constant Object_Pointer := Object_Word_To_Pointer(Nil_Word); + True_Pointer: constant Object_Pointer := Object_Word_To_Pointer(True_Word); + False_Pointer: constant Object_Pointer := Object_Word_To_Pointer(False_Word); -- -----------------------------------------------------------------------------