From b87ce61c297934a8fc1f9cc3e7e029d0d138c211 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sun, 16 Feb 2014 15:02:04 +0000 Subject: [PATCH] added some essential procedures --- lib/h2-scheme-execute-apply.adb | 250 ++++++++++++++++++++++---------- lib/h2-scheme.adb | 24 +-- 2 files changed, 186 insertions(+), 88 deletions(-) diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index 3cdb42e..db1fdea 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -7,30 +7,148 @@ procedure Apply is Func: aliased Object_Pointer; Args: aliased Object_Pointer; + -- ------------------------------------------------------------- + -- 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_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; + + procedure Apply_Q_Number_Procedure is new Apply_Question_Procedure (Is_Number_Class); + procedure Apply_Q_Procedure_Procedure is new Apply_Question_Procedure (Is_Procedure_Class); + + -- ------------------------------------------------------------- -- Boolean procedures -- ------------------------------------------------------------- procedure Apply_Not_Procedure is + Ptr: Object_Pointer; begin - null; + -- (not obj) + -- 'not' returns #t if obj is false, and returns #f otherwise. + -- (not #t) ; #f + -- (not 0) ; #f + -- (not #f) ; #t + + if not Is_Cons(Args) or else Get_Cdr(Args) /= Nil_Pointer then +Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR NOT?"); + raise Syntax_Error; + end if; + + Ptr := Get_Car(Args); + if Is_True_Class(Ptr) then + Ptr := False_Pointer; + else + Ptr := True_Pointer; + end if; + Return_Frame (Interp, Ptr); end Apply_Not_Procedure; procedure Apply_Q_Boolean_Procedure is + Ptr: Object_Pointer; begin - null; + -- (boolean? obj) + -- it returns #t if obj is either #t or #f and + -- returns #f otherwise. + -- (boolean? #f) ; #t + -- (boolean? 0) ; #f + + if not Is_Cons(Args) or else Get_Cdr(Args) /= Nil_Pointer then +Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR BOOLEAN?"); + raise Syntax_Error; + end if; + + Ptr := Get_Car(Args); + if Ptr = True_Pointer or else Ptr = False_Pointer then + Ptr := True_Pointer; + else + Ptr := False_Pointer; + end if; + Return_Frame (Interp, Ptr); end Apply_Q_Boolean_Procedure; -- ------------------------------------------------------------- -- Equivalence predicates -- ------------------------------------------------------------- - procedure Apply_Q_Eqv_Procedure is + procedure Apply_Q_Eq_Procedure is + Ptr: Object_Pointer; begin - null; + if not Is_Cons(Args) or else Get_Cdr(Args) = Nil_Pointer or else Get_Cdr(Get_Cdr(Args)) /= Nil_Pointer then +Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR EQ?"); + raise Syntax_Error; + end if; + if Get_Car(Args) = Get_Car(Get_Cdr(Args)) then + Ptr := True_Pointer; + else + Ptr := False_Pointer; + end if; + Return_Frame (Interp, Ptr); + end Apply_Q_Eq_Procedure; + + procedure Apply_Q_Eqv_Procedure is + Ptr: Object_Pointer; + begin + if not Is_Cons(Args) or else Get_Cdr(Args) = Nil_Pointer or else Get_Cdr(Get_Cdr(Args)) /= Nil_Pointer then +Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR EQV?"); + raise Syntax_Error; + end if; + + if Equal_Values(Get_Car(Args), Get_Car(Get_Cdr(Args))) then + Ptr := True_Pointer; + else + Ptr := False_Pointer; + end if; + Return_Frame (Interp, Ptr); end Apply_Q_Eqv_Procedure; -- ------------------------------------------------------------- -- List manipulation procedures -- ------------------------------------------------------------- + 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_Pair_Class (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_Pair_Class); + begin + return Is_Cons(X); + end Is_Pair_Class; + + procedure Apply_Q_Null_Procedure is new Apply_Question_Procedure (Is_Null_Class); + procedure Apply_Q_Pair_Procedure is new Apply_Question_Procedure (Is_Pair_Class); + procedure Apply_Car_Procedure is Ptr: Object_Pointer := Args; A: Object_Pointer; @@ -126,6 +244,41 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcdr"); Return_Frame (Interp, A); end Apply_Setcdr_Procedure; + -- ------------------------------------------------------------- + -- Symbol procedures + -- ------------------------------------------------------------- + procedure Apply_Q_Symbol_Procedure is new Apply_Question_Procedure (Is_Symbol); + + -- ------------------------------------------------------------- + -- String procedures + -- ------------------------------------------------------------- + procedure Apply_Q_String_Procedure is new Apply_Question_Procedure (Is_String); + + procedure Apply_Q_String_EQ_Procedure is + Ptr1: Object_Pointer; + Ptr2: Object_Pointer; + begin + if not Is_Cons(Args) or else Get_Cdr(Args) = Nil_Pointer or else Get_Cdr(Get_Cdr(Args)) /= Nil_Pointer then +Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR STRING=?"); + raise Syntax_Error; + end if; + + Ptr1 := Get_Car(Args); + Ptr2 := Get_Car(Get_Cdr(Args)); + if not Is_String(Ptr1) or else not Is_String(Ptr2) then +Ada.Text_IO.Put_Line ("STRING EXPECTED FOR STRING=?"); + raise Evaluation_Error; + end if; + + if Ptr1.Character_Slot = Ptr2.Character_Slot then + Ptr1 := True_Pointer; + else + Ptr1 := False_Pointer; + end if; + + Return_Frame (Interp, Ptr1); + end Apply_Q_String_EQ_Procedure; + -- ------------------------------------------------------------- -- Arithmetic procedures -- ------------------------------------------------------------- @@ -304,72 +457,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); procedure Apply_N_GE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Or_Equal); procedure Apply_N_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_Q_Null_Procedure is new Apply_Question_Procedure (Is_Null_Class); - procedure Apply_Q_Number_Procedure is new Apply_Question_Procedure (Is_Number_Class); - procedure Apply_Q_Procedure_Procedure is new Apply_Question_Procedure (Is_Procedure_Class); - procedure Apply_Q_String_Procedure is new Apply_Question_Procedure (Is_String_Class); - procedure Apply_Q_Symbol_Procedure is new Apply_Question_Procedure (Is_Symbol_Class); - - procedure Apply_Q_Eq_Procedure is - begin - null; - end Apply_Q_Eq_Procedure; - -- ------------------------------------------------------------- -- Closure @@ -608,17 +696,21 @@ begin Apply_Q_Eq_Procedure; when Q_Eqv_Procedure => Apply_Q_Eqv_Procedure; - when Q_Null_Procedure => - Apply_Q_Null_Procedure; - when Q_Number_Procedure => - Apply_Q_Number_Procedure; - when Q_Procedure_Procedure => - Apply_Q_Procedure_Procedure; - when Q_String_Procedure => - Apply_Q_String_Procedure; - when Q_Symbol_Procedure => - Apply_Q_Symbol_Procedure; + when Q_Null_Procedure => + Apply_Q_Null_Procedure; + when Q_Number_Procedure => + Apply_Q_Number_Procedure; + when Q_Pair_Procedure => + Apply_Q_Pair_Procedure; + when Q_Procedure_Procedure => + Apply_Q_Procedure_Procedure; + when Q_String_Procedure => + Apply_Q_String_Procedure; + when Q_String_EQ_Procedure => + Apply_Q_String_EQ_Procedure; + when Q_Symbol_Procedure => + Apply_Q_Symbol_Procedure; when Setcar_Procedure => Apply_Setcar_Procedure; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 76c75e7..878fee6 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -44,8 +44,10 @@ package body H2.Scheme is Q_Eqv_Procedure, Q_Null_Procedure, Q_Number_Procedure, + Q_Pair_Procedure, Q_Procedure_Procedure, Q_String_Procedure, + Q_String_EQ_Procedure, Q_Symbol_Procedure, Setcar_Procedure, @@ -76,11 +78,11 @@ package body H2.Scheme is Label_Set: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Exclamation); -- "set!" - Label_Callcc: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_L, Ch.LC_L, Ch.Minus_Sign, - Ch.LC_W, Ch.LC_I, Ch.LC_T, Ch.LC_H, Ch.Minus_Sign, - 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_Callcc: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_L, Ch.LC_L, Ch.Minus_Sign, + Ch.LC_W, Ch.LC_I, Ch.LC_T, Ch.LC_H, Ch.Minus_Sign, + 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" @@ -102,8 +104,10 @@ package body H2.Scheme is Label_Q_Eqv: constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.LC_V, Ch.Question); -- "eqv?" Label_Q_Null: constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_L, Ch.LC_L, Ch.Question); -- "null?" Label_Q_Number: 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_Q_Pair: constant Object_Character_Array := (Ch.LC_P, Ch.LC_A, Ch.LC_I, Ch.LC_R, Ch.Question); -- "pair?" Label_Q_Procedure: 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_Q_String: 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_Q_String_EQ: constant Object_Character_Array := (Ch.LC_S, Ch.LC_T, Ch.LC_R, Ch.LC_I, Ch.LC_N, Ch.LC_G, Ch.Equal_Sign, Ch.Question); -- "string=?" Label_Q_Symbol: 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_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!" @@ -499,10 +503,12 @@ package body H2.Scheme is when others => -- TODO: BIGNUM, OTHER NUMERIC DATA. - if Get_Pointer_Type(Y) /= Ptr_Type then + if Is_Special_Pointer(X) then + return X = Y; + elsif Get_Pointer_Type(Y) /= Ptr_Type then return Standard.False; end if; - + case X.Kind is when Character_Object => if Y.Kind = X.Kind then @@ -531,8 +537,6 @@ package body H2.Scheme is when Moved_Object => raise Internal_Error; end case; - - return X = Y; end case; end Equal_Values; @@ -1943,8 +1947,10 @@ end if; Dummy := Make_Procedure (Interp.Self, Q_Eqv_Procedure, Label_Q_Eqv); -- "eqv?" Dummy := Make_Procedure (Interp.Self, Q_Null_Procedure, Label_Q_Null); -- "null?" Dummy := Make_Procedure (Interp.Self, Q_Number_Procedure, Label_Q_Number); -- "number?" + Dummy := Make_Procedure (Interp.Self, Q_Pair_Procedure, Label_Q_Pair); -- "pair?" Dummy := Make_Procedure (Interp.Self, Q_Procedure_Procedure, Label_Q_Procedure); -- "procedure?" Dummy := Make_Procedure (Interp.Self, Q_String_Procedure, Label_Q_String); -- "string?" + Dummy := Make_Procedure (Interp.Self, Q_String_EQ_Procedure, Label_Q_String_EQ); -- "string=?" Dummy := Make_Procedure (Interp.Self, Q_Symbol_Procedure, Label_Q_Symbol); -- "symbol?" Dummy := Make_Procedure (Interp.Self, Setcar_Procedure, Label_Setcar); -- "set-car!"