hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

implemented a few list manipulation procedures

Browse Source
This commit is contained in:
hyung-hwan
2014-01-19 06:40:23 +00:00
parent 55441b4451
commit f970a410fd
9 changed files with 439 additions and 210 deletions
Download Patch File Download Diff File Expand all files Collapse all files

180
lib/h2-scheme-execute.adb
View File

@ -305,184 +305,7 @@ Print (Interp, Operand);
null;
end Evaluate_Procedure;
procedure Apply is
pragma Inline (Apply);
Operand: aliased Object_Pointer;
Func: aliased Object_Pointer;
Args: aliased Object_Pointer;
procedure Apply_Car_Procedure is
begin
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Args));
end Apply_Car_Procedure;
procedure Apply_Cdr_Procedure is
begin
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Get_Cdr(Args));
end Apply_Cdr_Procedure;
procedure Apply_Add_Procedure is
Ptr: Object_Pointer := Args;
Num: Object_Integer := 0; -- TODO: support BIGNUM
Car: Object_Pointer;
begin
while Ptr /= Nil_Pointer loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
raise Evaluation_Error;
end if;
Num := Num + Pointer_To_Integer(Car);
Ptr := Get_Cdr(Ptr);
end loop;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Add_Procedure;
procedure Apply_Subtract_Procedure is
Ptr: Object_Pointer := Args;
Num: Object_Integer := 0; -- TODO: support BIGNUM
Car: Object_Pointer;
begin
if Ptr /= Nil_Pointer then
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
raise Evaluation_Error;
end if;
Num := Pointer_To_Integer(Car);
while Ptr /= Nil_Pointer loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
raise Evaluation_Error;
end if;
Num := Num - Pointer_To_Integer(Car);
Ptr := Get_Cdr(Ptr);
end loop;
end if;
Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
end Apply_Subtract_Procedure;
procedure Apply_Closure is
Fbody: aliased Object_Pointer;
Param: aliased Object_Pointer;
Arg: aliased Object_Pointer;
begin
Push_Top (Interp, Fbody'Unchecked_Access);
Push_Top (Interp, Param'Unchecked_Access);
Push_Top (Interp, Arg'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))"
-- Push a new environmen for the closure
Interp.Environment := Make_Environment (Interp.Self, Get_Closure_Environment(Func));
Fbody := Get_Closure_Code(Func);
pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this.
Param := Get_Car(Fbody); -- Parameter list
--Arg := Get_Car(Args); -- Actual argument list
Arg := Args; -- Actual argument list
Fbody := Get_Cdr (Fbody); -- Real function body
pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this as wel..
while Is_Cons(Param) loop
if not Is_Cons(Arg) then
Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<");
raise Evaluation_Error;
end if;
-- Insert the key/value pair into the environment
Set_Environment (Interp, Get_Car(Param), Get_Car(Arg));
Param := Get_Cdr(Param);
Arg := Get_Cdr(Arg);
end loop;
-- Perform cosmetic checks for the parameter list
if Param /= Nil_Pointer then
Ada.Text_IO.Put_Line (">>> GARBAGE IN PARAMETER LIST <<<");
raise Syntax_Error;
end if;
-- Perform cosmetic checks for the argument list
if Is_Cons(Arg) then
Ada.Text_IO.Put_Line (">>>> Two many arguments <<<<");
raise Evaluation_Error;
elsif Arg /= Nil_Pointer then
Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<");
raise Syntax_Error;
end if;
-- TODO: is it correct to keep the environement in the frame?
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
Set_Frame_Operand (Interp.Stack, Fbody);
Clear_Frame_Result (Interp.Stack);
Pop_Tops (Interp, 3);
end Apply_Closure;
begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Func'Unchecked_Access);
Push_Top (Interp, Args'Unchecked_Access);
Operand := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Cons(Operand));
Print (Interp, Operand);
Func := Get_Car(Operand);
if not Is_Normal_Pointer(Func) then
Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE");
raise Evaluation_Error;
end if;
Args := Get_Cdr(Operand);
case Func.Tag is
when Procedure_Object =>
case Get_Procedure_Opcode(Func) is
when Car_Procedure =>
Apply_Car_Procedure;
when Cdr_Procedure =>
Apply_Cdr_Procedure;
when Add_Procedure =>
Apply_Add_Procedure;
when Subtract_Procedure =>
Apply_Subtract_Procedure;
when others =>
raise Internal_Error;
end case;
when Closure_Object =>
Apply_Closure;
when Continuation_Object =>
null;
when others =>
Ada.Text_IO.Put_Line ("INVALID FUNCTION TYPE");
raise Internal_Error;
end case;
Pop_Tops (Interp, 3);
end Apply;
procedure Apply is separate;
procedure Fetch_Character is
begin
@ -1013,6 +836,7 @@ begin
exception
when Stream_End_Error =>
Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN .............");
raise;
when others =>