From d7e25ac8cacdcaf45d3850757917631e138b221f Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Mon, 10 Feb 2014 08:33:18 +0000 Subject: [PATCH] added some query procedures --- lib/h2-scheme-execute-apply.adb | 88 +++++++++++++++++++++++++++++++-- lib/h2-scheme.adb | 70 ++++++++++++++++++-------- lib/h2-scheme.ads | 43 +++++++++------- 3 files changed, 160 insertions(+), 41 deletions(-) diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index a01b042..abee8b3 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -197,6 +197,10 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car); Return_Frame (Interp, Integer_To_Pointer(Num)); end Apply_Quotient_Procedure; + -- ------------------------------------------------------------- + -- Comparions procedures + -- ------------------------------------------------------------- + generic with function Validate (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean; with function Compare (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean; @@ -280,6 +284,67 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); procedure Apply_GE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Or_Equal); procedure Apply_LE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Or_Equal); + -- ------------------------------------------------------------- + -- Questioning procedures + -- ------------------------------------------------------------- + generic + with function Question (X: in Object_Pointer) return Standard.Boolean; + procedure Apply_Question_Procedure; + + procedure Apply_Question_Procedure is + Bool: Object_Pointer; + begin + if Is_Cons(Args) and then not Is_Cons(Get_Cdr(Args)) then + -- 1 actual argument + if Question(Get_Car(Args)) then + Bool := True_Pointer; + else + Bool := False_Pointer; + end if; + Return_Frame (Interp, Bool); + else +Ada.Text_IO.Put_line ("WRONG NUMBER OF ARGUMETNS FOR COMPARISON"); + raise Syntax_Error; + end if; + end Apply_Question_Procedure; + + function Is_Null_Class (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_Null_Class); + begin + return X = Nil_Pointer; + end Is_Null_Class; + + function Is_Number_Class (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_Number_Class); + begin + return Is_Integer(X); -- TODO bignum + end Is_Number_Class; + + function Is_Procedure_Class (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_Procedure_Class); + begin + return Is_Closure(X) or else Is_Procedure(X) or else Is_Continuation(X); + end Is_Procedure_Class; + + function Is_String_Class (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_String_Class); + begin + return Is_String(X); + end Is_String_Class; + + function Is_Symbol_Class (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_Symbol_Class); + begin + return Is_Symbol(X); + end Is_Symbol_Class; + + procedure Apply_NullQ_Procedure is new Apply_Question_Procedure (Is_Null_Class); + procedure Apply_NumberQ_Procedure is new Apply_Question_Procedure (Is_Number_Class); + procedure Apply_ProcedureQ_Procedure is new Apply_Question_Procedure (Is_Procedure_Class); + procedure Apply_StringQ_Procedure is new Apply_Question_Procedure (Is_String_Class); + procedure Apply_SymbolQ_Procedure is new Apply_Question_Procedure (Is_Symbol_Class); + + -- ------------------------------------------------------------- -- Closure -- ------------------------------------------------------------- @@ -498,8 +563,10 @@ begin Apply_Multiply_Procedure; when Quotient_Procedure => Apply_Quotient_Procedure; - --when Remainder_Procedure => - -- Apply_Remainder_Procedure; + when Remainder_Procedure => + --Apply_Remainder_Procedure; + ada.text_io.put_line ("NOT IMPLEMENTED"); + raise Evaluation_Error; when EQ_Procedure => Apply_EQ_Procedure; @@ -511,8 +578,21 @@ begin Apply_GE_Procedure; when LE_Procedure => Apply_LE_Procedure; - when others => - raise Internal_Error; + + + when NullQ_Procedure => + Apply_NullQ_Procedure; + when NumberQ_Procedure => + Apply_NumberQ_Procedure; + when ProcedureQ_Procedure => + Apply_ProcedureQ_Procedure; + when StringQ_Procedure => + Apply_StringQ_Procedure; + when SymbolQ_Procedure => + Apply_SymbolQ_Procedure; + +-- when others => +-- raise Internal_Error; end case; when Closure_Object => diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 8791454..b4588b8 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -49,21 +49,26 @@ package body H2.Scheme is Ch.LC_C, Ch.LC_U, Ch.LC_R, Ch.LC_R, Ch.LC_E, Ch.LC_N, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_T, Ch.LC_I, Ch.LC_N, Ch.LC_U, Ch.LC_A, Ch.LC_T, Ch.LC_I, Ch.LC_O, Ch.LC_N); -- "call-with-current-continuation" - 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" - Label_Cons: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_S); -- "cons" - Label_EQ: constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "=" - Label_GE: constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">=" - Label_GT: constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">" - Label_LE: constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<=" - Label_LT: constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<" - Label_Minus: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-" - Label_Multiply: constant Object_Character_Array := (1 => Ch.Asterisk); -- "*" - Label_Plus: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+" - Label_Quotient: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_I, Ch.LC_E, Ch.LC_N, Ch.LC_T); -- "quotient" - Label_Remainder: constant Object_Character_Array := (Ch.LC_R, Ch.LC_E, Ch.LC_M, Ch.LC_A, Ch.LC_I, Ch.LC_N, Ch.LC_D, Ch.LC_E, Ch.LC_R); -- "remainder" - Label_Setcar: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_A, Ch.LC_R, Ch.Exclamation); -- "set-car!" - Label_Setcdr: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_D, Ch.LC_R, Ch.Exclamation); -- "set-cdr!" + 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" + Label_Cons: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_S); -- "cons" + Label_EQ: constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "=" + Label_GE: constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">=" + Label_GT: constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">" + Label_LE: constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<=" + Label_LT: constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<" + Label_Minus: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-" + Label_Multiply: constant Object_Character_Array := (1 => Ch.Asterisk); -- "*" + Label_NullQ: constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_L, Ch.LC_L, Ch.Question); -- "null?" + Label_NumberQ: constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_M, Ch.LC_B, Ch.LC_E, Ch.LC_R, Ch.Question); -- "number?" + Label_Plus: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+" + Label_ProcedureQ: constant Object_Character_Array := (Ch.LC_P, Ch.LC_R, Ch.LC_O, Ch.LC_C, Ch.LC_E, Ch.LC_D, Ch.LC_U, Ch.LC_R, Ch.LC_E, Ch.Question); -- "procedure?" + Label_Quotient: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_I, Ch.LC_E, Ch.LC_N, Ch.LC_T); -- "quotient" + Label_Remainder: constant Object_Character_Array := (Ch.LC_R, Ch.LC_E, Ch.LC_M, Ch.LC_A, Ch.LC_I, Ch.LC_N, Ch.LC_D, Ch.LC_E, Ch.LC_R); -- "remainder" + Label_Setcar: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_A, Ch.LC_R, Ch.Exclamation); -- "set-car!" + Label_Setcdr: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_D, Ch.LC_R, Ch.Exclamation); -- "set-cdr!" + Label_StringQ: constant Object_Character_Array := (Ch.LC_S, Ch.LC_T, Ch.LC_R, Ch.LC_I, Ch.LC_N, Ch.LC_G, Ch.Question); -- "string?" + 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" @@ -381,6 +386,19 @@ package body H2.Scheme is return Integer_To_Pointer(Opcode_Type'Pos(Opcode)); end Opcode_To_Pointer; + function Pointer_To_Procedure_Code (Pointer: in Object_Pointer) return Procedure_Code is + pragma Inline (Pointer_To_Procedure_Code); + begin + return Procedure_Code'Val(Pointer_To_Integer(Pointer)); + end Pointer_To_Procedure_Code; + + function Procedure_Code_To_Pointer (Opcode: in Procedure_Code) return Object_Pointer is + pragma Inline (Procedure_Code_To_Pointer); + begin + return Integer_To_Pointer(Procedure_Code'Pos(Opcode)); + end Procedure_Code_To_Pointer; + + function Token_To_Pointer (Interp: access Interpreter_Record; Token: in Token_Record) return Object_Pointer is begin @@ -1094,12 +1112,19 @@ end if; end Reverse_Cons; ----------------------------------------------------------------------------- + function Is_String (Source: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_String); + begin + return Is_Normal_Pointer(Source) and then + Source.Tag = String_Object; + end Is_String; + function Make_String (Interp: access Interpreter_Record; 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 := Allocate_Character_Object(Interp, Source); Result.Tag := String_Object; --Print_Object_Pointer ("Make_String Result - " & Source, Result); return Result; @@ -1108,7 +1133,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); function Is_Symbol (Source: in Object_Pointer) return Standard.Boolean is pragma Inline (Is_Symbol); begin - return Is_Normal_Pointer (Source) and then + return Is_Normal_Pointer(Source) and then Source.Tag = Symbol_Object; end Is_Symbol; @@ -1538,7 +1563,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); end Is_Syntax; function Make_Procedure (Interp: access Interpreter_Record; - Opcode: in Procedure_Code; + Code: in Procedure_Code; Name: in Object_Character_Array) return Object_Pointer is -- this procedure is for internal use only Symbol: aliased Object_Pointer; @@ -1553,7 +1578,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- Make the actual procedure object Proc := Allocate_Pointer_Object(Interp, Procedure_Object_Size, Nil_Pointer); Proc.Tag := Procedure_Object; - Proc.Pointer_Slot(Procedure_Opcode_Index) := Integer_To_Pointer(Opcode); + Proc.Pointer_Slot(Procedure_Opcode_Index) := Procedure_Code_To_Pointer(Code); -- Link it to the top environement pragma Assert (Get_Frame_Environment(Interp.Stack) = Interp.Root_Environment); @@ -1576,7 +1601,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); pragma Assert (Is_Procedure(Proc)); pragma Assert (Proc.Size = Procedure_Object_Size); begin - return Pointer_To_Integer(Proc.Pointer_Slot(Procedure_Opcode_Index)); + return Pointer_To_Procedure_Code(Proc.Pointer_Slot(Procedure_Opcode_Index)); end Get_Procedure_Opcode; ----------------------------------------------------------------------------- @@ -1796,10 +1821,15 @@ Ada.Text_IO.Put_Line ("Make_String..."); Dummy := Make_Procedure (Interp.Self, LE_Procedure, Label_LE); -- "<=" Dummy := Make_Procedure (Interp.Self, LT_Procedure, Label_LT); -- "<" Dummy := Make_Procedure (Interp.Self, Multiply_Procedure, Label_Multiply); -- "*" + Dummy := Make_Procedure (Interp.Self, NumberQ_Procedure, Label_NumberQ); -- "number?" + Dummy := Make_Procedure (Interp.Self, NullQ_Procedure, Label_NullQ); -- "null?" Dummy := Make_Procedure (Interp.Self, Quotient_Procedure, Label_Quotient); -- "quotient" Dummy := Make_Procedure (Interp.Self, Remainder_Procedure, Label_Remainder); -- "remainder" Dummy := Make_Procedure (Interp.Self, Setcar_Procedure, Label_Setcar); -- "set-car!" Dummy := Make_Procedure (Interp.Self, Setcdr_Procedure, Label_Setcdr); -- "set-cdr!" + Dummy := Make_Procedure (Interp.Self, ProcedureQ_Procedure, Label_ProcedureQ); -- "procedure?" + Dummy := Make_Procedure (Interp.Self, StringQ_Procedure, Label_StringQ); -- "string?" + Dummy := Make_Procedure (Interp.Self, SymbolQ_Procedure, Label_SymbolQ); -- "symbol?" Dummy := Make_Procedure (Interp.Self, Subtract_Procedure, Label_Minus); -- "-" end Make_Procedure_Objects; diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index fbcc182..40af3e0 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -181,23 +181,32 @@ package H2.Scheme is 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); - Callcc_Procedure: constant Procedure_Code := Procedure_Code'(1); - Car_Procedure: constant Procedure_Code := Procedure_Code'(2); - Cdr_Procedure: constant Procedure_Code := Procedure_Code'(3); - Cons_Procedure: constant Procedure_Code := Procedure_Code'(4); - EQ_Procedure: constant Procedure_Code := Procedure_Code'(5); - GT_Procedure: constant Procedure_Code := Procedure_Code'(6); - LT_Procedure: constant Procedure_Code := Procedure_Code'(7); - GE_Procedure: constant Procedure_Code := Procedure_Code'(8); - LE_Procedure: constant Procedure_Code := Procedure_Code'(9); - Multiply_Procedure: constant Procedure_Code := Procedure_Code'(10); - Quotient_Procedure: constant Procedure_Code := Procedure_Code'(11); - Remainder_Procedure: constant Procedure_Code := Procedure_Code'(12); - Setcar_Procedure: constant Procedure_Code := Procedure_Code'(13); - Setcdr_Procedure: constant Procedure_Code := Procedure_Code'(14); - Subtract_Procedure: constant Procedure_Code := Procedure_Code'(15); + --subtype Procedure_Code is Object_Integer; + type Procedure_Code is ( + Add_Procedure, + Callcc_Procedure, + Car_Procedure, + Cdr_Procedure, + Cons_Procedure, + EQ_Procedure, + GT_Procedure, + LT_Procedure, + GE_Procedure, + LE_Procedure, + Multiply_Procedure, + NullQ_Procedure, + NumberQ_Procedure, + ProcedureQ_Procedure, + Quotient_Procedure, + Remainder_Procedure, + Setcar_Procedure, + Setcdr_Procedure, + StringQ_Procedure, + Subtract_Procedure, + SymbolQ_Procedure + ); + for Procedure_Code'Size use Object_Integer'Size; + type Object_Tag is ( Unknown_Object,