implemented 'case'

This commit is contained in:
2014-02-14 15:47:10 +00:00
parent 21b0dd665f
commit 38ca4baf8f
5 changed files with 250 additions and 102 deletions

View File

@ -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 =>