From c123f1c39a09d32b6327c49f55e1086c225e2ad6 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sat, 15 Feb 2014 03:41:37 +0000 Subject: [PATCH] fixed a comparison between a normal object and a special pointer --- lib/h2-scheme-execute-apply.adb | 67 +++++++++++++++++++-------------- lib/h2-scheme.adb | 63 ++++++++++++++++++------------- 2 files changed, 74 insertions(+), 56 deletions(-) diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index 7594bed..3cdb42e 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -7,7 +7,27 @@ procedure Apply is Func: aliased Object_Pointer; Args: aliased Object_Pointer; + -- ------------------------------------------------------------- + -- Boolean procedures + -- ------------------------------------------------------------- + procedure Apply_Not_Procedure is + begin + null; + end Apply_Not_Procedure; + procedure Apply_Q_Boolean_Procedure is + begin + null; + end Apply_Q_Boolean_Procedure; + + -- ------------------------------------------------------------- + -- Equivalence predicates + -- ------------------------------------------------------------- + procedure Apply_Q_Eqv_Procedure is + begin + null; + end Apply_Q_Eqv_Procedure; + -- ------------------------------------------------------------- -- List manipulation procedures -- ------------------------------------------------------------- @@ -106,7 +126,6 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcdr"); Return_Frame (Interp, A); end Apply_Setcdr_Procedure; - -- ------------------------------------------------------------- -- Arithmetic procedures -- ------------------------------------------------------------- @@ -351,16 +370,6 @@ Ada.Text_IO.Put_line ("WRONG NUMBER OF ARGUMETNS FOR COMPARISON"); null; end Apply_Q_Eq_Procedure; - procedure Apply_Q_Eqv_Procedure is - begin - null; - end Apply_Q_Eqv_Procedure; - - - procedure Apply_Not_Procedure is - begin - null; - end Apply_Not_Procedure; -- ------------------------------------------------------------- -- Closure @@ -567,24 +576,11 @@ begin Apply_Cdr_Procedure; when Cons_Procedure => Apply_Cons_Procedure; - when Setcar_Procedure => - Apply_Setcar_Procedure; - when Setcdr_Procedure => - Apply_Setcdr_Procedure; + when Not_Procedure => + Apply_Not_Procedure; when N_Add_Procedure => Apply_Add_Procedure; - when N_Subtract_Procedure => - Apply_Subtract_Procedure; - when N_Multiply_Procedure => - Apply_Multiply_Procedure; - when N_Quotient_Procedure => - Apply_Quotient_Procedure; - when N_Remainder_Procedure => - --Apply_Remainder_Procedure; - ada.text_io.put_line ("NOT IMPLEMENTED"); - raise Evaluation_Error; - when N_EQ_Procedure => Apply_N_EQ_Procedure; when N_GT_Procedure => @@ -595,8 +591,19 @@ begin Apply_N_GE_Procedure; when N_LE_Procedure => Apply_N_LE_Procedure; + when N_Multiply_Procedure => + Apply_Multiply_Procedure; + when N_Quotient_Procedure => + Apply_Quotient_Procedure; + when N_Remainder_Procedure => + --Apply_Remainder_Procedure; + ada.text_io.put_line ("NOT IMPLEMENTED"); + raise Evaluation_Error; + when N_Subtract_Procedure => + Apply_Subtract_Procedure; - + when Q_Boolean_Procedure => + Apply_Q_Boolean_Procedure; when Q_Eq_Procedure => Apply_Q_Eq_Procedure; when Q_Eqv_Procedure => @@ -613,8 +620,10 @@ begin Apply_Q_Symbol_Procedure; - when Not_Procedure => - Apply_Not_Procedure; + when Setcar_Procedure => + Apply_Setcar_Procedure; + when Setcdr_Procedure => + Apply_Setcdr_Procedure; end case; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index af55ae8..76c75e7 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -26,20 +26,20 @@ package body H2.Scheme is Car_Procedure, Cdr_Procedure, Cons_Procedure, - Not_Procedure, - + + N_Add_Procedure, N_EQ_Procedure, N_GT_Procedure, N_LT_Procedure, N_GE_Procedure, N_LE_Procedure, - N_Add_Procedure, N_Multiply_Procedure, N_Quotient_Procedure, N_Remainder_Procedure, N_Subtract_Procedure, - + + Q_Boolean_Procedure, Q_Eq_Procedure, Q_Eqv_Procedure, Q_Null_Procedure, @@ -47,7 +47,7 @@ package body H2.Scheme is Q_Procedure_Procedure, Q_String_Procedure, Q_Symbol_Procedure, - + Setcar_Procedure, Setcdr_Procedure ); @@ -84,20 +84,20 @@ package body H2.Scheme is 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_Not: constant Object_Character_Array := (Ch.LC_N, Ch.LC_O, Ch.LC_T); -- "not" + + Label_N_Add: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+" Label_N_EQ: constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "=" Label_N_GE: constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">=" Label_N_GT: constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">" Label_N_LE: constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<=" Label_N_LT: constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<" - Label_N_Minus: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-" Label_N_Multiply: constant Object_Character_Array := (1 => Ch.Asterisk); -- "*" - Label_N_Plus: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+" Label_N_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_N_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_N_Subtract: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-" + Label_Q_Boolean: constant Object_Character_Array := (Ch.LC_B, Ch.LC_O, Ch.LC_O, Ch.LC_L, Ch.LC_E, Ch.LC_A, Ch.LC_N, Ch.Question); -- "boolean?" Label_Q_Eq: constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.Question); -- "eq?" 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?" @@ -108,15 +108,13 @@ package body H2.Scheme is 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_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_Else: constant Object_Character_Array := (Ch.LC_E, Ch.LC_L, Ch.LC_S, Ch.LC_E); -- "else" - + ----------------------------------------------------------------------------- -- EXCEPTIONS ----------------------------------------------------------------------------- @@ -479,22 +477,32 @@ package body H2.Scheme is function Equal_Values (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is Ptr_Type: Object_Pointer_Type; begin - + if X = Y then + return Standard.True; + end if; + Ptr_Type := Get_Pointer_Type(X); case Ptr_Type is when Object_Pointer_Type_Integer | Object_Pointer_Type_Character | Object_Pointer_Type_Byte => - if Get_Pointer_Type(Y) = Ptr_Type then - return X = Y; - else + -- This part of the code won't be reached if two special + -- pointers are the same. So False can be returned safely + -- without further check. See the lines commented out. + + --if Get_Pointer_Type(Y) = Ptr_Type then + -- return X = Y; + --else return Standard.False; - end if; + --end if; when others => -- TODO: BIGNUM, OTHER NUMERIC DATA. - + if 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 @@ -1911,25 +1919,26 @@ end if; procedure Make_Procedure_Objects is Dummy: Object_Pointer; begin - + Dummy := Make_Procedure (Interp.Self, Callcc_Procedure, Label_Callcc); -- "call-with-current-continuation" Dummy := Make_Procedure (Interp.Self, Car_Procedure, Label_Car); -- "car" Dummy := Make_Procedure (Interp.Self, Cdr_Procedure, Label_Cdr); -- "cdr" Dummy := Make_Procedure (Interp.Self, Cons_Procedure, Label_Cons); -- "cons" - + Dummy := Make_Procedure (Interp.Self, Not_Procedure, Label_Not); -- "not" + + Dummy := Make_Procedure (Interp.Self, N_Add_Procedure, Label_N_Add); -- "+" Dummy := Make_Procedure (Interp.Self, N_EQ_Procedure, Label_N_EQ); -- "=" Dummy := Make_Procedure (Interp.Self, N_GE_Procedure, Label_N_GE); -- ">=" Dummy := Make_Procedure (Interp.Self, N_GT_Procedure, Label_N_GT); -- ">" Dummy := Make_Procedure (Interp.Self, N_LE_Procedure, Label_N_LE); -- "<=" Dummy := Make_Procedure (Interp.Self, N_LT_Procedure, Label_N_LT); -- "<" - Dummy := Make_Procedure (Interp.Self, N_Add_Procedure, Label_N_Plus); -- "+" Dummy := Make_Procedure (Interp.Self, N_Multiply_Procedure, Label_N_Multiply); -- "*" Dummy := Make_Procedure (Interp.Self, N_Quotient_Procedure, Label_N_Quotient); -- "quotient" Dummy := Make_Procedure (Interp.Self, N_Remainder_Procedure, Label_N_Remainder); -- "remainder" - Dummy := Make_Procedure (Interp.Self, N_Subtract_Procedure, Label_N_Minus); -- "-" - - + Dummy := Make_Procedure (Interp.Self, N_Subtract_Procedure, Label_N_Subtract); -- "-" + + Dummy := Make_Procedure (Interp.Self, Q_Boolean_Procedure, Label_Q_Boolean); -- "boolean?" Dummy := Make_Procedure (Interp.Self, Q_Eq_Procedure, Label_Q_Eq); -- "eq?" Dummy := Make_Procedure (Interp.Self, Q_Eqv_Procedure, Label_Q_Eqv); -- "eqv?" Dummy := Make_Procedure (Interp.Self, Q_Null_Procedure, Label_Q_Null); -- "null?" @@ -1937,10 +1946,10 @@ end if; 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_Symbol_Procedure, Label_Q_Symbol); -- "symbol?" - + Dummy := Make_Procedure (Interp.Self, Setcar_Procedure, Label_Setcar); -- "set-car!" Dummy := Make_Procedure (Interp.Self, Setcdr_Procedure, Label_Setcdr); -- "set-cdr!" - + end Make_Procedure_Objects; procedure Make_Common_Symbol_Objects is