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

enhanced lambda processing

Browse Source
This commit is contained in:
hyung-hwan 2014-01-21 05:08:46 +00:00
parent 78436b78f4
commit d7eae56e90
6 changed files with 112 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
lib/h2-scheme-execute-apply.adb
View File

@ -212,8 +212,15 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
Arg := Args; -- Actual argument list Arg := Args; -- Actual argument list
Fbody := Get_Cdr(Fbody); -- Real function body Fbody := Get_Cdr(Fbody); -- Real function body
pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this as wel.. pragma Assert (Is_Cons(Fbody)); -- the lambda evaluator must ensure this.
if Is_Symbol(Param) 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.
Print (Interp, Arg);
Put_Environment (Interp, Param, Arg);
else
while Is_Cons(Param) loop while Is_Cons(Param) loop
if not Is_Cons(Arg) then if not Is_Cons(Arg) then
Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<"); Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<");
@ -228,10 +235,10 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
end loop; end loop;
-- Perform cosmetic checks for the parameter list -- Perform cosmetic checks for the parameter list
--if Param /= Nil_Pointer then -- this check handled in reading (lambda ...) if Param /= Nil_Pointer then
-- Ada.Text_IO.Put_Line (">>> GARBAGE IN PARAMETER LIST <<<"); Ada.Text_IO.Put_Line (">>> GARBAGE IN PARAMETER LIST <<<");
-- raise Syntax_Error; raise Syntax_Error;
--end if; end if;
-- Perform cosmetic checks for the argument list -- Perform cosmetic checks for the argument list
if Is_Cons(Arg) then if Is_Cons(Arg) then
@ -241,6 +248,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<"); Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
end if;
-- TODO: is it correct to keep the environement in the frame? -- TODO: is it correct to keep the environement in the frame?
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);

28
lib/h2-scheme-execute-evaluate.adb
View File

@ -103,7 +103,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
pragma Inline (Evaluate_Lambda_Syntax); pragma Inline (Evaluate_Lambda_Syntax);
begin begin
-- (lambda <formals> <body>) -- (lambda <formals> <body>)
-- (lambda (x y) (+ x y)); -- e.g) (lambda (x y) (+ x y))
-- e.g) (lambda (x y . z) z)
-- e.g) (lambda x (car x))
Operand := Cdr; -- Skip "lambda". cons cell pointing to <formals> Operand := Cdr; -- Skip "lambda". cons cell pointing to <formals>
if not Is_Cons(Operand) then if not Is_Cons(Operand) then
-- e.g) (lambda) -- e.g) (lambda)
@ -113,17 +115,31 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if; end if;
Car := Get_Car(Operand); -- <formals> Car := Get_Car(Operand); -- <formals>
if not Is_Cons(Car) then if Is_Symbol(Car) then
Ada.Text_IO.Put_Line ("INVALID FORMALS FOR LAMBDA"); -- (lambda x ...)
null;
elsif Is_Cons(Car) then
Cdr := Car;
loop
Cdr := Get_Cdr(Cdr);
exit when not Is_Cons(Cdr);
Car := Get_Car(Cdr);
if not Is_Symbol(Car) then
Ada.Text_IO.Put_Line ("WRONG FORMALS FOR LAMBDA");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
-- TODO: Check duplicate symbol names???
end loop;
Cdr := Get_Last_Cdr(Car); if Cdr /= Nil_Pointer and then not Is_Symbol(Cdr) then
if Cdr /= Nil_Pointer then
-- (lambda (x y . z) ...)
Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA"); Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
else
Ada.Text_IO.Put_Line ("INVALID FORMALS FOR LAMBDA");
raise Syntax_Error;
end if;
Cdr := Get_Cdr(Operand); -- cons cell containing <body> Cdr := Get_Cdr(Operand); -- cons cell containing <body>
if not Is_Cons(Cdr) then if not Is_Cons(Cdr) then

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

