added some essential procedures
This commit is contained in:
@ -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;
|
||||
|
||||
@ -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!"
|
||||
|
||||
Reference in New Issue
Block a user