implemented 'case'
This commit is contained in:
@ -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 =>
|
||||
|
||||
@ -109,7 +109,7 @@ procedure Evaluate is
|
||||
raise Syntax_Error;
|
||||
end if;
|
||||
|
||||
--Key := Get_Car(Operand);
|
||||
--Key := Get_Car(Operand); -- <key>
|
||||
|
||||
Ptr1 := Get_Cdr(Operand); -- <clause> list.
|
||||
while Is_Cons(Ptr1) loop
|
||||
@ -119,7 +119,7 @@ procedure Evaluate is
|
||||
raise Syntax_Error;
|
||||
end if;
|
||||
|
||||
Ptr3 := Get_Car(Ptr2); -- <datum>
|
||||
Ptr3 := Get_Car(Ptr2); -- <datum> 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 <clause> 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); -- <key>
|
||||
Push_Subframe (Interp, Opcode_Case_Finish, Get_Cdr(Operand)); -- <clause> list
|
||||
end Evaluate_Case_Syntax;
|
||||
|
||||
-- ----------------------------------------------------------------
|
||||
|
||||
@ -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); -- <test> result
|
||||
O := Get_Frame_Operand(Interp.Stack); -- <clause> list
|
||||
|
||||
while Is_Cons(O) loop
|
||||
C := Get_Car(O); -- <clause>
|
||||
D := Get_Car(C); -- <datum> 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 -- <datum>
|
||||
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;
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,
|
||||
|
||||
Reference in New Issue
Block a user