@ -82,14 +82,15 @@ procedure Execute (Interp: in out Interpreter_Record) is
X: aliased Object_Pointer; X: aliased Object_Pointer;
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
begin begin
Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
Push_Top (Interp, X'Unchecked_Access); Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- symbol X := Get_Frame_Operand(Interp.Stack); -- symbol
Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- value
pragma Assert (Is_Symbol(X)); pragma Assert (Is_Symbol(X));
pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
Y := Get_Frame_Result(Interp.Stack); -- value list
pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure only 1 return value
Y := Get_Car(Y); -- the first value
Put_Environment (Interp, X, Y); Put_Environment (Interp, X, Y);
@ -105,15 +106,15 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
Z: aliased Object_Pointer; Z: aliased Object_Pointer;
begin begin
Ada.Text_IO.PUt_Line ("FINISH IF");
Push_Top (Interp, X'Unchecked_Access); Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- cons cell containing <consequent> X := Get_Frame_Operand(Interp.Stack); -- cons cell containing <consequent>
Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- result of conditional
pragma Assert (Is_Cons(X)); pragma Assert (Is_Cons(X));
pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
Y := Get_Frame_Result(Interp.Stack); -- result list of <test>
pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure only 1 return value
Y := Get_Car(Y); -- the first value
Pop_Frame (Interp); Pop_Frame (Interp);
if Y = False_Pointer then if Y = False_Pointer then
@ -139,7 +140,6 @@ Ada.Text_IO.PUt_Line ("FINISH IF");
X: aliased Object_Pointer; X: aliased Object_Pointer;
Y: aliased Object_Pointer; Y: aliased Object_Pointer;
begin begin
Ada.Text_IO.PUt_Line ("FINISH Set");
Push_Top (Interp, X'Unchecked_Access); Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access);
@ -159,7 +159,6 @@ Ada.Text_IO.PUt_Line ("FINISH Set");
Pop_Tops (Interp, 2); Pop_Tops (Interp, 2);
end Finish_Set; end Finish_Set;
procedure Evaluate is separate; procedure Evaluate is separate;
procedure Apply is separate; procedure Apply is separate;
@ -607,6 +606,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
Pop_Frame (Interp); Pop_Frame (Interp);
Chain_Frame_Result (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when others => when others =>
Ada.Text_IO.Put_Line ("Right parenthesis expected");
raise Syntax_Error; raise Syntax_Error;
end case; end case;

51
lib/h2-scheme.adb
View File

@ -1159,27 +1159,9 @@ Ada.Text_IO.Put_Line ("Make_String...");
Arr := Arr.Pointer_Slot(3); Arr := Arr.Pointer_Slot(3);
end loop; end loop;
return null; -- not found.
return null; -- not found. note that it's not Nil_Pointer.
end Find_In_Environment_List; end Find_In_Environment_List;
function Set_Environment (Interp: access Interpreter_Record;
Key: in Object_Pointer;
Value: in Object_Pointer) return Object_Pointer is
Arr: Object_Pointer;
begin
pragma Assert (Is_Symbol(Key));
Arr := Find_In_Environment_List(Interp, Get_Car(Interp.Environment), Key);
if Arr = null then
return null;
else
-- overwrite an existing pair
Arr.Pointer_Slot(2) := Value;
return Value;
end if;
end Set_Environment;
procedure Put_Environment (Interp: in out Interpreter_Record; procedure Put_Environment (Interp: in out Interpreter_Record;
Key: in Object_Pointer; Key: in Object_Pointer;
Value: in Object_Pointer) is Value: in Object_Pointer) is
@ -1213,6 +1195,23 @@ Ada.Text_IO.Put_Line ("Make_String...");
end if; end if;
end Put_Environment; end Put_Environment;
function Set_Environment (Interp: access Interpreter_Record;
Key: in Object_Pointer;
Value: in Object_Pointer) return Object_Pointer is
Arr: Object_Pointer;
begin
pragma Assert (Is_Symbol(Key));
Arr := Find_In_Environment_List(Interp, Get_Car(Interp.Environment), Key);
if Arr = null then
return null;
else
-- overwrite an existing pair
Arr.Pointer_Slot(2) := Value;
return Value;
end if;
end Set_Environment;
function Get_Environment (Interp: access Interpreter_Record; function Get_Environment (Interp: access Interpreter_Record;
Key: in Object_Pointer) return Object_Pointer is Key: in Object_Pointer) return Object_Pointer is
Envir: Object_Pointer; Envir: Object_Pointer;
@ -1222,7 +1221,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
while Envir /= Nil_Pointer loop while Envir /= Nil_Pointer loop
pragma Assert (Is_Cons(Envir)); pragma Assert (Is_Cons(Envir));
Arr := Find_In_Environment_List(Interp, Get_Car(Envir), Key); Arr := Find_In_Environment_List(Interp, Get_Car(Envir), Key);
if Arr /= Nil_Pointer then if Arr /= null then
return Arr.Pointer_Slot(2); return Arr.Pointer_Slot(2);
end if; end if;
@ -1669,12 +1668,19 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- TODO: disallow garbage collecion during initialization. -- TODO: disallow garbage collecion during initialization.
Initialize_Heap (Initial_Heap_Size); Initialize_Heap (Initial_Heap_Size);
Interp.Mark := Make_Mark(Interp.Self, 0); -- to indicate the end of cons evluation ada.text_io.put_line ("kkkkkkkkkkkkkk");
Interp.Mark := Make_Mark(Interp.Self, 0); -- to indicate the end of cons evaluation
ada.text_io.put_line ("xxxxxxxxxxxxxx");
Interp.Root_Environment := Make_Environment(Interp.Self, Nil_Pointer); Interp.Root_Environment := Make_Environment(Interp.Self, Nil_Pointer);
ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz");
Interp.Environment := Interp.Root_Environment; Interp.Environment := Interp.Root_Environment;
Make_Syntax_Objects; Make_Syntax_Objects;
print (interp, interp.mark);
ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 00");
Make_Procedure_Objects; Make_Procedure_Objects;
ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 00--00");
Make_Common_Symbol_Objects; Make_Common_Symbol_Objects;
ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 11");
exception exception
when others => when others =>
@ -1801,6 +1807,8 @@ Ada.Text_IO.Put_Line ("Make_String...");
when Others => when Others =>
if Atom.Kind = Character_Object then if Atom.Kind = Character_Object then
Output_Character_Array (Atom.Character_Slot); Output_Character_Array (Atom.Character_Slot);
elsif Atom.Tag = Mark_Object then
Ada.Text_IO.Put ("#INTERNAL MARK#");
else else
Ada.Text_IO.Put ("#NOIMPL#"); Ada.Text_IO.Put ("#NOIMPL#");
end if; end if;
@ -2007,7 +2015,6 @@ end if;
pragma Assert (Interp.Stack = Nil_Pointer); pragma Assert (Interp.Stack = Nil_Pointer);
Interp.Stack := Nil_Pointer; Interp.Stack := Nil_Pointer;
Print_Object_Pointer ("STACK IN EVALUTE => ", Interp.Stack);
-- Push a pseudo-frame to terminate the evaluation loop -- Push a pseudo-frame to terminate the evaluation loop
Push_Frame (Interp, Opcode_Exit, Nil_Pointer); Push_Frame (Interp, Opcode_Exit, Nil_Pointer);

11
lib/h2-scheme.ads
View File

@ -367,19 +367,20 @@ package H2.Scheme is
-- The nil/true/false object are represented by special pointer values. -- The nil/true/false object are represented by special pointer values.
-- The special values are defined under the assumption that actual objects -- The special values are defined under the assumption that actual objects
-- are never allocated on one of these addresses. Addresses of 0, 4, 8 are -- are never allocated on one of these addresses. Addresses of 4, 8, 12 are
-- very low, making the assumption pretty safe. -- very low, making the assumption pretty safe. I don't use 0 for Nil_Word
Nil_Word: constant Object_Word := 2#0000#; -- 0 -- as it may conflict with ada's null.
Nil_Word: constant Object_Word := 2#0100#; -- 4
--Nil_Pointer: constant Object_Pointer; --Nil_Pointer: constant Object_Pointer;
--for Nil_Pointer'Address use Nil_Word'Address; --for Nil_Pointer'Address use Nil_Word'Address;
--pragma Import (Ada, Nil_Pointer); --pragma Import (Ada, Nil_Pointer);
True_Word: constant Object_Word := 2#0100#; -- 4 True_Word: constant Object_Word := 2#1000#; -- 8
--True_Pointer: constant Object_Pointer; --True_Pointer: constant Object_Pointer;
--for True_Pointer'Address use True_Word'Address; --for True_Pointer'Address use True_Word'Address;
--pragma Import (Ada, True_Pointer); --pragma Import (Ada, True_Pointer);
False_Word: constant Object_Word := 2#1000#; -- 8 False_Word: constant Object_Word := 2#1100#; -- 12
--False_Pointer: constant Object_Pointer; --False_Pointer: constant Object_Pointer;
--for False_Pointer'Address use False_Word'Address; --for False_Pointer'Address use False_Word'Address;
--pragma Import (Ada, False_Pointer); --pragma Import (Ada, False_Pointer);