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

made 'if' and 'define' continuation-friendly

Browse Source
This commit is contained in:
hyung-hwan 2014-02-07 16:25:38 +00:00
parent 8b0444593a
commit d3363e11e5
4 changed files with 68 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
cmd/scheme.adb
View File

@ -58,36 +58,6 @@ S.Run_Loop (SI, I);
S.Print (SI, I);
S.Close (SI);
declare
subtype x is S.Object_Record (S.Moved_Object, 0);
subtype y is S.Object_Record (S.Pointer_Object, 1);
subtype z is S.Object_Record (S.Character_Object, 1);
subtype q is S.Object_Record (S.Byte_Object, 1);
a: x;
b: y;
c: z;
d: q;
w: S.Object_Word;
begin
Ada.Text_Io.Put_Line (S.Object_Word'Image(w'Size));
Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Word'Size));
Ada.Text_IO.Put_Line ("------");
Ada.Text_Io.Put_Line (S.Object_Word'Image(x'Size));
Ada.Text_Io.Put_Line (S.Object_Word'Image(y'Size));
Ada.Text_Io.Put_Line (S.Object_Word'Image(z'Size));
Ada.Text_Io.Put_Line (S.Object_Word'Image(q'Size));
Ada.Text_Io.Put_Line (S.Object_Word'Image(x'Max_Size_In_Storage_Elements));
Ada.Text_Io.Put_Line (S.Object_Word'Image(y'Max_Size_In_Storage_Elements));
Ada.Text_Io.Put_Line (S.Object_Word'Image(z'Max_Size_In_Storage_Elements));
Ada.Text_Io.Put_Line (S.Object_Word'Image(q'Max_Size_In_Storage_Elements));
Ada.Text_Io.Put_Line (S.Object_Word'Image(a'Size));
Ada.Text_Io.Put_Line (S.Object_Word'Image(b'Size));
Ada.Text_Io.Put_Line (S.Object_Word'Image(c'Size));
Ada.Text_Io.Put_Line (S.Object_Word'Image(c'Size));
Ada.Text_Io.Put_Line (S.Object_Integer'Image(S.Object_Integer'First));
Ada.Text_Io.Put_Line (S.Object_Integer'Image(S.Object_Integer'Last));
end;
Ada.Text_IO.Put_Line ("BYE...");
end scheme;

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

