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

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

@ -212,34 +212,42 @@ 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.
while Is_Cons(Param) loop if Is_Symbol(Param) then
if not Is_Cons(Arg) then -- Closure made of a lambda expression with a single formal argument
Ada.Text_IO.Put_Line (">>>> Too few arguments <<<<"); -- e.g) (lambda x (car x))
raise Evaluation_Error; -- Apply the whole actual argument list to the closure.
Print (Interp, Arg);
Put_Environment (Interp, Param, Arg);
else
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
Put_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; end if;
-- Insert the key/value pair into the environment -- Perform cosmetic checks for the argument list
Put_Environment (Interp, Get_Car(Param), Get_Car(Arg)); if Is_Cons(Arg) then
Ada.Text_IO.Put_Line (">>>> TOO MANY ARGUMETNS FOR CLOSURE <<<<");
Param := Get_Cdr(Param); raise Evaluation_Error;
Arg := Get_Cdr(Arg); elsif Arg /= Nil_Pointer then
end loop; Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<");
raise Syntax_Error;
-- Perform cosmetic checks for the parameter list end if;
--if Param /= Nil_Pointer then -- this check handled in reading (lambda ...)
-- 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 (">>>> TOO MANY ARGUMETNS FOR CLOSURE <<<<");
raise Evaluation_Error;
elsif Arg /= Nil_Pointer then
Ada.Text_IO.Put_Line (">>> GARBAGE IN ARGUMENT LIST <<<");
raise Syntax_Error;
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?

36
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,18 +115,32 @@ 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
-- (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;
end if;
-- TODO: Check duplicate symbol names???
end loop;
if Cdr /= Nil_Pointer and then not Is_Symbol(Cdr) then
Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA");
raise Syntax_Error;
end if;
else
Ada.Text_IO.Put_Line ("INVALID FORMALS FOR LAMBDA"); Ada.Text_IO.Put_Line ("INVALID FORMALS FOR LAMBDA");
raise Syntax_Error; raise Syntax_Error;
end if; end if;
Cdr := Get_Last_Cdr(Car);
if Cdr /= Nil_Pointer then
-- (lambda (x y . z) ...)
Ada.Text_IO.Put_Line ("FUCKING CDR IN 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
Ada.Text_IO.Put_Line ("NO BODY"); Ada.Text_IO.Put_Line ("NO BODY");
@ -140,7 +156,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
declare declare
Closure: Object_Pointer; Closure: Object_Pointer;
begin begin
Closure := Make_Closure (Interp.Self, Operand, Interp.Environment); Closure := Make_Closure(Interp.Self, Operand, Interp.Environment);
Pop_Frame (Interp); -- Done Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Closure); Chain_Frame_Result (Interp, Interp.Stack, Closure);
end; end;

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

@ -61,7 +61,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
Push_Frame (Interp, Opcode_Evaluate_Object, Car); Push_Frame (Interp, Opcode_Evaluate_Object, Car);
when Mark_Object => when Mark_Object =>
Operand := Get_Frame_Result (Interp.Stack); Operand := Get_Frame_Result(Interp.Stack);
Pop_Frame (Interp); -- Done Pop_Frame (Interp); -- Done
-- There must be only 1 return value chained in the Group frame. -- There must be only 1 return value chained in the Group frame.
@ -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;

2
lib/h2-scheme-token.adb
View File

@ -31,7 +31,7 @@ package body Token is
Pool.Deallocate (Tmp); Pool.Deallocate (Tmp);
end; end;
Buffer := ( Ptr => null, Len => 0, Last => 0); Buffer := (Ptr => null, Len => 0, Last => 0);
end if; end if;
end Purge_Buffer; end Purge_Buffer;

59
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;
@ -1254,7 +1253,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Name: in Object_Character_Array) return Object_Pointer is Name: in Object_Character_Array) return Object_Pointer is
Result: Object_Pointer; Result: Object_Pointer;
begin begin
Result := Make_Symbol (Interp, Name); Result := Make_Symbol(Interp, Name);
Result.Flags := Result.Flags or Syntax_Object; Result.Flags := Result.Flags or Syntax_Object;
Result.Scode := Opcode; Result.Scode := Opcode;
--Ada.Text_IO.Put ("Creating Syntax Symbol "); --Ada.Text_IO.Put ("Creating Syntax Symbol ");
@ -1279,16 +1278,16 @@ Ada.Text_IO.Put_Line ("Make_String...");
Push_Top (Interp.all, Proc'Unchecked_Access); Push_Top (Interp.all, Proc'Unchecked_Access);
-- Make a symbol for the procedure -- Make a symbol for the procedure
Symbol := Make_Symbol (Interp, Name); Symbol := Make_Symbol(Interp, Name);
-- Make the actual procedure object -- Make the actual procedure object
Proc := Allocate_Pointer_Object (Interp, Procedure_Object_Size, Nil_Pointer); Proc := Allocate_Pointer_Object(Interp, Procedure_Object_Size, Nil_Pointer);
Proc.Tag := Procedure_Object; Proc.Tag := Procedure_Object;
Proc.Pointer_Slot(Procedure_Opcode_Index) := Integer_To_Pointer(Opcode); Proc.Pointer_Slot(Procedure_Opcode_Index) := Integer_To_Pointer(Opcode);
-- Link it to the top environement -- Link it to the top environement
pragma Assert (Interp.Environment = Interp.Root_Environment); pragma Assert (Interp.Environment = Interp.Root_Environment);
pragma Assert (Get_Environment (Interp.Self, Symbol) = null); pragma Assert (Get_Environment(Interp.Self, Symbol) = null);
Put_Environment (Interp.all, Symbol, Proc); Put_Environment (Interp.all, Symbol, Proc);
Pop_Tops (Interp.all, 2); Pop_Tops (Interp.all, 2);
@ -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);

17
lib/h2-scheme.ads
View File

@ -367,28 +367,29 @@ 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);
function Object_Word_To_Pointer is new Ada.Unchecked_Conversion (Object_Word, Object_Pointer); function Object_Word_To_Pointer is new Ada.Unchecked_Conversion (Object_Word, Object_Pointer);
function Object_Pointer_To_Word is new Ada.Unchecked_Conversion (Object_Pointer, Object_Word); function Object_Pointer_To_Word is new Ada.Unchecked_Conversion (Object_Pointer, Object_Word);
Nil_Pointer: constant Object_Pointer := Object_Word_To_Pointer (Nil_Word); Nil_Pointer: constant Object_Pointer := Object_Word_To_Pointer(Nil_Word);
True_Pointer: constant Object_Pointer := Object_Word_To_Pointer (True_Word); True_Pointer: constant Object_Pointer := Object_Word_To_Pointer(True_Word);
False_Pointer: constant Object_Pointer := Object_Word_To_Pointer (False_Word); False_Pointer: constant Object_Pointer := Object_Word_To_Pointer(False_Word);
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------