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
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
if not Is_Cons(Arg) then
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;
-- Perform cosmetic checks for the parameter list
--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;
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
@ -241,6 +248,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
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?
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);

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

@ -103,7 +103,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
pragma Inline (Evaluate_Lambda_Syntax);
begin
-- (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>
if not Is_Cons(Operand) then
-- e.g) (lambda)
@ -113,17 +115,31 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if;
Car := Get_Car(Operand); -- <formals>
if not Is_Cons(Car) then
Ada.Text_IO.Put_Line ("INVALID FORMALS FOR LAMBDA");
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;
Cdr := Get_Last_Cdr(Car);
if Cdr /= Nil_Pointer then
-- (lambda (x y . z) ...)
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");
raise Syntax_Error;
end if;
Cdr := Get_Cdr(Operand); -- cons cell containing <body>
if not Is_Cons(Cdr) then
@ -140,7 +156,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
declare
Closure: Object_Pointer;
begin
Closure := Make_Closure (Interp.Self, Operand, Interp.Environment);
Closure := Make_Closure(Interp.Self, Operand, Interp.Environment);
Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Closure);
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);
when Mark_Object =>
Operand := Get_Frame_Result (Interp.Stack);
Operand := Get_Frame_Result(Interp.Stack);
Pop_Frame (Interp); -- Done
-- 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;
Y: aliased Object_Pointer;
begin
Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- symbol
Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- value
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);
@ -105,15 +106,15 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
Y: aliased Object_Pointer;
Z: aliased Object_Pointer;
begin
Ada.Text_IO.PUt_Line ("FINISH IF");
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
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 (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);
if Y = False_Pointer then
@ -139,7 +140,6 @@ Ada.Text_IO.PUt_Line ("FINISH IF");
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
begin
Ada.Text_IO.PUt_Line ("FINISH Set");
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
@ -159,7 +159,6 @@ Ada.Text_IO.PUt_Line ("FINISH Set");
Pop_Tops (Interp, 2);
end Finish_Set;
procedure Evaluate is separate;
procedure Apply is separate;
@ -607,6 +606,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
Pop_Frame (Interp);
Chain_Frame_Result (Interp, Interp.Stack, V);
when others =>
Ada.Text_IO.Put_Line ("Right parenthesis expected");
raise Syntax_Error;
end case;

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

@ -31,7 +31,7 @@ package body Token is
Pool.Deallocate (Tmp);
end;
Buffer := ( Ptr => null, Len => 0, Last => 0);
Buffer := (Ptr => null, Len => 0, Last => 0);
end if;
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);
end loop;
return null; -- not found. note that it's not Nil_Pointer.
return null; -- not found.
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;
Key: in Object_Pointer;
Value: in Object_Pointer) is
@ -1213,6 +1195,23 @@ Ada.Text_IO.Put_Line ("Make_String...");
end if;
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;
Key: in Object_Pointer) return Object_Pointer is
Envir: Object_Pointer;
@ -1222,7 +1221,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
while Envir /= Nil_Pointer loop
pragma Assert (Is_Cons(Envir));
Arr := Find_In_Environment_List(Interp, Get_Car(Envir), Key);
if Arr /= Nil_Pointer then
if Arr /= null then
return Arr.Pointer_Slot(2);
end if;
@ -1254,7 +1253,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Name: in Object_Character_Array) return Object_Pointer is
Result: Object_Pointer;
begin
Result := Make_Symbol (Interp, Name);
Result := Make_Symbol(Interp, Name);
Result.Flags := Result.Flags or Syntax_Object;
Result.Scode := Opcode;
--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);
-- Make a symbol for the procedure
Symbol := Make_Symbol (Interp, Name);
Symbol := Make_Symbol(Interp, Name);
-- 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.Pointer_Slot(Procedure_Opcode_Index) := Integer_To_Pointer(Opcode);
-- Link it to the top environement
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);
Pop_Tops (Interp.all, 2);
@ -1669,12 +1668,19 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- TODO: disallow garbage collecion during initialization.
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);
ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz");
Interp.Environment := Interp.Root_Environment;
Make_Syntax_Objects;
print (interp, interp.mark);
ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 00");
Make_Procedure_Objects;
ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 00--00");
Make_Common_Symbol_Objects;
ada.text_io.put_line ("zzzzzzzzzzzzzzzzzz 11");
exception
when others =>
@ -1801,6 +1807,8 @@ Ada.Text_IO.Put_Line ("Make_String...");
when Others =>
if Atom.Kind = Character_Object then
Output_Character_Array (Atom.Character_Slot);
elsif Atom.Tag = Mark_Object then
Ada.Text_IO.Put ("#INTERNAL MARK#");
else
Ada.Text_IO.Put ("#NOIMPL#");
end if;
@ -2007,7 +2015,6 @@ end if;
pragma Assert (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_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 special values are defined under the assumption that actual objects
-- are never allocated on one of these addresses. Addresses of 0, 4, 8 are
-- very low, making the assumption pretty safe.
Nil_Word: constant Object_Word := 2#0000#; -- 0
-- are never allocated on one of these addresses. Addresses of 4, 8, 12 are
-- very low, making the assumption pretty safe. I don't use 0 for Nil_Word
-- as it may conflict with ada's null.
Nil_Word: constant Object_Word := 2#0100#; -- 4
--Nil_Pointer: constant Object_Pointer;
--for Nil_Pointer'Address use Nil_Word'Address;
--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;
--for True_Pointer'Address use True_Word'Address;
--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;
--for False_Pointer'Address use False_Word'Address;
--pragma Import (Ada, False_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);
Nil_Pointer: constant Object_Pointer := Object_Word_To_Pointer (Nil_Word);
True_Pointer: constant Object_Pointer := Object_Word_To_Pointer (True_Word);
False_Pointer: constant Object_Pointer := Object_Word_To_Pointer (False_Word);
Nil_Pointer: constant Object_Pointer := Object_Word_To_Pointer(Nil_Word);
True_Pointer: constant Object_Pointer := Object_Word_To_Pointer(True_Word);
False_Pointer: constant Object_Pointer := Object_Word_To_Pointer(False_Word);
-- -----------------------------------------------------------------------------