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

implemented set!

Browse Source
This commit is contained in:
hyung-hwan 2014-01-20 15:47:08 +00:00
parent af588f1430
commit 78436b78f4
4 changed files with 149 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -208,36 +208,34 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
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
Param := Get_Car(Fbody); -- Formal 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..
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));
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;
--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 (">>>> Two many arguments <<<<");
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 <<<");

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

@ -17,6 +17,7 @@ procedure Evaluate is
if not Is_Cons(Operand) or else not Is_Cons(Get_Cdr(Operand)) then
-- e.g) (define)
-- (define . 10)
-- (define x . 10)
Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR DEFINE");
raise Syntax_Error;
end if;
@ -52,7 +53,7 @@ procedure Evaluate is
begin
-- (if <test> <consequent>)
-- (if <test> <consequent> <alternate>)
-- (if (> 3 2) 'yes)
-- e.g) (if (> 3 2) 'yes)
-- (if (> 3 2) 'yes 'no)
-- (if (> 3 2) (- 3 2) (+ 3 2))
Operand := Cdr; -- Skip "if"
@ -101,8 +102,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
procedure Evaluate_Lambda_Syntax is
pragma Inline (Evaluate_Lambda_Syntax);
begin
-- (lambda <formals> <body>)
-- (lambda (x y) (+ x y));
Operand := Cdr; -- Skip "lambda"
Operand := Cdr; -- Skip "lambda". cons cell pointing to <formals>
if not Is_Cons(Operand) then
-- e.g) (lambda)
-- (lambda . 10)
@ -110,17 +112,31 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error;
end if;
if not Is_Cons(Get_Car(Operand)) then
Ada.Text_IO.Put_Line ("INVALID PARRAMETER LIST");
Car := Get_Car(Operand); -- <formals>
if not Is_Cons(Car) then
Ada.Text_IO.Put_Line ("INVALID FORMALS FOR LAMBDA");
raise Syntax_Error;
end if;
--Print (Interp, Get_Cdr(Operand));
if not Is_Cons(Get_Cdr(Operand)) then
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>
if not Is_Cons(Cdr) then
Ada.Text_IO.Put_Line ("NO BODY");
raise Syntax_Error;
end if;
if Get_Last_Cdr(Cdr) /= Nil_Pointer then
-- (lambda (x y) (+ x y) . 99)
Ada.Text_IO.Put_Line ("FUCKING CDR IN BODY FOR LAMBDA");
raise Syntax_Error;
end if;
declare
Closure: Object_Pointer;
begin
@ -147,6 +163,43 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
Chain_Frame_Result (Interp, Interp.Stack, Get_Car(Operand));
end Evaluate_Quote_Syntax;
procedure Evaluate_Set_Syntax is
pragma Inline (Evaluate_Set_Syntax);
begin
-- (set! <variable> <expression>)
-- e.g) (set! x 10)
Operand := Cdr; -- Skip "set!"
if not Is_Cons(Operand) or else not Is_Cons(Get_Cdr(Operand)) then
-- e.g) (set!)
-- (set . 10)
-- (set x . 10)
Ada.Text_IO.Put_LINE ("TOO FEW ARGUMENTS FOR SET");
raise Syntax_Error;
end if;
Car := Get_Car(Operand); -- <variable>
Cdr := Get_Cdr(Operand); -- cons cell to <expression>
if Is_Symbol(Car) then
if Get_Cdr(Cdr) /= Nil_Pointer then
Ada.Text_IO.Put_LINE ("TOO MANY ARGUMENTS FOR set!");
raise Syntax_Error;
end if;
Cdr := Get_Car(Cdr); -- <expression>
-- Arrange to finish setting a variable after <expression> evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Set);
Set_Frame_Operand (Interp.Stack, Car);
-- Arrange to evalaute the value part
Push_Frame (Interp, Opcode_Evaluate_Object, Cdr);
else
Ada.Text_IO.Put_LINE ("INVALID SYMBOL AFTER SET!");
raise Syntax_Error;
end if;
end Evaluate_Set_Syntax;
begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Car'Unchecked_Access);
@ -220,6 +273,9 @@ begin
when Quote_Syntax =>
Evaluate_Quote_Syntax;
when Set_Syntax => -- set!
Evaluate_Set_Syntax;
when others =>
Ada.Text_IO.Put_Line ("Unknown syntax");
--Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax); -- Switch to syntax evaluation
@ -242,6 +298,12 @@ begin
Cdr := Get_Cdr(Operand);
else
-- last cons
if Cdr /= Nil_Pointer then
-- The last CDR is not Nil.
Ada.Text_IO.Put_Line ("WARNING: $$$$$$$$$$$$$$$$$$$$$..FUCKING CDR.....................OPTIMIZATIN $$$$");
raise Syntax_Error;
end if;
Operand := Reverse_Cons(Get_Frame_Result(Interp.Stack));
Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);

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

