diff --git a/lib/ascii.txt b/lib/ascii.txt index b1da5a4..257db51 100644 --- a/lib/ascii.txt +++ b/lib/ascii.txt @@ -59,7 +59,7 @@ Nine Colon Semicolon Less_Than_Sign -Equals_Sign +Equal_Sign Greater_Than_Sign Question Commercial_At diff --git a/lib/h2-ascii.ads b/lib/h2-ascii.ads index f5a407a..f7e0c8c 100644 --- a/lib/h2-ascii.ads +++ b/lib/h2-ascii.ads @@ -67,7 +67,7 @@ package H2.Ascii is Colon : constant := 58; -- : Semicolon : constant := 59; -- ; Less_Than_Sign : constant := 60; -- < - Equals_Sign : constant := 61; -- = + Equal_Sign : constant := 61; -- = Greater_Than_Sign : constant := 62; -- > Question : constant := 63; -- ? Commercial_At : constant := 64; -- @ @@ -197,7 +197,7 @@ package H2.Ascii is Colon : constant Character_Type := Character_Type'Val(Pos.Colon); Semicolon : constant Character_Type := Character_Type'Val(Pos.Semicolon); Less_Than_Sign : constant Character_Type := Character_Type'Val(Pos.Less_Than_Sign); - Equals_Sign : constant Character_Type := Character_Type'Val(Pos.Equals_Sign); + Equal_Sign : constant Character_Type := Character_Type'Val(Pos.Equal_Sign); Greater_Than_Sign : constant Character_Type := Character_Type'Val(Pos.Greater_Than_Sign); Question : constant Character_Type := Character_Type'Val(Pos.Question); Commercial_At : constant Character_Type := Character_Type'Val(Pos.Commercial_At); diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index 9a35187..f749e8a 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -131,6 +131,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car); end if; Num := Pointer_To_Integer(Car); + Ptr := Get_Cdr(Ptr); while Ptr /= Nil_Pointer loop -- TODO: check if car is an integer or bignum or something else. -- if something else, error diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 6dcb180..4496d9a 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -47,6 +47,57 @@ procedure Evaluate is end Evaluate_Define_Syntax; + procedure Evaluate_If_Syntax is + pragma Inline (Evaluate_If_Syntax); + begin + -- (if ) + -- (if ) + -- (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) + -- (if . 10) + Ada.Text_IO.Put_LINE ("NO CONDITIONAL FOR IF"); + raise Syntax_Error; + end if; + + Car := Get_Car(Operand); -- + + Operand := Get_Cdr(Operand); -- cons cell containg + if not Is_Cons(Operand) then + Ada.Text_IO.Put_Line ("NO ACTION FOR IF"); + raise Syntax_Error; + end if; + + Cdr := Get_Cdr(Operand); -- cons cell containing + if Cdr = Nil_Pointer then + -- no . it's ok +Ada.Text_IO.Put_Line ("NO ALTERNATE"); + null; + elsif not Is_Cons(Cdr) then + -- no but reduncant cdr. + -- (if (> 3 2) 3 . 99) + Ada.Text_IO.Put_Line ("FUCKING CDR FOR IF"); + raise Syntax_Error; + + elsif Get_Cdr(Cdr) /= Nil_Pointer then + -- (if (> 3 2) 3 2 . 99) + -- (if (> 3 2) 3 2 99) + Ada.Text_IO.Put_Line ("TOO MANY ARGUMENTS FOR IF"); + raise Syntax_Error; + end if; + + -- Switch the current frame to execute action after evaluation. + Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If); + Set_Frame_Operand (Interp.Stack, Operand); + + -- Arrange to evalaute the conditional + Push_Frame (Interp, Opcode_Evaluate_Object, Car); + + end Evaluate_If_Syntax; + procedure Evaluate_Lambda_Syntax is pragma Inline (Evaluate_Lambda_Syntax); begin @@ -142,7 +193,6 @@ begin -- (begin . 10) Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN"); raise Syntax_Error; - --Pop_Frame (Interp); -- Done else Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); @@ -161,6 +211,9 @@ begin when Define_Syntax => Evaluate_Define_Syntax; + when If_Syntax => + Evaluate_If_Syntax; + when Lambda_Syntax => Evaluate_Lambda_Syntax; diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 18a2e61..e8d6c0c 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -45,7 +45,7 @@ procedure Execute (Interp: in out Interpreter_Record) is if Cdr /= Nil_Pointer then -- The last CDR is not Nil. Ada.Text_IO.Put_Line ("$$$$..................FUCKING CDR. FOR GROUP....................$$$$"); - -- raise Syntax_Error; + raise Syntax_Error; end if; -- Change the operand to a mark object so that the call to this @@ -86,8 +86,8 @@ 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); - Y := Get_Car(Get_Frame_Result(Interp.Stack)); + 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); @@ -99,6 +99,41 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL"); Pop_Tops (Interp, 2); end Finish_Define_Symbol; + procedure Finish_If is + pragma Inline (Finish_If); + X: aliased Object_Pointer; + 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); + + Pop_Frame (Interp); + if Y = False_Pointer then + -- evaluated to #f. + X := Get_Cdr(X); -- cons cell containing + if Is_Cons(X) then + -- evaluate + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); + else + -- return nil if no is specified + Chain_Frame_Result (Interp, Interp.Stack, Nil_Pointer); + end if; + else + -- all values except #f are true values. evaluate + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); + end if; + + Pop_Tops (Interp, 2); + end Finish_If; + procedure Evaluate is separate; procedure Apply is separate; @@ -449,6 +484,12 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END"); V := Make_Symbol(Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); Chain_Frame_Result (Interp, Interp.Stack, V); + when True_Token => + Chain_Frame_Result (Interp, Interp.Stack, True_Pointer); + + when False_Token => + Chain_Frame_Result (Interp, Interp.Stack, False_Pointer); + when others => -- TODO: set various error info raise Syntax_Error; @@ -507,6 +548,14 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END"); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); Chain_Frame_Result (Interp, Interp.Stack, V); + when True_Token => + Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); + Chain_Frame_Result (Interp, Interp.Stack, True_Pointer); + + when False_Token => + Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); + Chain_Frame_Result (Interp, Interp.Stack, False_Pointer); + when others => -- TODO: set various error info raise Syntax_Error; @@ -558,8 +607,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END"); begin --Push_Top (Interp, V'Unchecked_Access); --- TODO: use Interp.Quote_Syntax instead of Make_Symbol("quote") - Chain_Frame_Result (Interp, Interp.Stack, Make_Symbol(Interp.Self, Label_Quote)); + Chain_Frame_Result (Interp, Interp.Stack, Interp.Symbol.Quote); V := Get_Frame_Result(Interp.Stack); Pop_Frame (Interp); -- Done with the current frame Chain_Frame_Result (Interp, Interp.Stack, V); @@ -610,6 +658,15 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN "); Pop_Frame (Interp); -- Done with the current frame Chain_Frame_Result (Interp, Interp.Stack, V); + when True_Token => + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, True_Pointer); + + when False_Token => + Pop_Frame (Interp); -- Done with the current frame + Chain_Frame_Result (Interp, Interp.Stack, False_Pointer); + + when others => -- TODO: set various error info raise Syntax_Error; @@ -701,6 +758,9 @@ begin when Opcode_Finish_Define_Symbol => Finish_Define_Symbol; + + when Opcode_Finish_If => + Finish_If; when Opcode_Apply => Apply; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index cb1a513..491f86c 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -54,6 +54,8 @@ package body H2.Scheme is Label_Newline: constant Object_Character_Array := (Ch.LC_N, Ch.LC_E, Ch.LC_W, Ch.LC_L, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "newline" Label_Space: constant Object_Character_Array := (Ch.LC_S, Ch.LC_P, Ch.LC_A, Ch.LC_C, Ch.LC_E); -- "space" + + Label_Arrow: constant Object_Character_Array := (Ch.Equal_Sign, Ch.Greater_Than_Sign); -- "=>" ----------------------------------------------------------------------------- -- EXCEPTIONS ----------------------------------------------------------------------------- @@ -78,19 +80,20 @@ package body H2.Scheme is subtype Moved_Object_Record is Object_Record (Moved_Object, 0); - subtype Opcode_Type is Object_Integer range 0 .. 11; + subtype Opcode_Type is Object_Integer range 0 .. 12; 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_Apply: constant Opcode_Type := Opcode_Type'(5); - Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(6); - Opcode_Read_List: constant Opcode_Type := Opcode_Type'(7); - Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(8); - Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(9); - Opcode_Close_List: constant Opcode_Type := Opcode_Type'(10); - Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(11); + 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); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -734,6 +737,8 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL"); --Print_Object_Pointer (">>> [GC MOVING SYMBOL TABLE]", Interp.Symbol_Table); -- Migrate the symbol table itself Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table); + Interp.Symbol.Arrow := Move_One_Object(Interp.Symbol.Arrow); + Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote); -- Update temporary object pointers that were pointing to the symbol table if Original_Symbol_Table /= null then @@ -1580,7 +1585,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); 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, Or_Syntax, Label_Or); -- "or" - Dummy := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote" + Interp.Symbol.Quote := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote" Dummy := Make_Syntax (Interp.Self, Set_Syntax, Label_Set); -- "set!" end Make_Syntax_Objects; @@ -1598,6 +1603,11 @@ Ada.Text_IO.Put_Line ("Make_String..."); Dummy := Make_Procedure (Interp.Self, Setcdr_Procedure, Label_Setcdr); -- "set-cdr!" Dummy := Make_Procedure (Interp.Self, Subtract_Procedure, Label_Minus); -- "-" end Make_Procedure_Objects; + + procedure Make_Common_Symbol_Objects is + begin + Interp.Symbol.Arrow := Make_Symbol (Interp.Self, Label_Arrow); + end Make_Common_Symbol_Objects; begin declare Aliased_Interp: aliased Interpreter_Record; @@ -1636,6 +1646,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Interp.Environment := Interp.Root_Environment; Make_Syntax_Objects; Make_Procedure_Objects; + Make_Common_Symbol_Objects; exception when others => diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index e6f65e0..1e0a853 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -471,6 +471,11 @@ private Data: Top_Array(1 .. 100) := (others => null); end record; + type Common_Symbol_Record is record + Quote: Object_Pointer := Nil_Pointer; + Arrow: Object_Pointer := Nil_Pointer; + end record; + --type Interpreter_Record is tagged limited record type Interpreter_Record is limited record Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer @@ -488,6 +493,7 @@ private Stack: aliased Object_Pointer := Nil_Pointer; Mark: Object_Pointer := Nil_Pointer; + Symbol: Common_Symbol_Record; Top: Top_Record; -- temporary object pointers Base_Input: aliased IO_Record;