From 24e62d6f816bbf9b8d432d517a1ae52a1079c458 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Tue, 21 Jan 2014 14:55:08 +0000 Subject: [PATCH] started implementing let --- lib/h2-scheme-execute-evaluate.adb | 87 +++++++++++++++++++++++++++++- lib/h2-scheme-execute.adb | 13 +++++ lib/h2-scheme.adb | 53 ++++++++++-------- lib/h2-scheme.ads | 33 ++++++------ 4 files changed, 146 insertions(+), 40 deletions(-) diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 70b3bb2..2f07517 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -45,7 +45,6 @@ procedure Evaluate is Ada.Text_IO.Put_LINE ("NO SYMBOL NOR ARGUMENT LIST AFTER DEFINE"); raise Syntax_Error; end if; - end Evaluate_Define_Syntax; procedure Evaluate_If_Syntax is @@ -110,13 +109,14 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); if not Is_Cons(Operand) then -- e.g) (lambda) -- (lambda . 10) - Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN"); + Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR LAMBDA"); raise Syntax_Error; end if; Car := Get_Car(Operand); -- if Is_Symbol(Car) then -- (lambda x ...) + -- nothing to do. null; elsif Is_Cons(Car) then declare @@ -178,6 +178,86 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); end; end Evaluate_Lambda_Syntax; + procedure Evaluate_Let_Syntax is + pragma Inline (Evaluate_Let_Syntax); + begin + -- let + Operand := Cdr; -- Skip "let". + if not Is_Cons(Operand) then + -- e.g) (let) + -- (let . 10) + Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR LET"); + raise Syntax_Error; + end if; + + Car := Get_Car(Operand); -- + if not Is_Cons(Car) then + Ada.Text_IO.Put_Line ("INVALID BINDINGS FOR LET"); + raise Syntax_Error; + end if; + + Cdr := Get_Cdr(Operand); -- cons cell to + if not Is_Cons(Cdr) then + -- (let ((x 2)) ) + -- (let ((x 2)) . 99) + Ada.Text_IO.Put_Line ("INVALID BODY FOR LET"); + raise Syntax_Error; + end if; + + Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Let); + Set_Frame_Operand (Interp.Stack, Operand); + + declare + Bindings: aliased Object_Pointer := Car; + Binding_Name: Object_Pointer; + Binding_Value: Object_Pointer; + V: Object_Pointer; + begin + Push_Top (Interp, Bindings'Unchecked_Access); + + 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 + Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET"); + raise Syntax_Error; + end if; + + Binding_Name := Get_Car(Car); + if not Is_Symbol(Binding_Name) then + Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET"); + raise Syntax_Error; + end if; + + Binding_Value := Get_Car(Get_Cdr(Car)); + Push_Frame (Interp, Opcode_Evaluate_Object, Binding_Value); +-- TODO: check duplicate + --V := Formals; + --loop + -- exit when V = Cdr; + + -- if Get_Car(V) = Car then + -- Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET"); + -- raise Syntax_Error; + -- end if; +-- +-- V := Get_Cdr(V); +-- end loop; + + Cdr := Get_Cdr(Cdr); + exit when not Is_Cons(Cdr); + end loop; + + Pop_Tops (Interp, 1); + end; + +-- 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; + + end Evaluate_Let_Syntax; + procedure Evaluate_Quote_Syntax is pragma Inline (Evaluate_Quote_Syntax); begin @@ -302,6 +382,9 @@ begin when Lambda_Syntax => Evaluate_Lambda_Syntax; + when Let_Syntax => + Evaluate_Let_Syntax; + when Quote_Syntax => Evaluate_Quote_Syntax; diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 2110f05..b482c80 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -135,6 +135,13 @@ procedure Execute (Interp: in out Interpreter_Record) is Pop_Tops (Interp, 2); end Finish_If; + procedure Finish_Let is + pragma Inline (Finish_Let); + begin +ada.text_io.put_line ("Finish_Let"); + null; + end Finish_Let; + procedure Finish_Set is pragma Inline (Finish_Set); X: aliased Object_Pointer; @@ -288,6 +295,8 @@ procedure Execute (Interp: in out Interpreter_Record) is -- #t -- #f -- #\C -- character + -- #\xHHHH -- unicode + -- #\xHHHHHHHH -- unicode -- #( ) -- vector -- #[ ] -- list -- #{ } -- hash table @@ -322,6 +331,7 @@ procedure Execute (Interp: in out Interpreter_Record) is if Interp.Token.Value.Last > 1 then -- TODO: case insensitive match. binary search for more diverse words + -- TODO: #\xHHHH.... if Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Newline then Token.Set (Interp, Character_Token, Ch.LF); -- reset the token to LF elsif Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Space then @@ -788,6 +798,9 @@ begin when Opcode_Finish_If => Finish_If; + when Opcode_Finish_Let => + Finish_Let; + when Opcode_Finish_Set => Finish_Set; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index db8debe..da5ac0f 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -26,19 +26,22 @@ package body H2.Scheme is -- Why doesn't ada include a formal type support for different character -- and string types? This limitation is caused because the generic -- type I chosed to use to represent a character type is a discrete type. - Label_And: constant Object_Character_Array := (Ch.LC_A, Ch.LC_N, Ch.LC_D); -- "and" - Label_Begin: constant Object_Character_Array := (Ch.LC_B, Ch.LC_E, Ch.LC_G, Ch.LC_I, Ch.LC_N); -- "begin" - Label_Case: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_S, Ch.LC_E); -- "case" - Label_Cond: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_D); -- "cond" - Label_Define: constant Object_Character_Array := (Ch.LC_D, Ch.LC_E, Ch.LC_F, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "define" - Label_If: constant Object_Character_Array := (Ch.LC_I, Ch.LC_F); -- "if" - Label_Lambda: constant Object_Character_Array := (Ch.LC_L, Ch.LC_A, Ch.LC_M, Ch.LC_B, Ch.LC_D, Ch.LC_A); -- "lambda" - Label_Let: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T); -- "let" - Label_Letast: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.Asterisk); -- "let*" - Label_Letrec: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.LC_R, Ch.LC_E, Ch.LC_C); -- "letrec" - Label_Or: constant Object_Character_Array := (Ch.LC_O, Ch.LC_R); -- "or" - Label_Quote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quote" - Label_Set: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Exclamation); -- "set!" + Label_And: constant Object_Character_Array := (Ch.LC_A, Ch.LC_N, Ch.LC_D); -- "and" + Label_Begin: constant Object_Character_Array := (Ch.LC_B, Ch.LC_E, Ch.LC_G, Ch.LC_I, Ch.LC_N); -- "begin" + Label_Case: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_S, Ch.LC_E); -- "case" + Label_Cond: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_D); -- "cond" + Label_Define: constant Object_Character_Array := (Ch.LC_D, Ch.LC_E, Ch.LC_F, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "define" + Label_Do: constant Object_Character_Array := (Ch.LC_D, Ch.LC_O); -- "do" + Label_If: constant Object_Character_Array := (Ch.LC_I, Ch.LC_F); -- "if" + Label_Lambda: constant Object_Character_Array := (Ch.LC_L, Ch.LC_A, Ch.LC_M, Ch.LC_B, Ch.LC_D, Ch.LC_A); -- "lambda" + Label_Let: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T); -- "let" + Label_Letast: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.Asterisk); -- "let*" + Label_Letrec: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.LC_R, Ch.LC_E, Ch.LC_C); -- "letrec" + Label_Or: constant Object_Character_Array := (Ch.LC_O, Ch.LC_R); -- "or" + Label_Quasiquote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_A, Ch.LC_S, Ch.LC_I, + Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quasiquote" + Label_Quote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quote" + Label_Set: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Exclamation); -- "set!" Label_Car: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_R); -- "car" Label_Cdr: constant Object_Character_Array := (Ch.LC_C, Ch.LC_D, Ch.LC_R); -- "cdr" @@ -80,21 +83,22 @@ package body H2.Scheme is subtype Moved_Object_Record is Object_Record (Moved_Object, 0); - subtype Opcode_Type is Object_Integer range 0 .. 13; + subtype Opcode_Type is Object_Integer range 0 .. 14; 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_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); + Opcode_Finish_Let: constant Opcode_Type := Opcode_Type'(6); + Opcode_Finish_Set: constant Opcode_Type := Opcode_Type'(7); + Opcode_Apply: constant Opcode_Type := Opcode_Type'(8); + Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(9); + Opcode_Read_List: constant Opcode_Type := Opcode_Type'(10); + Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(11); + Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(12); + Opcode_Close_List: constant Opcode_Type := Opcode_Type'(13); + Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(14); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -739,6 +743,7 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL"); -- 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.Quasiquote := Move_One_Object(Interp.Symbol.Quasiquote); Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote); -- Update temporary object pointers that were pointing to the symbol table @@ -1235,7 +1240,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); pragma Inline (Push_Environment); pragma Assert (Is_Cons(Interp.Environment)); begin - Interp.Environment := Make_Environment (Interp.Self, Interp.Environment); + Interp.Environment := Make_Environment(Interp.Self, Interp.Environment); end Push_Environment; procedure Pop_Environment (Interp: in out Interpreter_Record) is @@ -1606,6 +1611,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Dummy := Make_Syntax (Interp.Self, Case_Syntax, Label_Case); -- "case" Dummy := Make_Syntax (Interp.Self, Cond_Syntax, Label_Cond); -- "cond" Dummy := Make_Syntax (Interp.Self, Define_Syntax, Label_Define); -- "define" + Dummy := Make_Syntax (Interp.Self, Do_Syntax, Label_Do); -- "do" Dummy := Make_Syntax (Interp.Self, If_Syntax, Label_If); -- "if" Dummy := Make_Syntax (Interp.Self, Lambda_Syntax, Label_Lambda); -- "lamba" Dummy := Make_Syntax (Interp.Self, Let_Syntax, Label_Let); -- "let" @@ -1613,6 +1619,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Dummy := Make_Syntax (Interp.Self, Letrec_Syntax, Label_Letrec); -- "letrc" 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" Dummy := Make_Syntax (Interp.Self, Set_Syntax, Label_Set); -- "set!" end Make_Syntax_Objects; diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 68ae6a6..bdd6229 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -165,19 +165,21 @@ package H2.Scheme is Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#); type Syntax_Code is mod 2 ** 4; - And_Syntax: constant Syntax_Code := Syntax_Code'(0); - Begin_Syntax: constant Syntax_Code := Syntax_Code'(1); - Case_Syntax: constant Syntax_Code := Syntax_Code'(2); - Cond_Syntax: constant Syntax_Code := Syntax_Code'(3); - Define_Syntax: constant Syntax_Code := Syntax_Code'(4); - If_Syntax: constant Syntax_Code := Syntax_Code'(5); - Lambda_Syntax: constant Syntax_Code := Syntax_Code'(6); - Let_Syntax: constant Syntax_Code := Syntax_Code'(7); - Letast_Syntax: constant Syntax_Code := Syntax_Code'(8); - Letrec_Syntax: constant Syntax_Code := Syntax_Code'(9); - Or_Syntax: constant Syntax_Code := Syntax_Code'(10); - Quote_Syntax: constant Syntax_Code := Syntax_Code'(11); - Set_Syntax: constant Syntax_Code := Syntax_Code'(12); + And_Syntax: constant Syntax_Code := Syntax_Code'(0); + Begin_Syntax: constant Syntax_Code := Syntax_Code'(1); + Case_Syntax: constant Syntax_Code := Syntax_Code'(2); + Cond_Syntax: constant Syntax_Code := Syntax_Code'(3); + Define_Syntax: constant Syntax_Code := Syntax_Code'(4); + Do_Syntax: constant Syntax_Code := Syntax_Code'(5); + If_Syntax: constant Syntax_Code := Syntax_Code'(6); + Lambda_Syntax: constant Syntax_Code := Syntax_Code'(7); + Let_Syntax: constant Syntax_Code := Syntax_Code'(8); + Letast_Syntax: constant Syntax_Code := Syntax_Code'(9); + Letrec_Syntax: constant Syntax_Code := Syntax_Code'(10); + Or_Syntax: constant Syntax_Code := Syntax_Code'(11); + Quasiquote_Syntax: constant Syntax_Code := Syntax_Code'(12); + Quote_Syntax: constant Syntax_Code := Syntax_Code'(13); + Set_Syntax: constant Syntax_Code := Syntax_Code'(14); subtype Procedure_Code is Object_Integer; Add_Procedure: constant Procedure_Code := Procedure_Code'(0); @@ -473,8 +475,9 @@ private end record; type Common_Symbol_Record is record - Quote: Object_Pointer := Nil_Pointer; - Arrow: Object_Pointer := Nil_Pointer; + Arrow: Object_Pointer := Nil_Pointer; + Quasiquote: Object_Pointer := Nil_Pointer; + Quote: Object_Pointer := Nil_Pointer; end record; --type Interpreter_Record is tagged limited record