@ -31,12 +31,10 @@ procedure Evaluate is
Ada.Text_IO.Put_LINE ("FUCKING cDR FOR DEFINE");
raise Syntax_Error;
else
Set_Frame_Opcode (Interp.Stack, Opcode);
Set_Frame_Operand (Interp.Stack, Get_Cdr(Operand)); -- <test2> onwards
Clear_Frame_Result (Interp.Stack);
-- arrange to evaluate <test1>
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand));
--Switch_Frame (Interp.Stack, Opcode, Get_Cdr(Operand), Nil_Pointer); -- <test2> onwards
--Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand)); -- <test1>
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Operand), Nil_Pointer); -- <test2> onwards
Push_Subframe (Interp, Opcode, Get_Cdr(Operand)); -- <test1> onwards
end if;
end Generic_And_Or_Syntax;
@ -64,7 +62,8 @@ procedure Evaluate is
Cdr := Get_Cdr(Operand);
if Is_Cons(Car) then
-- define a function: (define (add x y) ...)
null;
ada.text_io.put_line ("NOT IMPLEMENTED YET");
raise Syntax_Error;
elsif Is_Symbol(Car) then
-- define a symbol: (define x ...)
if Get_Cdr(Cdr) /= Nil_Pointer then
@ -73,13 +72,12 @@ procedure Evaluate is
end if;
Cdr := Get_Car(Cdr); -- Value
-- Arrange to finish defining after value evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Define_Symbol);
Set_Frame_Operand (Interp.Stack, Car);
Clear_Frame_Result (Interp.Stack);
-- Arrange to evalaute the value part
Push_Frame (Interp, Opcode_Evaluate_Object, Cdr);
-- Arrange to finish defining after value evaluation
-- and to evaluate the value part.
--Switch_Frame (Interp.Stack, Opccode_Define_Finish, Car);
--Push_Frame (Interp, Opcode_Evaluate_Object, Cdr);
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Cdr, Nil_Pointer);
Push_Subframe (Interp, Opcode_Define_Finish, Car);
else
Ada.Text_IO.Put_LINE ("NO SYMBOL NOR ARGUMENT LIST AFTER DEFINE");
raise Syntax_Error;
@ -128,14 +126,13 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
raise Syntax_Error;
end if;
-- Switch the current frame to execute action after <test> evaluation.
Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If_Syntax);
Set_Frame_Operand (Interp.Stack, Operand);
Clear_Frame_Result (Interp.Stack);
-- Arrange to evalaute the conditional
Push_Frame (Interp, Opcode_Evaluate_Object, Car);
-- Arrange to evaluate <consequent> or <alternate> after <test>
-- evaluation and to evaluate <test>. Use Switch_Frame/Push_Subframe
-- instead of Switch_Frame/Push_Frame for continuation to work.
--Switch_Frame (Interp.Stack, Opcode_If_Finish, Operand, Nil_Pointer);
--Push_Frame (Interp, Opcode_Evaluate_Object, Car);
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car, Nil_Pointer);
Push_Subframe (Interp, Opcode_If_Finish, Operand);
end Evaluate_If_Syntax;
procedure Evaluate_Lambda_Syntax is
@ -573,7 +570,6 @@ end;
-- Switch the current frame to evaluate <operator>
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car, Nil_Pointer);
-- Push a new frame to evaluate arguments.
Push_Subframe (Interp, Opcode_Procedure_Call, Cdr);
end if;

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

