diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index abee8b3..7594bed 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -106,6 +106,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcdr"); Return_Frame (Interp, A); end Apply_Setcdr_Procedure; + -- ------------------------------------------------------------- -- Arithmetic procedures -- ------------------------------------------------------------- @@ -278,11 +279,11 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); return Pointer_To_Integer(X) <= Pointer_To_Integer(Y); end Less_Or_Equal; - procedure Apply_EQ_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Equal_To); - procedure Apply_GT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Than); - procedure Apply_LT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Than); - 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); + procedure Apply_N_EQ_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Equal_To); + procedure Apply_N_GT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Than); + procedure Apply_N_LT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Than); + 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 @@ -338,13 +339,29 @@ Ada.Text_IO.Put_line ("WRONG NUMBER OF ARGUMETNS FOR COMPARISON"); 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); - + 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; + + 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 -- ------------------------------------------------------------- @@ -555,44 +572,50 @@ begin when Setcdr_Procedure => Apply_Setcdr_Procedure; - when Add_Procedure => + when N_Add_Procedure => Apply_Add_Procedure; - when Subtract_Procedure => + when N_Subtract_Procedure => Apply_Subtract_Procedure; - when Multiply_Procedure => + when N_Multiply_Procedure => Apply_Multiply_Procedure; - when Quotient_Procedure => + when N_Quotient_Procedure => Apply_Quotient_Procedure; - when Remainder_Procedure => + when N_Remainder_Procedure => --Apply_Remainder_Procedure; ada.text_io.put_line ("NOT IMPLEMENTED"); raise Evaluation_Error; - when EQ_Procedure => - Apply_EQ_Procedure; - when GT_Procedure => - Apply_GT_Procedure; - when LT_Procedure => - Apply_LT_Procedure; - when GE_Procedure => - Apply_GE_Procedure; - when LE_Procedure => - Apply_LE_Procedure; + when N_EQ_Procedure => + Apply_N_EQ_Procedure; + when N_GT_Procedure => + Apply_N_GT_Procedure; + when N_LT_Procedure => + Apply_N_LT_Procedure; + when N_GE_Procedure => + Apply_N_GE_Procedure; + when N_LE_Procedure => + Apply_N_LE_Procedure; - 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 Q_Eq_Procedure => + 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 Not_Procedure => + Apply_Not_Procedure; --- when others => --- raise Internal_Error; end case; when Closure_Object => diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index f0f1e0c..0fbd03a 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -109,7 +109,7 @@ procedure Evaluate is raise Syntax_Error; end if; - --Key := Get_Car(Operand); + --Key := Get_Car(Operand); -- Ptr1 := Get_Cdr(Operand); -- list. while Is_Cons(Ptr1) loop @@ -119,7 +119,7 @@ procedure Evaluate is raise Syntax_Error; end if; - Ptr3 := Get_Car(Ptr2); -- + Ptr3 := Get_Car(Ptr2); -- list or 'else' if Is_Cons(Ptr3) then if Get_Last_Cdr(Ptr3) /= Nil_Pointer then Ada.Text_IO.Put_LINE ("FUCKING CDR FOR CASE DATUM"); @@ -135,6 +135,11 @@ procedure Evaluate is Ada.Text_IO.Put_LINE ("INVALID DATUM FOR CASE"); raise Syntax_Error; end if; + + if Get_Cdr(Ptr2) = Nil_Pointer then + Ada.Text_IO.Put_Line ("NO EXPRESSION IN CASE CLAUSE"); + raise Syntax_Error; + end if; Ptr1 := Get_Cdr(Ptr1); -- next list end loop; @@ -146,9 +151,9 @@ procedure Evaluate is Synlist.Flags := Synlist.Flags or Syntax_Checked; end if; - - Ada.Text_IO.Put_LINE ("UNIMPLEMENTED"); - raise Evaluation_Error; + + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Operand), Nil_Pointer); -- + Push_Subframe (Interp, Opcode_Case_Finish, Get_Cdr(Operand)); -- list end Evaluate_Case_Syntax; -- ---------------------------------------------------------------- diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 87572cb..1682678 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -66,6 +66,41 @@ procedure Execute (Interp: in out Interpreter_Record) is procedure Do_And_Finish is new Evaluate_While(Is_True_Class); procedure Do_Or_Finish is new Evaluate_While(Is_False_Class); + -- ---------------------------------------------------------------- + procedure Do_Case_Finish is + pragma Inline (Do_Case_Finish); + + R: Object_Pointer; + O: Object_Pointer; + C: Object_Pointer; + D: Object_Pointer; + begin + R := Get_Frame_Result(Interp.Stack); -- result + O := Get_Frame_Operand(Interp.Stack); -- list + + while Is_Cons(O) loop + C := Get_Car(O); -- + D := Get_Car(C); -- list + if D = Interp.Else_Symbol then + Reload_Frame (Interp, Opcode_Grouped_Call, Get_Cdr(C)); + return; + end if; + + while Is_Cons(D) loop + if Equal_Values(R, Get_Car(D)) then -- + Reload_Frame (Interp, Opcode_Grouped_Call, Get_Cdr(C)); + return; + end if; + D := Get_Cdr(D); + end loop; + + O := Get_Cdr(O); + end loop; + + -- no match found; + Pop_Frame (Interp); + end Do_Case_Finish; + -- ---------------------------------------------------------------- procedure Do_Cond_Finish is pragma Inline (Do_Cond_Finish); @@ -936,6 +971,9 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); when Opcode_And_Finish => Do_And_Finish; + when Opcode_Case_Finish => + Do_Case_Finish; + when Opcode_Cond_Finish => Do_Cond_Finish; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 190f1d6..af55ae8 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -21,6 +21,38 @@ package body H2.Scheme is -- PRIMITIVE DEFINITIONS ----------------------------------------------------------------------------- + type Procedure_Code is ( + Callcc_Procedure, + Car_Procedure, + Cdr_Procedure, + Cons_Procedure, + + Not_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_Eq_Procedure, + Q_Eqv_Procedure, + Q_Null_Procedure, + Q_Number_Procedure, + Q_Procedure_Procedure, + Q_String_Procedure, + Q_Symbol_Procedure, + + Setcar_Procedure, + Setcdr_Procedure + ); + for Procedure_Code'Size use Object_Integer'Size; + -- I define these constants to word around the limitation of not being -- able to use a string literal when the string type is a generic parameter. -- Why doesn't ada include a formal type support for different character @@ -52,23 +84,31 @@ 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_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_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_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?" + 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_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_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!" + 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" @@ -107,6 +147,7 @@ package body H2.Scheme is Opcode_And_Finish, Opcode_Or_Finish, + Opcode_Case_Finish, Opcode_Cond_Finish, Opcode_Define_Finish, Opcode_Grouped_Call, -- (begin ...), closure apply, let body @@ -431,6 +472,64 @@ package body H2.Scheme is end case; end Token_To_Pointer; + ----------------------------------------------------------------------------- + -- COMPARISON + ----------------------------------------------------------------------------- + + function Equal_Values (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is + Ptr_Type: Object_Pointer_Type; + begin + + 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 + return Standard.False; + end if; + + when others => + -- TODO: BIGNUM, OTHER NUMERIC DATA. + + case X.Kind is + when Character_Object => + if Y.Kind = X.Kind then + return X.Character_Slot = Y.Character_Slot; + else + return Standard.False; + end if; + + when Byte_Object => + if Y.Kind = X.Kind then + return X.Byte_Slot = Y.Byte_Slot; + else + return Standard.False; + end if; + + when Word_Object => + if Y.Kind = X.Kind then + return X.Word_Slot = Y.Word_Slot; + else + return Standard.False; + end if; + + when Pointer_Object => + return X = Y; + + when Moved_Object => + raise Internal_Error; + end case; + + return X = Y; + end case; + + end Equal_Values; + + ----------------------------------------------------------------------------- -- MEMORY MANAGEMENT ----------------------------------------------------------------------------- @@ -438,7 +537,7 @@ package body H2.Scheme is -- (define x #()) -- (define x $()) -- (define x #( --- (#a . 10) ; a is a synbol +-- (#a . 10) ; a is a symbol -- (b . 20) ; b is a variable. resolve b at the eval-time and use it. -- ("c" . 30) ; "c" is a string -- ) @@ -1812,27 +1911,36 @@ end if; procedure Make_Procedure_Objects is Dummy: Object_Pointer; begin - Dummy := Make_Procedure (Interp.Self, Add_Procedure, Label_Plus); -- "+" + 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, EQ_Procedure, Label_EQ); -- "=" - Dummy := Make_Procedure (Interp.Self, GE_Procedure, Label_GE); -- ">=" - Dummy := Make_Procedure (Interp.Self, GT_Procedure, Label_GT); -- ">" - 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, 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, 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?" + Dummy := Make_Procedure (Interp.Self, Q_Number_Procedure, Label_Q_Number); -- "number?" + 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!" - 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; procedure Make_Common_Symbol_Objects is diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 399147f..d99e585 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -183,32 +183,6 @@ package H2.Scheme is Set_Syntax ); - 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, Cons_Object,