805 lines
24 KiB
Ada
805 lines
24 KiB
Ada
|
|
separate (H2.Scheme.Execute)
|
|
|
|
procedure Apply is
|
|
--pragma Inline (Apply);
|
|
|
|
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
|
|
-- (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
|
|
-- (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_Eq_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 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;
|
|
begin
|
|
if not Is_Cons(Ptr) or else Get_Cdr(Ptr) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CAR");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
A := Get_Car(Ptr); -- the first argument
|
|
if not Is_Cons(A) then
|
|
Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CAR");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
|
|
Return_Frame (Interp, Get_Car(A));
|
|
end Apply_Car_Procedure;
|
|
|
|
procedure Apply_Cdr_Procedure is
|
|
Ptr: Object_Pointer := Args;
|
|
A: Object_Pointer;
|
|
begin
|
|
if not Is_Cons(Ptr) or else Get_Cdr(Ptr) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CDR");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
A := Get_Car(Ptr); -- the first argument
|
|
if not Is_Cons(A) then
|
|
Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR CDR");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
|
|
Return_Frame (Interp, Get_Cdr(A));
|
|
end Apply_Cdr_Procedure;
|
|
|
|
procedure Apply_Cons_Procedure is
|
|
Ptr: Object_Pointer := Args;
|
|
A: Object_Pointer;
|
|
B: Object_Pointer;
|
|
begin
|
|
if not Is_Cons(Ptr) or else not Is_Cons(Get_Cdr(Ptr)) or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CONS");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
A := Get_Car(Ptr); -- the first argument
|
|
B := Get_Car(Get_Cdr(Ptr)); -- the second argument
|
|
Ptr := Make_Cons (Interp.Self, A, B); -- change car
|
|
|
|
Return_Frame (Interp, Ptr);
|
|
end Apply_Cons_Procedure;
|
|
|
|
procedure Apply_Setcar_Procedure is
|
|
Ptr: Object_Pointer := Args;
|
|
A: Object_Pointer;
|
|
B: Object_Pointer;
|
|
begin
|
|
if not Is_Cons(Ptr) or else not Is_Cons(Get_Cdr(Ptr)) or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR SET-CAR!");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
A := Get_Car(Ptr); -- the first argument
|
|
if not Is_Cons(A) then
|
|
Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcar");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
B := Get_Car(Get_Cdr(Ptr)); -- the second argument
|
|
Set_Car (A, B); -- change car
|
|
|
|
Return_Frame (Interp, A);
|
|
end Apply_Setcar_Procedure;
|
|
|
|
procedure Apply_Setcdr_Procedure is
|
|
Ptr: Object_Pointer := Args;
|
|
A: Object_Pointer;
|
|
B: Object_Pointer;
|
|
begin
|
|
if not Is_Cons(Ptr) or else not Is_Cons(Get_Cdr(Ptr)) or else Get_Cdr(Get_Cdr(Ptr)) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR SET-CDR!");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
A := Get_Car(Ptr); -- the first argument
|
|
if not Is_Cons(A) then
|
|
Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcdr");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
B := Get_Car(Get_Cdr(Ptr)); -- the second argument
|
|
Set_Cdr (A, B); -- change cdr
|
|
|
|
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
|
|
-- -------------------------------------------------------------
|
|
|
|
function Is_Numeric (X: in Object_Pointer) return Standard.Boolean is
|
|
pragma Inline (Is_Numeric);
|
|
begin
|
|
return Is_Integer(X) or else Is_Bigint(X);
|
|
end Is_Numeric;
|
|
|
|
procedure Apply_Add_Procedure is
|
|
Ptr: aliased Object_Pointer := Args;
|
|
Num: Object_Pointer;
|
|
Car: Object_Pointer;
|
|
begin
|
|
Push_Top (Interp, Ptr'Unchecked_Access);
|
|
|
|
Num := Integer_To_Pointer(0);
|
|
while Is_Cons(Ptr) loop
|
|
Car := Get_Car(Ptr);
|
|
Ptr := Get_Cdr(Ptr);
|
|
|
|
if not Is_Numeric(Car) then
|
|
Ada.Text_IO.Put ("NOT NUMERIC FOR ADD"); Print (Interp, Car);
|
|
raise Evaluation_Error;
|
|
end if;
|
|
Bigint.Add (Interp, Num, Car, Num);
|
|
end loop;
|
|
|
|
Pop_Tops (Interp, 1);
|
|
Return_Frame (Interp, Num);
|
|
end Apply_Add_Procedure;
|
|
|
|
procedure Apply_Subtract_Procedure is
|
|
Ptr: aliased Object_Pointer := Args;
|
|
Num: Object_Pointer;
|
|
Car: Object_Pointer;
|
|
begin
|
|
if Is_Cons(Ptr) then
|
|
Push_Top (Interp, Ptr'Unchecked_Access);
|
|
|
|
Car := Get_Car(Ptr);
|
|
Ptr := Get_Cdr(Ptr);
|
|
if not Is_Numeric(Car) then
|
|
raise Evaluation_Error;
|
|
end if;
|
|
Num := Car;
|
|
|
|
while Is_Cons(Ptr) loop
|
|
Car := Get_Car(Ptr);
|
|
Ptr := Get_Cdr(Ptr);
|
|
if not Is_Numeric(Car) then
|
|
raise Evaluation_Error;
|
|
end if;
|
|
Bigint.Subtract (Interp, Num, Car, Num);
|
|
end loop;
|
|
|
|
Pop_Tops (Interp, 1);
|
|
else
|
|
Ada.Text_IO.Put_line ("NO ARGUMETNS FOR SUBNTRATION");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
|
|
Return_Frame (Interp, Num);
|
|
end Apply_Subtract_Procedure;
|
|
|
|
procedure Apply_Multiply_Procedure is
|
|
Ptr: aliased Object_Pointer := Args;
|
|
Num: Object_Pointer;
|
|
Car: Object_Pointer;
|
|
begin
|
|
Push_Top (Interp, Ptr'Unchecked_Access);
|
|
|
|
Num := Integer_To_Pointer(1);
|
|
while Is_Cons(Ptr) loop
|
|
Car := Get_Car(Ptr);
|
|
Ptr := Get_Cdr(Ptr);
|
|
if not Is_Numeric(Car) then
|
|
Ada.Text_IO.Put ("NOT NUMERIC FOR MULTIPLY"); Print (Interp, Car);
|
|
raise Evaluation_Error;
|
|
end if;
|
|
Bigint.Multiply (Interp, Num, Car, Num);
|
|
end loop;
|
|
|
|
Pop_Tops (Interp, 1);
|
|
Return_Frame (Interp, Num);
|
|
end Apply_Multiply_Procedure;
|
|
|
|
procedure Apply_Quotient_Procedure is
|
|
Ptr: aliased Object_Pointer := Args;
|
|
Num: Object_Pointer;
|
|
Car: Object_Pointer;
|
|
Rmn: Object_Pointer;
|
|
begin
|
|
if Is_Cons(Ptr) then
|
|
Push_Top (Interp, Ptr'Unchecked_Access);
|
|
|
|
Car := Get_Car(Ptr);
|
|
Ptr := Get_Cdr(Ptr);
|
|
if not Is_Numeric(Car) then
|
|
raise Evaluation_Error;
|
|
end if;
|
|
Num := Car;
|
|
|
|
while Is_Cons(Ptr) loop
|
|
-- TODO: check if car is an integer or bignum or something else.
|
|
-- if something else, error
|
|
Car := Get_Car(Ptr);
|
|
Ptr := Get_Cdr(Ptr);
|
|
if not Is_Numeric(Car) then
|
|
Ada.Text_IO.Put ("NOT INTEGER FOR QUOTIENT"); Print (Interp, Car);
|
|
raise Evaluation_Error;
|
|
end if;
|
|
Bigint.Divide (Interp, Num, Car, Num, Rmn);
|
|
end loop;
|
|
|
|
Pop_Tops (Interp, 1);
|
|
else
|
|
Ada.Text_IO.Put_line ("NO ARGUMETNS FOR QUOTIENT");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
|
|
Return_Frame (Interp, Num);
|
|
end Apply_Quotient_Procedure;
|
|
|
|
procedure Apply_Remainder_Procedure is
|
|
Ptr: aliased Object_Pointer := Args;
|
|
Num: Object_Pointer;
|
|
Car: Object_Pointer;
|
|
Quo: Object_Pointer;
|
|
begin
|
|
if Is_Cons(Ptr) then
|
|
Push_Top (Interp, Ptr'Unchecked_Access);
|
|
|
|
Car := Get_Car(Ptr);
|
|
Ptr := Get_Cdr(Ptr);
|
|
if not Is_Numeric(Car) then
|
|
raise Evaluation_Error;
|
|
end if;
|
|
Num := Car;
|
|
|
|
while Is_Cons(Ptr) loop
|
|
-- TODO: check if car is an integer or bignum or something else.
|
|
-- if something else, error
|
|
Car := Get_Car(Ptr);
|
|
Ptr := Get_Cdr(Ptr);
|
|
if not Is_Numeric(Car) then
|
|
Ada.Text_IO.Put ("NOT INTEGER FOR QUOTIENT"); Print (Interp, Car);
|
|
raise Evaluation_Error;
|
|
end if;
|
|
Bigint.Divide (Interp, Num, Car, Quo, Num);
|
|
end loop;
|
|
|
|
Pop_Tops (Interp, 1);
|
|
else
|
|
Ada.Text_IO.Put_line ("NO ARGUMETNS FOR QUOTIENT");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
|
|
Return_Frame (Interp, Num);
|
|
end Apply_Remainder_Procedure;
|
|
|
|
-- -------------------------------------------------------------
|
|
-- Comparions procedures
|
|
-- -------------------------------------------------------------
|
|
|
|
generic
|
|
with function Validate (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean;
|
|
|
|
with function Compare (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean;
|
|
procedure Apply_Compare_Procedure;
|
|
|
|
procedure Apply_Compare_Procedure is
|
|
Ptr: Object_Pointer := Args;
|
|
X: Object_Pointer;
|
|
Y: Object_Pointer;
|
|
Bool: Object_Pointer := True_Pointer;
|
|
begin
|
|
if Is_Cons(Ptr) and then Is_Cons(Get_Cdr(Ptr)) then
|
|
-- at least 2 actual arguments
|
|
X := Get_Car(Ptr);
|
|
|
|
Ptr := Get_Cdr(Ptr);
|
|
while Is_Cons(Ptr) loop
|
|
Y := Get_Car(Ptr);
|
|
|
|
if not Validate(X, Y) then
|
|
ADA.TEXT_IO.PUT_LINE ("INVALID TYPE FOR COMPARISION");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
|
|
if not Compare(X, Y) then
|
|
Bool := False_Pointer;
|
|
exit;
|
|
end if;
|
|
|
|
X := Y;
|
|
Ptr := Get_Cdr(Ptr);
|
|
end loop;
|
|
|
|
Return_Frame (Interp, Bool);
|
|
else
|
|
Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
|
|
raise Syntax_Error;
|
|
end if;
|
|
end Apply_Compare_Procedure;
|
|
|
|
function Validate_Numeric (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
begin
|
|
return Is_Numeric(X) and then Is_Numeric(Y);
|
|
end Validate_Numeric;
|
|
|
|
function Equal_To (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
begin
|
|
return Bigint.Compare (Interp.Self, X, Y) = 0;
|
|
end Equal_To;
|
|
|
|
function Greater_Than (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
begin
|
|
return Bigint.Compare (Interp.Self, X, Y) > 0;
|
|
end Greater_Than;
|
|
|
|
function Less_Than (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
begin
|
|
return Bigint.Compare (Interp.Self, X, Y) < 0;
|
|
end Less_Than;
|
|
|
|
function Greater_Or_Equal (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
begin
|
|
return Bigint.Compare (Interp.Self, X, Y) >= 0;
|
|
end Greater_Or_Equal;
|
|
|
|
function Less_Or_Equal (X: in Object_Pointer;
|
|
Y: in Object_Pointer) return Standard.Boolean is
|
|
begin
|
|
return Bigint.Compare (Interp.Self, X, Y) <= 0;
|
|
end 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);
|
|
|
|
-- -------------------------------------------------------------
|
|
-- Closure
|
|
-- -------------------------------------------------------------
|
|
procedure Apply_Closure is
|
|
Fbody: aliased Object_Pointer;
|
|
Formal: aliased Object_Pointer;
|
|
Actual: aliased Object_Pointer;
|
|
Envir: aliased Object_Pointer;
|
|
begin
|
|
Push_Top (Interp, Fbody'Unchecked_Access);
|
|
Push_Top (Interp, Formal'Unchecked_Access);
|
|
Push_Top (Interp, Actual'Unchecked_Access);
|
|
Push_Top (Interp, Envir'Unchecked_Access);
|
|
|
|
-- For a closure created of "(lambda (x y) (+ x y) (* x y))"
|
|
-- Get_Closure_Code(Func) returns "((x y) (+ x y) (* x y))"
|
|
|
|
-- Create a new environment for the closure
|
|
Envir := Make_Environment(Interp.Self, Get_Closure_Environment(Func));
|
|
-- Update the environment of the frame to the one created above
|
|
-- so as to put the arguments into the new environment.
|
|
Set_Frame_Environment (Interp.Stack, Envir);
|
|
|
|
Fbody := Get_Closure_Code(Func);
|
|
pragma Assert (Is_Cons(Fbody)); -- the lambda evaluator must ensure this.
|
|
|
|
Formal := Get_Car(Fbody); -- Formal argument list
|
|
Actual := Args; -- Actual argument list
|
|
|
|
Fbody := Get_Cdr(Fbody); -- Real function body
|
|
pragma Assert (Is_Cons(Fbody)); -- the lambda evaluator must ensure this.
|
|
|
|
if Is_Symbol(Formal) then
|
|
-- Closure made of a lambda expression with a single formal argument
|
|
-- e.g) (lambda x (car x))
|
|
-- Apply the whole actual argument list to the closure.
|
|
Set_Current_Environment (Interp, Formal, Actual);
|
|
else
|
|
while Is_Cons(Formal) loop
|
|
if not Is_Cons(Actual) then
|
|
Ada.Text_IO.Put_Line (">>>> TOO FEW ARGUMENTS FOR CLOSURE <<<<");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
|
|
-- Insert the key/value pair into the environment
|
|
Set_Current_Environment (Interp, Get_Car(Formal), Get_Car(Actual));
|
|
|
|
Formal := Get_Cdr(Formal);
|
|
Actual := Get_Cdr(Actual);
|
|
end loop;
|
|
|
|
-- Perform cosmetic checks for the parameter list
|
|
if Is_Symbol(Formal) then
|
|
-- The last formal argument to the closure is in a CDR.
|
|
-- Assign the remaining actual arguments to the last formal argument
|
|
-- e.g) ((lambda (x y . z) z) 1 2 3 4 5)
|
|
Set_Current_Environment (Interp, Formal, Actual);
|
|
else
|
|
-- The lambda evaluator must ensure all formal arguments are symbols.
|
|
pragma Assert (Formal = Nil_Pointer);
|
|
|
|
if Actual /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line (">>>> TOO MANY ARGUMETNS FOR CLOSURE <<<<");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Fbody, Nil_Pointer);
|
|
|
|
Pop_Tops (Interp, 4);
|
|
end Apply_Closure;
|
|
|
|
-- -------------------------------------------------------------
|
|
-- Continuation
|
|
-- -------------------------------------------------------------
|
|
|
|
function Is_Callcc_Friendly (A: Object_Pointer) return Standard.Boolean is
|
|
pragma Inline (Is_Callcc_Friendly);
|
|
begin
|
|
return Is_Closure(A) or else Is_Procedure(A) or else Is_Continuation(A);
|
|
end Is_Callcc_Friendly;
|
|
|
|
procedure Apply_Callcc_Procedure is
|
|
C: aliased Object_Pointer;
|
|
begin
|
|
-- (call-with-current-continuation proc)
|
|
-- where proc is a procedure accepting one argument.
|
|
--
|
|
-- (define f (lambda (return) (return 2) 3))
|
|
-- (f (lambda (x) x)) ; 3
|
|
-- (call-with-current-continuation f) ; 2
|
|
--
|
|
-- (call-with-current-continuation (lambda (return) (return 2) 3))
|
|
--
|
|
-- (define c (call-with-current-continuation call-with-current-continuation))
|
|
-- c ; continuation
|
|
-- (c (+ 1 2 3)) ; 6 becomes the result of the frame that continuation remembers.
|
|
-- ; subsequently, its parent frames are executed.
|
|
-- c ; 6
|
|
|
|
if not Is_Cons(Args) or else Get_Cdr(Args) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CALL/CC");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
if not Is_Callcc_Friendly(Get_Car(Args)) then
|
|
ada.text_io.put_line ("NON CLOSURE/PROCEDURE/CONTINUATION FOR CALL/CC");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
Push_Top (Interp, C'Unchecked_Access); -- this is not needed. TOOD: remove this
|
|
C := Make_Continuation (Interp.Self, Get_Frame_Parent(Interp.Stack));
|
|
|
|
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
|
|
Set_Frame_Operand (Interp.Stack, Get_Car(Args)); -- (call/cc xxx), xxx becomes this.
|
|
Set_Frame_Intermediate (Interp.Stack, Nil_Pointer); -- pass the continuation object
|
|
Chain_Frame_Intermediate (Interp, Interp.Stack, C); -- as an actual parameter. (xxx #continuation)
|
|
Clear_Frame_Result (Interp.Stack);
|
|
|
|
Pop_Tops (Interp, 1);
|
|
end Apply_Callcc_Procedure;
|
|
|
|
procedure Apply_Continuation is
|
|
begin
|
|
--declare
|
|
--w: object_word;
|
|
--for w'address use func'address;
|
|
--f: object_word;
|
|
--for f'address use interp.stack'address;
|
|
--begin
|
|
--ada.text_io.put_line ("Frame" & object_word'image(f) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
|
|
--ada.text_io.put (" POPPING ... APPLY CONTINUATION -->> ");
|
|
--ada.text_io.put (object_word'image(w) & " ");
|
|
--end;
|
|
--Print (Interp, Args);
|
|
--ada.text_io.put (" CURRENT FREME RESULT " );
|
|
--Print (Interp, get_Frame_result(interp.stack));
|
|
if not Is_Cons(Args) or else Get_Cdr(Args) /= Nil_Pointer then
|
|
Ada.Text_IO.Put_Line ("WRONG NUMBER OF ARGUMETNS FOR CONTINUATION");
|
|
raise Syntax_Error;
|
|
end if;
|
|
|
|
-- Restore the frame to the remembered one
|
|
Interp.Stack := Get_Continuation_Frame(Func);
|
|
|
|
--declare
|
|
--f: object_word;
|
|
--for f'address use interp.stack'address;
|
|
--begin
|
|
--ada.text_io.put_line (" SWITCHED STACK TO FREME " & object_word'image(f) );
|
|
--ada.text_io.put (" CURRENT RESULT " );
|
|
--print (interp, get_Frame_result(interp.stack));
|
|
--ada.text_io.put (" CURRENT OPERAND " );
|
|
--print (interp, get_Frame_operand(interp.stack));
|
|
--ada.text_io.put (" CURRENT INTERMEDIATE " );
|
|
--print (interp, get_Frame_intermediate(interp.stack));
|
|
--ada.text_io.put_line (" CURRENT OPCODE " & opcode_type'image(get_Frame_opcode(interp.stack)));
|
|
--end;
|
|
|
|
Set_Frame_Result (Interp.Stack, Get_Car(Args));
|
|
|
|
--ada.text_io.put (" FINAL RESULT ");
|
|
--print (interp, get_Frame_result(interp.stack));
|
|
|
|
end Apply_Continuation;
|
|
|
|
begin
|
|
Push_Top (Interp, Func'Unchecked_Access);
|
|
Push_Top (Interp, Args'Unchecked_Access);
|
|
|
|
Func := Get_Frame_Operand(Interp.Stack);
|
|
if not Is_Normal_Pointer(Func) then
|
|
Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE");
|
|
raise Evaluation_Error;
|
|
end if;
|
|
|
|
Args := Get_Frame_Intermediate(Interp.Stack);
|
|
|
|
--declare
|
|
--w: object_word;
|
|
--for w'address use interp.stack'address;
|
|
--begin
|
|
--ada.text_io.put_line ("Frame" & object_word'image(w) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
|
|
--ada.text_io.put (" FUNCTION => ");
|
|
--print (Interp, Func);
|
|
--ada.text_io.put (" ARGUMENTS => ");
|
|
--print (Interp, Args);
|
|
--ada.text_io.put (" CURRENT RESULT => ");
|
|
--print (Interp, get_frame_result(interp.stack));
|
|
--end;
|
|
|
|
|
|
case Func.Tag is
|
|
when Procedure_Object =>
|
|
case Get_Procedure_Opcode(Func) is
|
|
|
|
when Callcc_Procedure =>
|
|
Apply_Callcc_Procedure;
|
|
when Car_Procedure =>
|
|
Apply_Car_Procedure;
|
|
when Cdr_Procedure =>
|
|
Apply_Cdr_Procedure;
|
|
when Cons_Procedure =>
|
|
Apply_Cons_Procedure;
|
|
when Not_Procedure =>
|
|
Apply_Not_Procedure;
|
|
|
|
when N_Add_Procedure =>
|
|
Apply_Add_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 N_Multiply_Procedure =>
|
|
Apply_Multiply_Procedure;
|
|
when N_Quotient_Procedure =>
|
|
Apply_Quotient_Procedure;
|
|
when N_Remainder_Procedure =>
|
|
Apply_Remainder_Procedure;
|
|
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 =>
|
|
Apply_Q_Eqv_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;
|
|
when Setcdr_Procedure =>
|
|
Apply_Setcdr_Procedure;
|
|
|
|
end case;
|
|
|
|
when Closure_Object =>
|
|
Apply_Closure;
|
|
|
|
when Continuation_Object =>
|
|
Apply_Continuation;
|
|
|
|
when others =>
|
|
Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE");
|
|
raise Internal_Error;
|
|
|
|
end case;
|
|
|
|
Pop_Tops (Interp, 2);
|
|
end Apply;
|