@ -91,7 +91,7 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
pragma Assert (Is_Symbol(X));
pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
Set_Environment (Interp, X, Y);
Put_Environment (Interp, X, Y);
Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Y);
@ -134,6 +134,32 @@ Ada.Text_IO.PUt_Line ("FINISH IF");
Pop_Tops (Interp, 2);
end Finish_If;
procedure Finish_Set is
pragma Inline (Finish_Set);
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);
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);
if Set_Environment(Interp.Self, X, Y) = null then
Ada.Text_IO.PUt_LINE ("ERROR: UNBOUND SYMBOL");
raise Evaluation_Error;
end if;
Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Y);
Pop_Tops (Interp, 2);
end Finish_Set;
procedure Evaluate is separate;
procedure Apply is separate;
@ -762,6 +788,9 @@ begin
when Opcode_Finish_If =>
Finish_If;
when Opcode_Finish_Set =>
Finish_Set;
when Opcode_Apply =>
Apply;

52
lib/h2-scheme.adb
View File

@ -80,20 +80,21 @@ package body H2.Scheme is
subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
subtype Opcode_Type is Object_Integer range 0 .. 12;
subtype Opcode_Type is Object_Integer range 0 .. 13;
Opcode_Exit: constant Opcode_Type := Opcode_Type'(0);
Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1);
Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2);
Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply
Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4);
Opcode_Finish_If: constant Opcode_Type := Opcode_Type'(5);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(6);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(7);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(9);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(10);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(11);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(12);
Opcode_Finish_Set: constant Opcode_Type := Opcode_Type'(6);
Opcode_Apply: constant Opcode_Type := Opcode_Type'(7);
Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(8);
Opcode_Read_List: constant Opcode_Type := Opcode_Type'(9);
Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(10);
Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(11);
Opcode_Close_List: constant Opcode_Type := Opcode_Type'(12);
Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(13);
-----------------------------------------------------------------------------
-- COMMON OBJECTS
@ -990,6 +991,17 @@ end if;
Source.Pointer_Slot(Cons_Cdr_Index) := Value;
end Set_Cdr;
function Get_Last_Cdr (Source: in Object_Pointer) return Object_Pointer is
pragma Assert (Is_Cons(Source));
Ptr: Object_Pointer := Source;
begin
loop
Ptr := Get_Cdr(Ptr);
exit when not Is_Cons(Ptr);
end loop;
return Ptr;
end Get_Last_Cdr;
function Reverse_Cons (Source: in Object_Pointer;
Last_Cdr: in Object_Pointer := Nil_Pointer) return Object_Pointer is
pragma Assert (Is_Cons(Source));
@ -1151,7 +1163,24 @@ Ada.Text_IO.Put_Line ("Make_String...");
return null; -- not found. note that it's not Nil_Pointer.
end Find_In_Environment_List;
procedure Set_Environment (Interp: in out Interpreter_Record;
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
Arr: Object_Pointer;
@ -1182,8 +1211,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- overwrite an existing pair
Arr.Pointer_Slot(2) := Value;
end if;
end Set_Environment;
end Put_Environment;
function Get_Environment (Interp: access Interpreter_Record;
Key: in Object_Pointer) return Object_Pointer is
@ -1261,7 +1289,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- Link it to the top environement
pragma Assert (Interp.Environment = Interp.Root_Environment);
pragma Assert (Get_Environment (Interp.Self, Symbol) = null);
Set_Environment (Interp.all, Symbol, Proc);
Put_Environment (Interp.all, Symbol, Proc);
Pop_Tops (Interp.all, 2);
return Proc;