@ -27,6 +27,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
procedure Evaluate_Up_To is
X: Object_Pointer;
Y: Object_Pointer;
Opcode: Opcode_Type;
begin
X := Get_Frame_Operand(Interp.Stack);
Y := Get_Frame_Result(Interp.Stack);
@ -38,9 +39,12 @@ procedure Execute (Interp: in out Interpreter_Record) is
if Y /= V and then Is_Cons(X) then
-- The result is not what I look for.
-- Yet there are still more tests to evaluate.
Set_Frame_Operand (Interp.Stack, Get_Cdr(X));
Clear_Frame_Result (Interp.Stack);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
--Switch_Frame (Interp.Stack, Get_Frame_Opcode(Interp.Stack), Get_Cdr(X), Nil_Pointer);
--Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
Opcode := Get_Frame_Opcode(Interp.Stack);
Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer);
Push_SubFrame (Interp, Opcode, Get_Cdr(X));
else
-- Return the result of the last expression evaluated.
Return_Frame (Interp, Y);
@ -48,11 +52,11 @@ procedure Execute (Interp: in out Interpreter_Record) is
end Evaluate_Up_To;
procedure Finish_And_Syntax is new Evaluate_Up_To(False_Pointer);
procedure Finish_Or_Syntax is new Evaluate_Up_To(True_Pointer);
procedure Finish_Or_Syntax is new Evaluate_Up_To(True_Pointer); -----> this is wrong, it shoudl be able to specify "/= False_Pointer".
-- ----------------------------------------------------------------
procedure Finish_Define_Symbol is
pragma Inline (Finish_Define_Symbol);
procedure Do_Define_Finish is
pragma Inline (Do_Define_Finish);
X: Object_Pointer;
Y: aliased Object_Pointer;
begin
@ -63,21 +67,18 @@ procedure Execute (Interp: in out Interpreter_Record) is
pragma Assert (Is_Symbol(X));
Y := Get_Frame_Result(Interp.Stack); -- value list
Put_Environment (Interp, X, Y); -- gc point
Return_Frame (Interp, Y); -- Y is referenced here.
Pop_Tops (Interp, 1); -- Unmanage Y
end Finish_Define_Symbol;
end Do_Define_Finish;
procedure Finish_If_Syntax is
pragma Inline (Finish_If_Syntax);
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
-- ----------------------------------------------------------------
procedure Do_If_Finish is
pragma Inline (Do_If_Finish);
X: Object_Pointer;
Y: Object_Pointer;
begin
Push_Top (Interp, X'Unchecked_Access);
Push_Top (Interp, Y'Unchecked_Access);
X := Get_Frame_Operand(Interp.Stack); -- cons cell containing <consequent>
pragma Assert (Is_Cons(X));
@ -87,26 +88,37 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- <test> evaluated to #f.
X := Get_Cdr(X); -- cons cell containing <alternate>
if Is_Cons(X) then
-- Switch the current current to evaluate <alternate>
-- Keep the environment untouched.
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object);
Set_Frame_Operand (Interp.Stack, Get_Car(X));
Clear_Frame_Result (Interp.Stack);
-- Switch the current current to evaluate <alternate>
-- keeping the environment untouched. Use Pop_Frame and
-- Push_Frame instead of Switch_Frame for continuation.
-- If continuation has been created in <test>, continuation
-- can be made to this frame.
--
-- For example,
-- (if (define xx (call/cc call/cc))
-- (+ 10 20) (* 1 2 3 4))
-- (xx 99)
-- When (xx 99) is evaluated, continuation is made to
-- this frame. For this frame to evaluate <consequent> or
-- <alternate>, its opcode must remain as Opcode_If_Finish.
--Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer);
Pop_Frame (Interp);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
else
-- Return nil if no <alternate> is specified
Return_Frame (Interp, Nil_Pointer);
end if;
else
-- All values except #f are true values. evaluate <consequent>
-- Switch the current current to evaluate <consequent>
-- Keep the environment untouched.
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object);
Set_Frame_Operand (Interp.Stack, Get_Car(X));
Clear_Frame_Result (Interp.Stack);
-- All values except #f are true values. evaluate <consequent>.
-- Switch the current current to evaluate <consequent> keeping
-- the environment untouched. Use Pop_Frame and Push_Frame
-- instead of Switch_Frame for continuation to work.
--Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer);
Pop_Frame (Interp);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
end if;
Pop_Tops (Interp, 2);
end Finish_If_Syntax;
end Do_If_Finish;
-- ----------------------------------------------------------------
@ -165,7 +177,6 @@ procedure Execute (Interp: in out Interpreter_Record) is
R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Nil_Pointer);
X := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Continuation(X)); -- this procedure can be called for continuation only.
Pop_Frame (Interp);
Push_Frame_With_Intermediate (Interp, Opcode_Apply, X, R);
@ -912,7 +923,7 @@ begin
pragma Assert (Interp.Stack /= Nil_Pointer);
loop
--ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
case Get_Frame_Opcode(Interp.Stack) is
when Opcode_Exit =>
exit;
@ -929,15 +940,12 @@ begin
--when Opcode_Finish_Case_Syntax =>
--when Opcode_Finish_Cond_Syntax =>
when Opcode_Finish_Define_Symbol =>
Finish_Define_Symbol;
when Opcode_Finish_If_Syntax =>
Finish_If_Syntax; -- Conditional
when Opcode_Define_Finish =>
Do_Define_Finish;
when Opcode_Grouped_Call =>
Do_Grouped_Call;
when Opcode_If_Finish =>
Do_If_Finish; -- Conditional
when Opcode_Let_Binding =>
Do_Let_Binding;
when Opcode_Letast_Binding =>

4
lib/h2-scheme.adb
View File

@ -98,11 +98,11 @@ package body H2.Scheme is
Opcode_Evaluate_Result,
Opcode_Evaluate_Object,
Opcode_Finish_And_Syntax,
Opcode_Finish_Define_Symbol,
Opcode_Finish_If_Syntax,
Opcode_Finish_Or_Syntax,
Opcode_Define_Finish,
Opcode_Grouped_Call, -- (begin ...), closure apply, let body
Opcode_If_Finish,
Opcode_Let_Binding,
Opcode_Letast_Binding,
Opcode_Letast_Binding_Finish,