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

finished initial implementation of 'do'

Browse Source
This commit is contained in:
hyung-hwan 2014-02-18 14:07:41 +00:00
parent 07503c4da7
commit cffbaef42f
1 changed files with 52 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -206,7 +206,8 @@ procedure Execute (Interp: in out Interpreter_Record) is
begin begin
X := Get_Frame_Operand(Interp.Stack); X := Get_Frame_Operand(Interp.Stack);
if Is_True_Class(Get_Frame_Result(Interp.Stack)) then if Is_True_Class(Get_Frame_Result(Interp.Stack)) then
-- <test> is true -- <test> is true. arrange to break out of 'do'.
X := Get_Cdr(Get_Car(Get_Cdr(X))); X := Get_Cdr(Get_Car(Get_Cdr(X)));
if X = Nil_Pointer then if X = Nil_Pointer then
-- no expression after <test> -- no expression after <test>
@ -216,29 +217,73 @@ procedure Execute (Interp: in out Interpreter_Record) is
Reload_Frame (Interp, Opcode_Grouped_Call, X); Reload_Frame (Interp, Opcode_Grouped_Call, X);
end if; end if;
else else
-- <test> is false -- <test> is false.
Push_Top (Interp, X'Unchecked_Access); Push_Top (Interp, X'Unchecked_Access);
Reload_Frame (Interp, Opcode_Do_Step, X); Reload_Frame (Interp, Opcode_Do_Step, X);
X := Get_Cdr(Get_Cdr(X)); X := Get_Cdr(Get_Cdr(X));
if X /= Nil_Pointer then if X /= Nil_Pointer then
Push_Frame (Interp, Opcode_Grouped_Call, X); Push_Frame (Interp, Opcode_Grouped_Call, X);
end if; end if;
Pop_Tops (Interp, 1); Pop_Tops (Interp, 1);
end if; end if;
end Do_Do_Break; end Do_Do_Break;
procedure Do_Do_Step is procedure Do_Do_Step is
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
begin begin
-- arrange to evaluate <step> and update binding <variable>. -- arrange to evaluate <step> and update binding <variable>.
print (interp, Get_Car(Get_Frame_Operand(Interp.Stack))); Push_Top (Interp, X'Unchecked_Access);
Pop_Frame (Interp); X := Get_Frame_Operand(Interp.Stack);
Reload_Frame (Interp, Opcode_Do_Test, X);
X := Get_Car(X);
while Is_Cons(X) loop
Y := Get_Cdr(Get_Cdr(Get_Car(X)));
if Is_Cons(Y) then
Push_Top (Interp, Y'Unchecked_Access);
Push_Frame (Interp, Opcode_Do_Update, X);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Y)); -- first <step>
Pop_Tops (Interp, 1);
exit;
else
-- no <step>
X := Get_Cdr(X);
end if;
end loop;
Pop_Tops (Interp, 1);
end Do_Do_Step; end Do_Do_Step;
procedure Do_Do_Update is procedure Do_Do_Update is
X: aliased Object_Pointer;
Y: aliased Object_Pointer;
begin begin
Pop_Frame (Interp); Push_Top (Interp, X'Unchecked_Access);
null; X := Get_Frame_Operand(Interp.StacK);
Set_Parent_Environment (Interp, Get_Car(Get_Car(X)), Get_Frame_Result(Interp.Stack));
loop
X := Get_Cdr(X);
if Is_Cons(X) then
Y := Get_Cdr(Get_Cdr(Get_Car(X)));
if Is_Cons(Y) then
-- if <step> is specified
Push_Top (Interp, Y'Unchecked_Access);
Reload_Frame (Interp, Opcode_Do_Update, X);
Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Y)); -- <step>
Pop_Tops (Interp, 1);
exit;
end if;
else
-- no more <bindings>
Pop_Frame (Interp);
exit;
end if;
end loop;
Pop_Tops (Interp, 1);
end Do_Do_Update; end Do_Do_Update;
-- ---------------------------------------------------------------- -- ----------------------------------------------------------------