From cbf8d0e54e18378481570c38dbb5aa42f98b8bc1 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Mon, 10 Feb 2014 15:39:20 +0000 Subject: [PATCH] implemented cond --- lib/h2-scheme-execute-evaluate.adb | 96 ++++++++++++++++++++++++++++-- lib/h2-scheme-execute.adb | 67 +++++++++++++++++---- lib/h2-scheme.adb | 31 +++++----- lib/h2-scheme.ads | 48 +++++++-------- 4 files changed, 185 insertions(+), 57 deletions(-) diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 2f32e84..04719e6 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -30,7 +30,7 @@ procedure Evaluate is elsif not Is_Cons(Operand) or else Get_Last_Cdr(Operand) /= Nil_Pointer then -- (and . 10) -- (and 1 2 . 10) - Ada.Text_IO.Put_LINE ("FUCKING cDR FOR DEFINE"); + Ada.Text_IO.Put_LINE ("FUCKING CDR FOR DEFINE"); raise Syntax_Error; else --Switch_Frame (Interp.Stack, Opcode, Get_Cdr(Operand), Nil_Pointer); -- onwards @@ -88,6 +88,76 @@ raise Syntax_Error; end if; end Evaluate_Define_Syntax; + -- ---------------------------------------------------------------- + + procedure Evaluate_Case_Syntax is + pragma Inline (Evaluate_Case_Syntax); + begin + Ada.Text_IO.Put_LINE ("UNIMPLEMENTED"); + raise Evaluation_Error; + end Evaluate_Case_Syntax; + + -- ---------------------------------------------------------------- + + procedure Evaluate_Cond_Syntax is + pragma Inline (Evaluate_Cond_Syntax); + Ptr: Object_Pointer; + begin + -- cond ... + -- A clause should be of the form: + -- ( ...) + -- the last clause may be an else clause of the form: + -- (else ...) + -- + -- (cond ((> 3 2) 'greater) + -- ((< 3 2) 'less)) => greater + -- (cond ((> 3 3) 'greater) + -- ((< 3 3) 'less) + -- (else 'equal)) => equal + + Operand := Cdr; -- Skip "cond" + if Not Is_Cons(Operand) then + -- e.g) (cond) + -- (cond . 10) + Ada.Text_IO.Put_LINE ("NO CLAUSE FOR COND"); + raise Syntax_Error; + end if; + + -- Check clauses + -- TODO: Skip this check of clauses that have been checked previously. + Ptr := Operand; + loop + Car := Get_Car(Ptr); -- + if not Is_Cons(Car) then + Ada.Text_IO.Put_Line ("FUCKING CLAUSE FOR COND"); + raise Syntax_Error; + end if; + If Get_Last_Cdr(Car) /= Nil_Pointer then + Ada.Text_IO.Put_Line ("FUCKING CDR FOR COND CLAUSE"); + raise Syntax_Error; + end if; + Ptr := Get_Cdr(Ptr); + exit when not Is_Cons(Ptr); + end loop; + if Ptr /= Nil_Pointer then + Ada.Text_IO.Put_Line ("FUCKING LAST CLAUSE FOR COND"); + raise Syntax_Error; + end if; + + Car := Get_Car(Operand); -- first + + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Car), Nil_Pointer); -- first + Push_Subframe (Interp, Opcode_Cond_Finish, Operand); + end Evaluate_Cond_Syntax; + + -- ---------------------------------------------------------------- + procedure Evaluate_Do_Syntax is + pragma Inline (Evaluate_Do_Syntax); + begin + Ada.Text_IO.Put_LINE ("UNIMPLEMENTED"); + raise Evaluation_Error; + end Evaluate_Do_Syntax; + -- ---------------------------------------------------------------- procedure Evaluate_If_Syntax is @@ -426,6 +496,14 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); end if; end Evaluate_Letrec_Syntax; + -- ---------------------------------------------------------------- + procedure Evaluate_Quasiquote_Syntax is + pragma Inline (Evaluate_Quasiquote_Syntax); + begin + Ada.Text_IO.Put_LINE ("UNIMPLEMENTED"); + raise Evaluation_Error; + end Evaluate_Quasiquote_Syntax; + -- ---------------------------------------------------------------- procedure Evaluate_Quote_Syntax is @@ -564,9 +642,18 @@ end; -- goto Start_Over; -- for optimization only. not really needed. --end if; + when Case_Syntax => + Evaluate_Case_Syntax; + + when Cond_Syntax => + Evaluate_Cond_Syntax; + when Define_Syntax => Evaluate_Define_Syntax; + when Do_Syntax => + Evaluate_Do_Syntax; + when If_Syntax => Evaluate_If_Syntax; @@ -585,16 +672,15 @@ end; when Or_Syntax => Evaluate_Or_Syntax; + when Quasiquote_Syntax => + Evaluate_Quasiquote_Syntax; + 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 - raise Internal_Error; end case; else -- procedure call diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 50fa9e5..3e81049 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -51,20 +51,61 @@ procedure Execute (Interp: in out Interpreter_Record) is end if; end Evaluate_While; - function Is_False (X: in Object_Pointer) return Standard.Boolean is - pragma Inline (Is_False); + function Is_False_Class (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_False_Class); begin return X = False_Pointer; - end Is_False; + end Is_False_Class; - function Is_True (X: in Object_Pointer) return Standard.Boolean is - pragma Inline (Is_True); + function Is_True_Class (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_True_Class); begin return X /= False_Pointer; - end Is_True; + end Is_True_Class; + + procedure Do_And_Finish is new Evaluate_While(Is_True_Class); + procedure Do_Or_Finish is new Evaluate_While(Is_False_Class); + + -- ---------------------------------------------------------------- + procedure Do_Cond_Finish is + pragma Inline (Do_Cond_Finish); + R: Object_Pointer; + O: Object_Pointer; + begin + R := Get_Frame_Result(Interp.Stack); -- result + O := Get_Frame_Operand(Interp.Stack); -- list + + if Is_True_Class(R) then + O := Get_Cdr(Get_Car(O)); -- list in + if Is_Cons(O) then + Reload_Frame (Interp, Opcode_Grouped_Call, O); + else + Pop_Frame (Interp); + end if; + else + O := Get_Cdr(O); -- next list + + if not Is_Cons(O) then + -- no more + Pop_Frame (Interp); + else + R := Get_Car(O); -- next + if Get_Car(R) = Interp.Else_Symbol then + -- else + O := Get_Cdr(R); -- list in else + if Is_Cons(O) then + Reload_Frame (Interp, Opcode_Grouped_Call, O); + else + Pop_Frame (Interp); + end if; + else + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(R), Nil_Pointer); + Push_Subframe (Interp, Opcode_Cond_Finish, O); + end if; + end if; + end if; + end Do_Cond_Finish; - procedure Do_And_Finish is new Evaluate_While(Is_True); - procedure Do_Or_Finish is new Evaluate_While(Is_False); -- ---------------------------------------------------------------- procedure Do_Define_Finish is @@ -766,7 +807,7 @@ Ada.Text_IO.Put_Line ("Right parenthesis expected"); begin V := Get_Frame_Result(Interp.Stack); V := Make_Cons(Interp.Self, V, Nil_Pointer); - V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V); + V := Make_Cons(Interp.Self, Interp.Quote_Symbol, V); Pop_Frame (Interp); Chain_Frame_Intermediate (Interp, Interp.Stack, V); end Close_Quote_In_List; @@ -777,7 +818,7 @@ Ada.Text_IO.Put_Line ("Right parenthesis expected"); begin V := Get_Frame_Result(Interp.Stack); V := Make_Cons(Interp.Self, V, Nil_Pointer); - V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V); + V := Make_Cons(Interp.Self, Interp.Quote_Symbol, V); Return_Frame (Interp, V); end Close_Quote; @@ -894,9 +935,9 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); when Opcode_And_Finish => Do_And_Finish; - - --when Opcode_Finish_Case_Syntax => - --when Opcode_Finish_Cond_Syntax => + + when Opcode_Cond_Finish => + Do_Cond_Finish; when Opcode_Define_Finish => Do_Define_Finish; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index b4588b8..a3d153f 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -71,10 +71,12 @@ package body H2.Scheme is Label_SymbolQ: constant Object_Character_Array := (Ch.LC_S, Ch.LC_Y, Ch.LC_M, Ch.LC_B, Ch.LC_O, Ch.LC_L, Ch.Question); -- "symbol?" - 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_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); -- "=>" + Label_Arrow: constant Object_Character_Array := (Ch.Equal_Sign, Ch.Greater_Than_Sign); -- "=>" + Label_Else: constant Object_Character_Array := (Ch.LC_E, Ch.LC_L, Ch.LC_S, Ch.LC_E); -- "else" + ----------------------------------------------------------------------------- -- EXCEPTIONS ----------------------------------------------------------------------------- @@ -105,6 +107,7 @@ package body H2.Scheme is Opcode_And_Finish, Opcode_Or_Finish, + Opcode_Cond_Finish, Opcode_Define_Finish, Opcode_Grouped_Call, -- (begin ...), closure apply, let body Opcode_If_Finish, @@ -808,9 +811,10 @@ ada.text_io.put_line ("[GC BEGIN]"); end loop; -- Migrate some known symbols - 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); + Interp.Arrow_Symbol := Move_One_Object(Interp.Arrow_Symbol); + Interp.Else_Symbol := Move_One_Object(Interp.Else_Symbol); + Interp.Quasiquote_Symbol := Move_One_Object(Interp.Quasiquote_Symbol); + Interp.Quote_Symbol := Move_One_Object(Interp.Quote_Symbol); --Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]"); -- Scan the heap @@ -908,7 +912,7 @@ end if; Kind => Pointer_Object, Size => Size, Flags => 0, - Scode => 0, + Scode => Syntax_Code'Val(0), Tag => Unknown_Object, Pointer_Slot => (others => Initial) ); @@ -939,7 +943,7 @@ end if; Kind => Character_Object, Size => Size, Flags => 0, - Scode => 0, + Scode => Syntax_Code'Val(0), Tag => Unknown_Object, Character_Slot => (others => Ch.NUL), Character_Terminator => Ch.NUL @@ -980,7 +984,7 @@ end if; Kind => Byte_Object, Size => Size, Flags => 0, - Scode => 0, + Scode => Syntax_Code'Val(0), Tag => Unknown_Object, Byte_Slot => (others => 0) ); @@ -1123,10 +1127,8 @@ end if; Source: in Object_Character_Array) return Object_Pointer is Result: Object_Pointer; begin -Ada.Text_IO.Put_Line ("Make_String..."); Result := Allocate_Character_Object(Interp, Source); Result.Tag := String_Object; ---Print_Object_Pointer ("Make_String Result - " & Source, Result); return Result; end Make_String; @@ -1802,8 +1804,8 @@ 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); -- "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" + Interp.Quote_Symbol := Make_Syntax (Interp.Self, Quote_Syntax, Label_Quote); -- "quote" + Interp.Quasiquote_Symbol := Make_Syntax (Interp.Self, Quasiquote_Syntax, Label_Quasiquote); -- "quasiquote" Dummy := Make_Syntax (Interp.Self, Set_Syntax, Label_Set); -- "set!" end Make_Syntax_Objects; @@ -1835,7 +1837,8 @@ Ada.Text_IO.Put_Line ("Make_String..."); procedure Make_Common_Symbol_Objects is begin - Interp.Symbol.Arrow := Make_Symbol (Interp.Self, Label_Arrow); + Interp.Arrow_Symbol := Make_Symbol (Interp.Self, Label_Arrow); + Interp.Else_Symbol := Make_Symbol (Interp.Self, Label_Else); end Make_Common_Symbol_Objects; begin declare diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 40af3e0..d79bd3f 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -164,24 +164,24 @@ package H2.Scheme is type Object_Flags is mod 2 ** 4; 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); - 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); + type Syntax_Code is ( + And_Syntax, + Begin_Syntax, + Case_Syntax, + Cond_Syntax, + Define_Syntax, + Do_Syntax, + If_Syntax, + Lambda_Syntax, + Let_Syntax, + Letast_Syntax, + Letrec_Syntax, + Or_Syntax, + Quasiquote_Syntax, + Quote_Syntax, + Set_Syntax + ); - --subtype Procedure_Code is Object_Integer; type Procedure_Code is ( Add_Procedure, Callcc_Procedure, @@ -224,7 +224,7 @@ package H2.Scheme is type Object_Record(Kind: Object_Kind; Size: Object_Size) is record Flags: Object_Flags := 0; - Scode: Syntax_Code := 0; + Scode: Syntax_Code := Syntax_Code'Val(0); Tag: Object_Tag := Unknown_Object; -- Object payload: @@ -503,12 +503,6 @@ private Data: Top_Array(1 .. 100) := (others => null); end record; - type Common_Symbol_Record is record - Arrow: Object_Pointer := Nil_Pointer; - Quasiquote: Object_Pointer := Nil_Pointer; - Quote: 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 @@ -525,7 +519,11 @@ private Root_Frame: Object_Pointer := Nil_Pointer; Stack: Object_Pointer := Nil_Pointer; - Symbol: Common_Symbol_Record; + Arrow_Symbol: Object_Pointer := Nil_Pointer; + Else_Symbol: Object_Pointer := Nil_Pointer; + Quasiquote_Symbol: Object_Pointer := Nil_Pointer; + Quote_Symbol: Object_Pointer := Nil_Pointer; + Top: Top_Record; -- temporary object pointers Base_Input: aliased IO_Record;